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")) { |
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; |