Commit | Line | Data |
---|---|---|
f9916dde A |
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 A |
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 A |
96 | } else { |
97 | $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed"); | |
98 | } | |
99 | } | |
100 | unless ($silent >= 2) { | |
2f2071b1 A |
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 A |
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 A |
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 A |
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; |