File Coverage

blib/lib/CPAN/InfoObj.pm
Criterion Covered Total %
statement 41 122 33.6
branch 9 58 15.5
condition 1 9 11.1
subroutine 9 14 64.2
pod 0 10 0.0
total 60 213 28.1


line stmt bran cond sub pod time code
1             # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
2             # vim: ts=4 sts=4 sw=4:
3             package CPAN::InfoObj;
4 12     12   53 use strict;
  12         17  
  12         377  
5              
6 12     12   4426 use CPAN::Debug;
  12         604  
  12         529  
7             @CPAN::InfoObj::ISA = qw(CPAN::Debug);
8              
9 12     12   61 use Cwd qw(chdir);
  12         16  
  12         1215  
10              
11 12         17284 use vars qw(
12             $VERSION
13 12     12   58 );
  12         15  
14             $VERSION = "5.5";
15              
16             sub ro {
17 81     81 0 69 my $self = shift;
18 81 100       248 exists $self->{RO} and return $self->{RO};
19             }
20              
21             #-> sub CPAN::InfoObj::cpan_userid
22             sub cpan_userid {
23 0     0 0 0 my $self = shift;
24 0         0 my $ro = $self->ro;
25 0 0       0 if ($ro) {
26 0   0     0 return $ro->{CPAN_USERID} || "N/A";
27             } else {
28 0         0 $self->debug("ID[$self->{ID}]");
29             # N/A for bundles found locally
30 0         0 return "N/A";
31             }
32             }
33              
34 76     76 0 258 sub id { shift->{ID}; }
35              
36             #-> sub CPAN::InfoObj::new ;
37             sub new {
38 21     21 0 68 my $this = bless {}, shift;
39 21         84 %$this = @_;
40 21         69 $this
41             }
42              
43             # The set method may only be used by code that reads index data or
44             # otherwise "objective" data from the outside world. All session
45             # related material may do anything else with instance variables but
46             # must not touch the hash under the RO attribute. The reason is that
47             # the RO hash gets written to Metadata file and is thus persistent.
48              
49             #-> sub CPAN::InfoObj::safe_chdir ;
50             sub safe_chdir {
51 0     0 0 0 my($self,$todir) = @_;
52             # we die if we cannot chdir and we are debuggable
53 0 0 0     0 Carp::confess("safe_chdir called without todir argument")
54             unless defined $todir and length $todir;
55 0 0       0 if (chdir $todir) {
56 0 0       0 $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
57             if $CPAN::DEBUG;
58             } else {
59 0 0       0 if (-e $todir) {
60 0 0       0 unless (-x $todir) {
61 0 0       0 unless (chmod 0755, $todir) {
62 0         0 my $cwd = CPAN::anycwd();
63 0         0 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
64             "permission to change the permission; cannot ".
65             "chdir to '$todir'\n");
66 0         0 $CPAN::Frontend->mysleep(5);
67 0         0 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
68             qq{to todir[$todir]: $!});
69             }
70             }
71             } else {
72 0         0 $CPAN::Frontend->mydie("Directory '$todir' has gone. Cannot continue.\n");
73             }
74 0 0       0 if (chdir $todir) {
75 0 0       0 $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
76             if $CPAN::DEBUG;
77             } else {
78 0         0 my $cwd = CPAN::anycwd();
79 0         0 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
80             qq{to todir[$todir] (a chmod has been issued): $!});
81             }
82             }
83             }
84              
85             #-> sub CPAN::InfoObj::set ;
86             sub set {
87 39     39 0 149 my($self,%att) = @_;
88 39         50 my $class = ref $self;
89              
90             # This must be ||=, not ||, because only if we write an empty
91             # reference, only then the set method will write into the readonly
92             # area. But for Distributions that spring into existence, maybe
93             # because of a typo, we do not like it that they are written into
94             # the readonly area and made permanent (at least for a while) and
95             # that is why we do not "allow" other places to call ->set.
96 39 50       71 unless ($self->id) {
97 0         0 CPAN->debug("Bug? Empty ID, rejecting");
98 0         0 return;
99             }
100 39   50     84 my $ro = $self->{RO} =
101             $CPAN::META->{readonly}{$class}{$self->id} ||= {};
102              
103 39         100 while (my($k,$v) = each %att) {
104 97         319 $ro->{$k} = $v;
105             }
106             }
107              
108             #-> sub CPAN::InfoObj::as_glimpse ;
109             sub as_glimpse {
110 0     0 0 0 my($self) = @_;
111 0         0 my(@m);
112 0         0 my $class = ref($self);
113 0         0 $class =~ s/^CPAN:://;
114 0 0       0 my $id = $self->can("pretty_id") ? $self->pretty_id : $self->{ID};
115 0         0 push @m, sprintf "%-15s %s\n", $class, $id;
116 0         0 join "", @m;
117             }
118              
119             #-> sub CPAN::InfoObj::as_string ;
120             sub as_string {
121 1     1 0 2 my($self) = @_;
122 1         2 my(@m);
123 1         2 my $class = ref($self);
124 1         6 $class =~ s/^CPAN:://;
125 1         5 push @m, $class, " id = $self->{ID}\n";
126 1         1 my $ro;
127 1 50       6 unless ($ro = $self->ro) {
128 0 0       0 if (substr($self->{ID},-1,1) eq ".") { # directory
129 0         0 $ro = +{};
130             } else {
131 0         0 $CPAN::Frontend->mywarn("Unknown object $self->{ID}\n");
132 0         0 $CPAN::Frontend->mysleep(5);
133 0         0 return;
134             }
135             }
136 1         7 for (sort keys %$ro) {
137             # next if m/^(ID|RO)$/;
138 2         3 my $extra = "";
139 2 50       7 if ($_ eq "CPAN_USERID") {
    100          
140 0         0 $extra .= " (";
141 0         0 $extra .= $self->fullname;
142 0         0 my $email; # old perls!
143 0 0       0 if ($email = $CPAN::META->instance("CPAN::Author",
144             $self->cpan_userid
145             )->email) {
146 0         0 $extra .= " <$email>";
147             } else {
148 0         0 $extra .= " ";
149             }
150 0         0 $extra .= ")";
151             } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
152 1         6 push @m, sprintf " %-12s %s\n", $_, $self->fullname;
153 1         3 next;
154             }
155 1 50       21 next unless defined $ro->{$_};
156 1         7 push @m, sprintf " %-12s %s%s\n", $_, $ro->{$_}, $extra;
157             }
158 1         5 KEY: for (sort keys %$self) {
159 2 50       9 next if m/^(ID|RO)$/;
160 0 0       0 unless (defined $self->{$_}) {
161 0         0 delete $self->{$_};
162 0         0 next KEY;
163             }
164 0 0       0 if (ref($self->{$_}) eq "ARRAY") {
    0          
165 0         0 push @m, sprintf " %-12s %s\n", $_, "@{$self->{$_}}";
  0         0  
166             } elsif (ref($self->{$_}) eq "HASH") {
167 0         0 my $value;
168 0 0       0 if (/^CONTAINSMODS$/) {
    0          
169 0         0 $value = join(" ",sort keys %{$self->{$_}});
  0         0  
170             } elsif (/^prereq_pm$/) {
171 0         0 my @value;
172 0         0 my $v = $self->{$_};
173 0         0 for my $x (sort keys %$v) {
174 0         0 my @svalue;
175 0         0 for my $y (sort keys %{$v->{$x}}) {
  0         0  
176 0         0 push @svalue, "$y=>$v->{$x}{$y}";
177             }
178 0 0       0 push @value, "$x\:" . join ",", @svalue if @svalue;
179             }
180 0         0 $value = join ";", @value;
181             } else {
182 0         0 $value = $self->{$_};
183             }
184 0         0 push @m, sprintf(
185             " %-12s %s\n",
186             $_,
187             $value,
188             );
189             } else {
190 0         0 push @m, sprintf " %-12s %s\n", $_, $self->{$_};
191             }
192             }
193 1         6 join "", @m, "\n";
194             }
195              
196             #-> sub CPAN::InfoObj::fullname ;
197             sub fullname {
198 0     0 0   my($self) = @_;
199 0           $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
200             }
201              
202             #-> sub CPAN::InfoObj::dump ;
203             sub dump {
204 0     0 0   my($self, $what) = @_;
205 0 0         unless ($CPAN::META->has_inst("Data::Dumper")) {
206 0           $CPAN::Frontend->mydie("dump command requires Data::Dumper installed");
207             }
208 0           local $Data::Dumper::Sortkeys;
209 0           $Data::Dumper::Sortkeys = 1;
210 0 0         my $out = Data::Dumper::Dumper($what ? eval $what : $self);
211 0 0         if (length $out > 100000) {
212 0           my $fh_pager = FileHandle->new;
213 0           local($SIG{PIPE}) = "IGNORE";
214 0   0       my $pager = $CPAN::Config->{'pager'} || "cat";
215 0 0         $fh_pager->open("|$pager")
216             or die "Could not open pager $pager\: $!";
217 0           $fh_pager->print($out);
218 0           close $fh_pager;
219             } else {
220 0           $CPAN::Frontend->myprint($out);
221             }
222             }
223              
224             1;