lib/CPAN/Author.pm

   1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
   2 # vim: ts=4 sts=4 sw=4:
   3 package CPAN::Author;
   4 use strict;
   5
   6 use CPAN::InfoObj;
   7 @CPAN::Author::ISA = qw(CPAN::InfoObj);
   8 use vars qw(
   9             $VERSION
  10 );
  11 $VERSION = "5.5";
  12
  13 package CPAN::Author;
  14 use strict;
  15
  16 #-> sub CPAN::Author::force
  17 sub force {
  18     my $self = shift;
  19     $self->{force}++;
  20 }
  21
  22 #-> sub CPAN::Author::force
  23 sub unforce {
  24     my $self = shift;
  25     delete $self->{force};
  26 }
  27
  28 #-> sub CPAN::Author::id
  29 sub id {
  30     my $self = shift;
  31     my $id = $self->{ID};
  32     $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
  33     $id;
  34 }
  35
  36 #-> sub CPAN::Author::as_glimpse ;
  37 sub as_glimpse {
  38     my($self) = @_;
  39     my(@m);
  40     my $class = ref($self);
  41     $class =~ s/^CPAN:://;
  42     push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
  43                      $class,
  44                      $self->{ID},
  45                      $self->fullname,
  46                      $self->email);
  47     join "", @m;
  48 }
  49
  50 #-> sub CPAN::Author::fullname ;
  51 sub fullname {
  52     shift->ro->{FULLNAME};
  53 }
  54 *name = \&fullname;
  55
  56 #-> sub CPAN::Author::email ;
  57 sub email    { shift->ro->{EMAIL}; }
  58
  59 #-> sub CPAN::Author::ls ;
  60 sub ls {
  61     my $self = shift;
  62     my $glob = shift || "";
  63     my $silent = shift || 0;
  64     my $id = $self->id;
  65
  66     # adapted from CPAN::Distribution::verifyCHECKSUM ;
  67     my(@csf); # chksumfile
  68     @csf = $self->id =~ /(.)(.)(.*)/;
  69     $csf[1] = join "", @csf[0,1];
  70     $csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK")
  71     my(@dl);
  72     @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1);
  73     unless (grep {$_->[2] eq $csf[1]} @dl) {
  74         $CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ;
  75         return;
  76     }
  77     @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
  78     unless (grep {$_->[2] eq $csf[2]} @dl) {
  79         $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent;
  80         return;
  81     }
  82     @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
  83     if ($glob) {
  84         if ($CPAN::META->has_inst("Text::Glob")) {
  85             my $rglob = Text::Glob::glob_to_regex($glob);
  86             @dl = grep { $_->[2] =~ /$rglob/ } @dl;
  87         } else {
  88             $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
  89         }
  90     }
  91     unless ($silent >= 2) {
  92         $CPAN::Frontend->myprint(join "", map {
  93             sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
  94         } sort { $a->[2] cmp $b->[2] } @dl);
  95     }
  96     @dl;
  97 }
  98
  99 # returns an array of arrays, the latter contain (size,mtime,filename)
 100 #-> sub CPAN::Author::dir_listing ;
 101 sub dir_listing {
 102     my $self = shift;
 103     my $chksumfile = shift;
 104     my $recursive = shift;
 105     my $may_ftp = shift;
 106
 107     my $lc_want =
 108         File::Spec->catfile($CPAN::Config->{keep_source_where},
 109                             "authors", "id", @$chksumfile);
 110
 111     my $fh;
 112
 113     # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
 114     # hazard.  (Without GPG installed they are not that much better,
 115     # though.)
 116     $fh = FileHandle->new;
 117     if (open($fh, $lc_want)) {
 118         my $line = <$fh>; close $fh;
 119         unlink($lc_want) unless $line =~ /PGP/;
 120     }
 121
 122     local($") = "/";
 123     # connect "force" argument with "index_expire".
 124     my $force = $self->{force};
 125     if (my @stat = stat $lc_want) {
 126         $force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
 127     }
 128     my $lc_file;
 129     if ($may_ftp) {
 130         $lc_file = CPAN::FTP->localize(
 131                                        "authors/id/@$chksumfile",
 132                                        $lc_want,
 133                                        $force,
 134                                       );
 135         unless ($lc_file) {
 136             $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
 137             $chksumfile->[-1] .= ".gz";
 138             $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
 139                                            "$lc_want.gz",1);
 140             if ($lc_file) {
 141                 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
 142                 eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
 143             } else {
 144                 return;
 145             }
 146         }
 147     } else {
 148         $lc_file = $lc_want;
 149         # we *could* second-guess and if the user has a file: URL,
 150         # then we could look there. But on the other hand, if they do
 151         # have a file: URL, wy did they choose to set
 152         # $CPAN::Config->{show_upload_date} to false?
 153     }
 154
 155     # adapted from CPAN::Distribution::CHECKSUM_check_file ;
 156     $fh = FileHandle->new;
 157     my($cksum);
 158     if (open $fh, $lc_file) {
 159         local($/);
 160         my $eval = <$fh>;
 161         $eval =~ s/\015?\012/\n/g;
 162         close $fh;
 163         my($compmt) = Safe->new();
 164         $cksum = $compmt->reval($eval);
 165         if ($@) {
 166             rename $lc_file, "$lc_file.bad";
 167             Carp::confess($@) if $@;
 168         }
 169     } elsif ($may_ftp) {
 170         Carp::carp ("Could not open '$lc_file' for reading.");
 171     } else {
 172         # Maybe should warn: "You may want to set show_upload_date to a true value"
 173         return;
 174     }
 175     my(@result,$f);
 176     for $f (sort keys %$cksum) {
 177         if (exists $cksum->{$f}{isdir}) {
 178             if ($recursive) {
 179                 my(@dir) = @$chksumfile;
 180                 pop @dir;
 181                 push @dir, $f, "CHECKSUMS";
 182                 push @result, map {
 183                     [$_->[0], $_->[1], "$f/$_->[2]"]
 184                 } $self->dir_listing(\@dir,1,$may_ftp);
 185             } else {
 186                 push @result, [ 0, "-", $f ];
 187             }
 188         } else {
 189             push @result, [
 190                            ($cksum->{$f}{"size"}||0),
 191                            $cksum->{$f}{"mtime"}||"---",
 192                            $f
 193                           ];
 194         }
 195     }
 196     @result;
 197 }
 198
 199 #-> sub CPAN::Author::reports
 200 sub reports {
 201     $CPAN::Frontend->mywarn("reports on authors not implemented.
 202 Please file a bugreport if you need this.\n");
 203 }
 204
 205 1;