File Coverage

blib/lib/CPAN/Author.pm
Criterion Covered Total %
statement 17 126 13.4
branch 1 50 2.0
condition 0 14 0.0
subroutine 6 13 46.1
pod 0 9 0.0
total 24 212 11.3


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