Commit | Line | Data |
f9916dde |
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")) { |
2f2071b1 |
85 | $glob =~ s|/$|/*|; |
f9916dde |
86 | my $rglob = Text::Glob::glob_to_regex($glob); |
2f2071b1 |
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; |
f9916dde |
96 | } else { |
97 | $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed"); |
98 | } |
99 | } |
100 | unless ($silent >= 2) { |
2f2071b1 |
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 | ); |
f9916dde |
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 | |
2f2071b1 |
134 | CPAN->debug("chksumfile[@$chksumfile]recursive[$recursive]may_ftp[$may_ftp]") if $CPAN::DEBUG; |
f9916dde |
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"; |
2f2071b1 |
204 | push @result, [ 0, "-", $f ]; |
f9916dde |
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; |