lib/CPAN/InfoObj.pm

   1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
   2 # vim: ts=4 sts=4 sw=4:
   3 package CPAN::InfoObj;
   4 use strict;
   5
   6 use CPAN::Debug;
   7 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
   8
   9 use Cwd qw(chdir);
  10
  11 use vars qw(
  12             $VERSION
  13 );
  14 $VERSION = "5.5";
  15
  16 sub ro {
  17     my $self = shift;
  18     exists $self->{RO} and return $self->{RO};
  19 }
  20
  21 #-> sub CPAN::InfoObj::cpan_userid
  22 sub 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
  34 sub id { shift->{ID}; }
  35
  36 #-> sub CPAN::InfoObj::new ;
  37 sub 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 ;
  50 sub 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 ;
  86 sub 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 ;
 109 sub 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 ;
 120 sub 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 ;
 197 sub fullname {
 198     my($self) = @_;
 199     $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
 200 }
 201
 202 #-> sub CPAN::InfoObj::dump ;
 203 sub 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
 224 1;