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             $glob =~ s|/$|/*|;
  86             my $rglob = Text::Glob::glob_to_regex($glob);
  87             CPAN->debug("glob[$glob]rglob[$rglob]dl[@dl]") if $CPAN::DEBUG;
  88             my @tmpdl = grep { $_->[2] =~ /$rglob/ } @dl;
  89             if (1==@tmpdl && $tmpdl[0][0]==0) {
  90                 $rglob = Text::Glob::glob_to_regex("$glob/*");
  91                 @dl = grep { $_->[2] =~ /$rglob/ } @dl;
  92             } else {
  93                 @dl = @tmpdl;
  94             }
  95             CPAN->debug("rglob[$rglob]dl[@dl]") if $CPAN::DEBUG;
  96         } else {
  97             $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
  98         }
  99     }
 100     unless ($silent >= 2) {
 101         $CPAN::Frontend->myprint
 102             (
 103              join "",
 104              map {
 105                  sprintf
 106                      (
 107                       "%8d %10s %s/%s%s\n",
 108                       $_->[0],
 109                       $_->[1],
 110                       $id,
 111                       $_->[2],
 112                       0==$_->[0]?"/":"",
 113                      )
 114                  } sort { $a->[2] cmp $b->[2] } @dl
 115             );
 116     }
 117     @dl;
 118 }
 119
 120 # returns an array of arrays, the latter contain (size,mtime,filename)
 121 #-> sub CPAN::Author::dir_listing ;
 122 sub dir_listing {
 123     my $self = shift;
 124     my $chksumfile = shift;
 125     my $recursive = shift;
 126     my $may_ftp = shift;
 127
 128     my $lc_want =
 129         File::Spec->catfile($CPAN::Config->{keep_source_where},
 130                             "authors", "id", @$chksumfile);
 131
 132     my $fh;
 133
 134     CPAN->debug("chksumfile[@$chksumfile]recursive[$recursive]may_ftp[$may_ftp]") if $CPAN::DEBUG;
 135     # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
 136     # hazard.  (Without GPG installed they are not that much better,
 137     # though.)
 138     $fh = FileHandle->new;
 139     if (open($fh, $lc_want)) {
 140         my $line = <$fh>; close $fh;
 141         unlink($lc_want) unless $line =~ /PGP/;
 142     }
 143
 144     local($") = "/";
 145     # connect "force" argument with "index_expire".
 146     my $force = $self->{force};
 147     if (my @stat = stat $lc_want) {
 148         $force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
 149     }
 150     my $lc_file;
 151     if ($may_ftp) {
 152         $lc_file = CPAN::FTP->localize(
 153                                        "authors/id/@$chksumfile",
 154                                        $lc_want,
 155                                        $force,
 156                                       );
 157         unless ($lc_file) {
 158             $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
 159             $chksumfile->[-1] .= ".gz";
 160             $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
 161                                            "$lc_want.gz",1);
 162             if ($lc_file) {
 163                 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
 164                 eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
 165             } else {
 166                 return;
 167             }
 168         }
 169     } else {
 170         $lc_file = $lc_want;
 171         # we *could* second-guess and if the user has a file: URL,
 172         # then we could look there. But on the other hand, if they do
 173         # have a file: URL, wy did they choose to set
 174         # $CPAN::Config->{show_upload_date} to false?
 175     }
 176
 177     # adapted from CPAN::Distribution::CHECKSUM_check_file ;
 178     $fh = FileHandle->new;
 179     my($cksum);
 180     if (open $fh, $lc_file) {
 181         local($/);
 182         my $eval = <$fh>;
 183         $eval =~ s/\015?\012/\n/g;
 184         close $fh;
 185         my($compmt) = Safe->new();
 186         $cksum = $compmt->reval($eval);
 187         if ($@) {
 188             rename $lc_file, "$lc_file.bad";
 189             Carp::confess($@) if $@;
 190         }
 191     } elsif ($may_ftp) {
 192         Carp::carp ("Could not open '$lc_file' for reading.");
 193     } else {
 194         # Maybe should warn: "You may want to set show_upload_date to a true value"
 195         return;
 196     }
 197     my(@result,$f);
 198     for $f (sort keys %$cksum) {
 199         if (exists $cksum->{$f}{isdir}) {
 200             if ($recursive) {
 201                 my(@dir) = @$chksumfile;
 202                 pop @dir;
 203                 push @dir, $f, "CHECKSUMS";
 204                 push @result, [ 0, "-", $f ];
 205                 push @result, map {
 206                     [$_->[0], $_->[1], "$f/$_->[2]"]
 207                 } $self->dir_listing(\@dir,1,$may_ftp);
 208             } else {
 209                 push @result, [ 0, "-", $f ];
 210             }
 211         } else {
 212             push @result, [
 213                            ($cksum->{$f}{"size"}||0),
 214                            $cksum->{$f}{"mtime"}||"---",
 215                            $f
 216                           ];
 217         }
 218     }
 219     @result;
 220 }
 221
 222 #-> sub CPAN::Author::reports
 223 sub reports {
 224     $CPAN::Frontend->mywarn("reports on authors not implemented.
 225 Please file a bugreport if you need this.\n");
 226 }
 227
 228 1;