1# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- 2# vim: ts=4 sts=4 sw=4: 3package CPAN::InfoObj; 4use strict; 5 6use CPAN::Debug; 7@CPAN::InfoObj::ISA = qw(CPAN::Debug); 8 9use Cwd qw(chdir); 10 11use vars qw( 12 $VERSION 13); 14$VERSION = "5.5"; 15 16sub ro { 17 my $self = shift; 18 exists $self->{RO} and return $self->{RO}; 19} 20 21#-> sub CPAN::InfoObj::cpan_userid 22sub cpan_userid { 23 my $self = shift; 24 my $ro = $self->ro; 25 if ($ro) { 26 return $ro->{CPAN_USERID} || "N/A"; 27 } else { 28 $self->debug("ID[$self->{ID}]"); 29 # N/A for bundles found locally 30 return "N/A"; 31 } 32} 33 34sub id { shift->{ID}; } 35 36#-> sub CPAN::InfoObj::new ; 37sub new { 38 my $this = bless {}, shift; 39 %$this = @_; 40 $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 ; 50sub safe_chdir { 51 my($self,$todir) = @_; 52 # we die if we cannot chdir and we are debuggable 53 Carp::confess("safe_chdir called without todir argument") 54 unless defined $todir and length $todir; 55 if (chdir $todir) { 56 $self->debug(sprintf "changed directory to %s", CPAN::anycwd()) 57 if $CPAN::DEBUG; 58 } else { 59 if (-e $todir) { 60 unless (-x $todir) { 61 unless (chmod 0755, $todir) { 62 my $cwd = CPAN::anycwd(); 63 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ". 64 "permission to change the permission; cannot ". 65 "chdir to '$todir'\n"); 66 $CPAN::Frontend->mysleep(5); 67 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }. 68 qq{to todir[$todir]: $!}); 69 } 70 } 71 } else { 72 $CPAN::Frontend->mydie("Directory '$todir' has gone. Cannot continue.\n"); 73 } 74 if (chdir $todir) { 75 $self->debug(sprintf "changed directory to %s", CPAN::anycwd()) 76 if $CPAN::DEBUG; 77 } else { 78 my $cwd = CPAN::anycwd(); 79 $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 ; 86sub set { 87 my($self,%att) = @_; 88 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 unless ($self->id) { 97 CPAN->debug("Bug? Empty ID, rejecting"); 98 return; 99 } 100 my $ro = $self->{RO} = 101 $CPAN::META->{readonly}{$class}{$self->id} ||= {}; 102 103 while (my($k,$v) = each %att) { 104 $ro->{$k} = $v; 105 } 106} 107 108#-> sub CPAN::InfoObj::as_glimpse ; 109sub as_glimpse { 110 my($self) = @_; 111 my(@m); 112 my $class = ref($self); 113 $class =~ s/^CPAN:://; 114 my $id = $self->can("pretty_id") ? $self->pretty_id : $self->{ID}; 115 push @m, sprintf "%-15s %s\n", $class, $id; 116 join "", @m; 117} 118 119#-> sub CPAN::InfoObj::as_string ; 120sub as_string { 121 my($self) = @_; 122 my(@m); 123 my $class = ref($self); 124 $class =~ s/^CPAN:://; 125 push @m, $class, " id = $self->{ID}\n"; 126 my $ro; 127 unless ($ro = $self->ro) { 128 if (substr($self->{ID},-1,1) eq ".") { # directory 129 $ro = +{}; 130 } else { 131 $CPAN::Frontend->mywarn("Unknown object $self->{ID}\n"); 132 $CPAN::Frontend->mysleep(5); 133 return; 134 } 135 } 136 for (sort keys %$ro) { 137 # next if m/^(ID|RO)$/; 138 my $extra = ""; 139 if ($_ eq "CPAN_USERID") { 140 $extra .= " ("; 141 $extra .= $self->fullname; 142 my $email; # old perls! 143 if ($email = $CPAN::META->instance("CPAN::Author", 144 $self->cpan_userid 145 )->email) { 146 $extra .= " <$email>"; 147 } else { 148 $extra .= " <no email>"; 149 } 150 $extra .= ")"; 151 } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion 152 push @m, sprintf " %-12s %s\n", $_, $self->fullname; 153 next; 154 } 155 next unless defined $ro->{$_}; 156 push @m, sprintf " %-12s %s%s\n", $_, $ro->{$_}, $extra; 157 } 158 KEY: for (sort keys %$self) { 159 next if m/^(ID|RO)$/; 160 unless (defined $self->{$_}) { 161 delete $self->{$_}; 162 next KEY; 163 } 164 if (ref($self->{$_}) eq "ARRAY") { 165 push @m, sprintf " %-12s %s\n", $_, "@{$self->{$_}}"; 166 } elsif (ref($self->{$_}) eq "HASH") { 167 my $value; 168 if (/^CONTAINSMODS$/) { 169 $value = join(" ",sort keys %{$self->{$_}}); 170 } elsif (/^prereq_pm$/) { 171 my @value; 172 my $v = $self->{$_}; 173 for my $x (sort keys %$v) { 174 my @svalue; 175 for my $y (sort keys %{$v->{$x}}) { 176 push @svalue, "$y=>$v->{$x}{$y}"; 177 } 178 push @value, "$x\:" . join ",", @svalue if @svalue; 179 } 180 $value = join ";", @value; 181 } else { 182 $value = $self->{$_}; 183 } 184 push @m, sprintf( 185 " %-12s %s\n", 186 $_, 187 $value, 188 ); 189 } else { 190 push @m, sprintf " %-12s %s\n", $_, $self->{$_}; 191 } 192 } 193 join "", @m, "\n"; 194} 195 196#-> sub CPAN::InfoObj::fullname ; 197sub fullname { 198 my($self) = @_; 199 $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname; 200} 201 202#-> sub CPAN::InfoObj::dump ; 203sub dump { 204 my($self, $what) = @_; 205 unless ($CPAN::META->has_inst("Data::Dumper")) { 206 $CPAN::Frontend->mydie("dump command requires Data::Dumper installed"); 207 } 208 local $Data::Dumper::Sortkeys; 209 $Data::Dumper::Sortkeys = 1; 210 my $out = Data::Dumper::Dumper($what ? eval $what : $self); 211 if (length $out > 100000) { 212 my $fh_pager = FileHandle->new; 213 local($SIG{PIPE}) = "IGNORE"; 214 my $pager = $CPAN::Config->{'pager'} || "cat"; 215 $fh_pager->open("|$pager") 216 or die "Could not open pager $pager\: $!"; 217 $fh_pager->print($out); 218 close $fh_pager; 219 } else { 220 $CPAN::Frontend->myprint($out); 221 } 222} 223 2241; 225