1 |
#!/bin/sh -- # -*- perl -*- -w |
2 |
eval 'exec perl -S $0 "$@"' |
3 |
if 0; |
4 |
|
5 |
use strict; |
6 |
|
7 |
use Config; |
8 |
use File::Basename qw(fileparse); |
9 |
|
10 |
my($file, $path) = fileparse($0); |
11 |
$file =~ s!\.PL$!!i; |
12 |
chdir($path) or die "Couldn't chdir to `$path': $!\n"; |
13 |
|
14 |
print "Extracting $file\n"; |
15 |
|
16 |
open(OUT, "> $file") or die "Couldn't create `$file': $!\n"; |
17 |
print OUT "$Config{'startperl'} -w\n"; |
18 |
while (<DATA>) { |
19 |
print OUT |
20 |
} |
21 |
close(OUT) or die "Couldn't close `$file': $!\n"; |
22 |
|
23 |
chmod(0755, $file) or die "Couldn't chmod 744 on `$file': $!\n"; |
24 |
|
25 |
exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; |
26 |
|
27 |
__END__ |
28 |
######################### -*- Mode: Perl -*- ######################### |
29 |
## |
30 |
## $Basename: cpan.PL $ |
31 |
## $Revision: 1.6 $ |
32 |
## |
33 |
## Author : Ulrich Pfeifer |
34 |
## Created On : Sat Jan 4 18:09:28 1997 |
35 |
## |
36 |
## Last Modified By : Ulrich Pfeifer |
37 |
## Last Modified On : Sun Nov 22 18:44:36 1998 |
38 |
## |
39 |
## Copyright (c) 1996-1997, Ulrich Pfeifer |
40 |
## |
41 |
## |
42 |
###################################################################### |
43 |
|
44 |
eval 'exec perl -S $0 "$@"' |
45 |
if 0; |
46 |
|
47 |
|
48 |
use strict; |
49 |
|
50 |
use File::Path; |
51 |
use DB_File; |
52 |
use Getopt::Long; |
53 |
use File::Find; |
54 |
use File::Basename; |
55 |
use IO::File; |
56 |
|
57 |
require WAIT::Config; |
58 |
require WAIT::Database; |
59 |
require WAIT::Parse::Pod; |
60 |
require WAIT::Document::Tar; |
61 |
|
62 |
|
63 |
my %OPT = (database => 'DB', |
64 |
dir => $WAIT::Config->{WAIT_home} || '/tmp', |
65 |
table => 'cpan', |
66 |
clean => 0, |
67 |
remove => [], |
68 |
force => 0, |
69 |
cpan => '/usr/src/perl/CPAN/sources', |
70 |
trust_mtime => 1, |
71 |
match => 'authors/id/', |
72 |
test => 0, |
73 |
# cpan => 'ftp://ftp.rz.ruhr-uni-bochum.de/pub/CPAN', |
74 |
cpan => 'ftp://ftp.uni-hamburg.de:/pub/soft/lang/perl/CPAN', |
75 |
keep => '/app/unido-i06/src/share/lang/perl/96a/CPAN/sources', |
76 |
); |
77 |
|
78 |
GetOptions(\%OPT, |
79 |
'database=s', |
80 |
'dir=s', |
81 |
'cpan=s', |
82 |
'table=s', |
83 |
'keep=s', |
84 |
'match=s', |
85 |
'clean!', |
86 |
'test=i', # test level 0: normal |
87 |
# 1: don't change db |
88 |
# 2: don't look at archives even |
89 |
|
90 |
'remove=s@', |
91 |
'force!', # force indexing even if seen |
92 |
'trust_mtime!', # use mtime instead of version number |
93 |
) || die "Usage: ...\n"; |
94 |
|
95 |
|
96 |
clean_database( |
97 |
database => $OPT{database}, |
98 |
dir => $OPT{dir}, |
99 |
table => $OPT{table}, |
100 |
) if $OPT{clean}; |
101 |
|
102 |
my $db = WAIT::Database->open( |
103 |
name => $OPT{database}, |
104 |
'directory' => $OPT{dir}, |
105 |
) |
106 |
|| WAIT::Database->create( |
107 |
name => $OPT{database}, |
108 |
'directory' => $OPT{dir}, |
109 |
) |
110 |
or die "Could not open/create database '$OPT{dir}/$OPT{database}': $@"; |
111 |
|
112 |
my $layout= new WAIT::Parse::Pod; |
113 |
|
114 |
my $tb = $db->table(name => $OPT{table}) |
115 |
|| create_table(db => $db, table => $OPT{table}, layout => $layout); |
116 |
|
117 |
# Map e.g. '.../latest' to 'perl'. Used in wanted(). Effects version |
118 |
# considerations. Value *must* match common prefix. Aliasing should be |
119 |
# used if CPAN contains serveral distributions with different name but |
120 |
# same root directory. |
121 |
# We still have a problem if there are different root directories! |
122 |
|
123 |
my %ALIAS = (# tar name real (root) name |
124 |
'latest' => 'perl', |
125 |
'perl5db-kit' => 'DB', |
126 |
'SGI-FM' => 'FM', |
127 |
'net-ext' => 'Net', |
128 |
'VelocisSQL' => 'Velocis', |
129 |
'Net-ext' => 'Net', |
130 |
'Curses-DevKit' => 'Cdk', |
131 |
'PostgresPerl' => 'Postgres', |
132 |
'perlpdf' => 'PERLPDF', |
133 |
'Des-perl' => 'Des', |
134 |
'SGI-GL' => 'GL', |
135 |
'DBD-DB2' => 'DB2', |
136 |
); |
137 |
my %NEW_ALIAS; # found in this pass |
138 |
|
139 |
# Map module names to pathes. Generated by wanted() doing alisaing. |
140 |
my %ARCHIVE; |
141 |
|
142 |
# Map module names to latest version. Generated by wanted() |
143 |
my %VERSION; |
144 |
|
145 |
|
146 |
# Mapping for modules with common root not matching modules name that |
147 |
# are not aliased. This is just for prefix stripping and not strictly |
148 |
# necessary. Takes effect after version considerations. |
149 |
my %TR = (# tar name root to strip |
150 |
'Net_SSLeay.pm' => 'SSLeay/', |
151 |
'EventDrivenServer' => 'Server/', |
152 |
'bio_lib.pl.' => '', |
153 |
'AlarmCall' => 'Sys/', |
154 |
'Cdk-ext' => 'Cdk/', |
155 |
'Sx' => '\d.\d/', |
156 |
'DumpStack' => 'Devel/', |
157 |
'StatisticsDescriptive'=> 'Statistics/', |
158 |
'Term-Gnuplot' => 'Gnuplot/', |
159 |
'iodbc_ext' => 'iodbc-ext-\d.\d/', |
160 |
'UNIVERSAL' => '', |
161 |
'Term-Query' => 'Query/', |
162 |
'SelfStubber' => 'Devel/', |
163 |
'CallerItem' => 'Devel/', |
164 |
); |
165 |
|
166 |
my $DIR = $tb->dir; |
167 |
my $DATA = $tb->dir . "/data"; |
168 |
my $LWP; |
169 |
|
170 |
|
171 |
if (@{$OPT{remove}}) { |
172 |
my $pod; |
173 |
for $pod (@{$OPT{remove}}) { |
174 |
unless (-e $pod) { |
175 |
$pod = "$DIR/$pod"; |
176 |
} |
177 |
index_pod(file => $pod, remove => 1) if -f $pod; |
178 |
unlink $pod or warn "Could not unlink '$pod': $!\n"; |
179 |
#$tb->sync; |
180 |
} |
181 |
$tb->close; |
182 |
$db->close; |
183 |
exit; |
184 |
} |
185 |
|
186 |
# Now get the beef |
187 |
if ($OPT{cpan} =~ /^(http|ftp):/) { |
188 |
$LWP = 1; |
189 |
require LWP::Simple; |
190 |
LWP::Simple->import(); |
191 |
|
192 |
mkpath($DATA,1,0755) or |
193 |
die "Could not generate '$DATA/': $!" |
194 |
unless -d $DATA; |
195 |
|
196 |
if (! -f "$DATA/find-ls.gz" or -M "$DATA/find-ls.gz" > 0.5) { |
197 |
my $status = mirror("$OPT{cpan}/indices/find-ls.gz", "$DATA/find-ls.gz"); |
198 |
if ($status != &RC_OK and $status != &RC_NOT_MODIFIED) { |
199 |
# we could use Net:FTP here ... |
200 |
die "Was unable to mirror '$OPT{cpan}/indices/find-ls.gz'\n"; |
201 |
} |
202 |
} |
203 |
my $fh = new IO::File "gzip -cd $DATA/find-ls.gz |"; |
204 |
die "Could not open 'gzip -cd $DATA/find-ls.gz': !$\n" unless $fh; |
205 |
|
206 |
my $line; |
207 |
while (defined ($line = <$fh>)) { |
208 |
chomp($line); |
209 |
my ($mon, $mday, $time, $file, $is_link) = (split ' ', $line)[7..11]; |
210 |
|
211 |
next if defined $is_link; |
212 |
my $mtime = mtime($mon, $mday, $time); |
213 |
|
214 |
$file =~ s:^\./::; |
215 |
($_) = fileparse($file); |
216 |
$File::Find::name = $file; |
217 |
wanted($mtime); |
218 |
} |
219 |
} else { |
220 |
find(sub {&wanted((stat($_))[9])}, $OPT{cpan}); |
221 |
} |
222 |
|
223 |
ARCHIVE: |
224 |
for my $tar (sort keys %ARCHIVE) { |
225 |
next if $OPT{match} and $ARCHIVE{$tar} !~ /$OPT{match}/o; |
226 |
my $base = (split /\//, $ARCHIVE{$tar})[-1]; |
227 |
my $parent; |
228 |
|
229 |
# logging |
230 |
if ($OPT{trust_mtime}) { |
231 |
printf "%-20s %10s %s\t", $tar, |
232 |
substr(scalar(localtime($VERSION{$tar})),0,10), $base; |
233 |
} else { |
234 |
printf "%-20s %10.5f %s\t", $tar, $VERSION{$tar}, $base; |
235 |
} |
236 |
|
237 |
# Remember the archive |
238 |
# We should have an extra table for the tar file data ... |
239 |
if (!$OPT{force} and $tb->have(docid => $base)) { |
240 |
print "skipping\n"; |
241 |
next ARCHIVE; |
242 |
} else { |
243 |
$parent = $tb->insert(docid => $base, |
244 |
headline => $ARCHIVE{$tar}) unless $OPT{test}; |
245 |
print "indexing\n"; |
246 |
} |
247 |
|
248 |
next ARCHIVE if $OPT{test} > 1; |
249 |
|
250 |
my $TAR = myget($tar); |
251 |
|
252 |
next ARCHIVE unless $TAR; # not able to fetch it |
253 |
|
254 |
my %tar; |
255 |
tie (%tar, |
256 |
'WAIT::Document::Tar', |
257 |
sub { $_[0] =~ /\.(pm|pod|PL)$/ or $_[0] =~ /readme/i}, |
258 |
#sub { $_[0] !~ m:/$: }, |
259 |
$TAR) |
260 |
or warn "Could not tie '$TAR'\n"; |
261 |
|
262 |
my $sloppy; |
263 |
my ($key, $val); |
264 |
|
265 |
FILE: |
266 |
while (($key, $val) = each %tar) { |
267 |
my $file = fname($key); |
268 |
|
269 |
# don't index directories |
270 |
next if $file =~ /\/$/; |
271 |
|
272 |
# is it a POD file? |
273 |
next FILE unless $file =~ /readme/i or $val =~ /\n=head/; |
274 |
|
275 |
# remove directory prefix |
276 |
unless ($sloppy # no common root |
277 |
or $file =~ s:^\Q$tar\E[^/]*/:: # common root, maybe alias |
278 |
or ($TR{$tar} # common root, not aliased |
279 |
and $file =~ s:^\Q$TR{$tar}\E::) |
280 |
) { |
281 |
# try to determine an alias |
282 |
warn "Bad directory prefix: '$file'\n"; |
283 |
my ($prefix) = split /\//, $file; |
284 |
|
285 |
while ($key = (tied %tar)->NEXTKEY) { |
286 |
my $file = fname($key); |
287 |
|
288 |
next if $file =~ /\/$/; |
289 |
unless ($file =~ m:^$prefix/: or $file eq $prefix) { |
290 |
warn "Archive contains different prefixes: $prefix,$file\n"; |
291 |
$prefix = ''; |
292 |
last; |
293 |
} |
294 |
} |
295 |
if ($prefix) { |
296 |
print "Please alias '$tar' to '$prefix' next time!\n"; |
297 |
print "See alias table later.\n"; |
298 |
$NEW_ALIAS{$tar} = $prefix; |
299 |
$tb->delete_by_key($parent); |
300 |
next ARCHIVE; |
301 |
} else { |
302 |
print "Assuming that tar file name $tar is a valid prefix\n"; |
303 |
$sloppy = 1; |
304 |
|
305 |
# We may reset too much here! But that this is not exact |
306 |
# science anyway. Maybe we should ignore using 'next ARCHIVE'. |
307 |
|
308 |
$key = (tied %tar)->FIRSTKEY; |
309 |
redo FILE; |
310 |
} |
311 |
} |
312 |
|
313 |
# remove /lib prefix |
314 |
$file =~ s:^lib/::; |
315 |
|
316 |
# generate new path |
317 |
my $path = "$DATA/$tar/$file"; |
318 |
|
319 |
my ($sbase, $sdir) = fileparse($path); |
320 |
my $fh; |
321 |
|
322 |
unless ($OPT{test}) { |
323 |
if (-f $path) { |
324 |
index_pod(file => $path, remove => 1); |
325 |
unlink $path or warn "Could not unlink '$path' $!\n"; |
326 |
} elsif (!-d $sdir) { |
327 |
mkpath($sdir,1,0755) or die "Could not mkpath($sdir): $!\n"; |
328 |
} |
329 |
$fh = new IO::File "> $path"; |
330 |
die "Could not write '$path': $!\n" unless $fh; |
331 |
} |
332 |
|
333 |
if ($file =~ /readme|install/i) { # make READMEs verbatim pods |
334 |
$val =~ s/\n/\n /g; |
335 |
$val = "=head1 NAME\n\n$tar $file\n\n=head1 DESCRIPTION\n\n $val" |
336 |
unless $val =~ /^=head/m; |
337 |
} else { # remove non-pod stuff |
338 |
my $nval = $val; $val = ''; |
339 |
my $cutting = 1; |
340 |
|
341 |
for (split /\n/, $nval) { |
342 |
if (/^=cut|!NO!SUBS!/) { |
343 |
$cutting = 1; |
344 |
} elsif ($cutting and /^=head/) { |
345 |
$cutting = 0; |
346 |
} |
347 |
unless ($cutting) { |
348 |
$val .= $_ . "\n"; |
349 |
} |
350 |
} |
351 |
} |
352 |
unless ($OPT{test}) { |
353 |
$fh->print($val); |
354 |
index_pod(file => $path, parent => $parent, |
355 |
text => $val, source => $ARCHIVE{$tar}); |
356 |
} |
357 |
} |
358 |
|
359 |
if ($LWP and !$OPT{keep}) { |
360 |
unlink $TAR or warn |
361 |
"Could not unlink '$TAR': $!\n"; |
362 |
} |
363 |
} |
364 |
|
365 |
if (%NEW_ALIAS) { |
366 |
print "\%ALIAS = (\n"; |
367 |
for (keys %NEW_ALIAS) { |
368 |
print "\t'$_'\t=> '$NEW_ALIAS{$_}',\n"; |
369 |
} |
370 |
print "\t);\n"; |
371 |
} |
372 |
|
373 |
# we are done |
374 |
$db->close(); |
375 |
exit; |
376 |
|
377 |
sub fname ($) { |
378 |
my $key = shift; |
379 |
my ($ntar, $file) = split $;, $key; |
380 |
|
381 |
# remove leading './' - shudder |
382 |
$file =~ s/^\.\///; |
383 |
|
384 |
return($file); |
385 |
} |
386 |
|
387 |
sub myget { |
388 |
my $tar = shift; |
389 |
my $TAR; |
390 |
|
391 |
if ($LWP) { # fetch the archive |
392 |
if ($OPT{keep}) { |
393 |
$TAR = "$OPT{keep}/$ARCHIVE{$tar}"; |
394 |
print "Keeping in '$TAR'\n" unless -e $TAR; |
395 |
my ($base, $path) = fileparse($TAR); |
396 |
unless (-d $path) { |
397 |
mkpath($path,1,0755) or |
398 |
die "Could not mkpath($path)\n"; |
399 |
} |
400 |
} else { |
401 |
$TAR = "/tmp/$tar.tar.gz"; |
402 |
} |
403 |
unless (-e $TAR) { # lwp mirror seems to fetch ftp: in any case? |
404 |
print "Fetching $OPT{cpan}/$ARCHIVE{$tar}\n"; |
405 |
my $status = mirror("$OPT{cpan}/$ARCHIVE{$tar}", $TAR); |
406 |
if ($status != &RC_OK and $status != &RC_NOT_MODIFIED) { |
407 |
warn "Was unable to mirror '$ARCHIVE{$tar}, skipping'\n"; |
408 |
return; |
409 |
} |
410 |
} |
411 |
} |
412 |
$TAR; |
413 |
} |
414 |
|
415 |
sub index_pod { |
416 |
my %parm = @_; |
417 |
my $did = $parm{file}; |
418 |
my $rel_did = $did; |
419 |
my $abs_did = $did; |
420 |
|
421 |
if ($rel_did =~ s:$DIR/::) { |
422 |
$abs_did = "$DIR/$rel_did"; |
423 |
} |
424 |
|
425 |
undef $did; |
426 |
|
427 |
# check for both variants |
428 |
if ($tb->have('docid' => $rel_did)) { |
429 |
$did = $rel_did; |
430 |
} elsif ($tb->have('docid' => $abs_did)) { |
431 |
$did = $abs_did; |
432 |
} |
433 |
if ($did) { # have it version |
434 |
if (!$parm{remove}) { |
435 |
warn "duplicate: $did\n"; |
436 |
return; |
437 |
} |
438 |
} else { # not seen yet |
439 |
$did = $rel_did; |
440 |
if ($parm{remove}) { |
441 |
print "missing: $did\n"; |
442 |
return; |
443 |
} |
444 |
} |
445 |
|
446 |
$parm{'text'} ||= WAIT::Document::Find->FETCH($abs_did); |
447 |
|
448 |
unless (defined $parm{'text'}) { |
449 |
print "unavailable: $did\n"; |
450 |
return; |
451 |
} |
452 |
|
453 |
my $record = $layout->split($parm{'text'}); |
454 |
$record->{size} = length($parm{'text'}); |
455 |
my $headline = $record->{name} || $did; |
456 |
|
457 |
$headline =~ s/^$DATA//o; # $did |
458 |
$headline =~ s/\s+/ /g; $headline =~ s/^\s+//; |
459 |
|
460 |
printf "%s %s\n", ($parm{remove})?'-':'+', substr($headline,0,70); |
461 |
if ($parm{remove}) { |
462 |
$tb->delete('docid' => $did, |
463 |
headline => $headline, |
464 |
%{$record}); |
465 |
} else { |
466 |
$tb->insert('docid' => $did, |
467 |
headline => $headline, |
468 |
source => $parm{source}, |
469 |
parent => $parm{parent}, |
470 |
%{$record}); |
471 |
} |
472 |
} |
473 |
|
474 |
# This *must* remove the version in *any* case. It should compute a |
475 |
# resonable version number - but usually mtimes should be used. |
476 |
sub version { |
477 |
local ($_) = @_; |
478 |
|
479 |
# remove alpha/beta postfix |
480 |
s/([-_\d])(a|b|alpha|beta|src)$/$1/; |
481 |
|
482 |
# jperl1.3@4.019.tar.gz |
483 |
s/@\d.\d+//; |
484 |
|
485 |
# oraperl-v2.4-gk.tar.gz |
486 |
s/-v(\d)/$1/; |
487 |
|
488 |
# lettered versions - shudder |
489 |
s/([-_\d\.])([a-z])([\d\._])/sprintf "$1%02d$3", ord(lc $2) - ord('a') /ei; |
490 |
s/([-_\d\.])([a-z])$/sprintf "$1%02d", ord(lc $2) - ord('a') /ei; |
491 |
|
492 |
# thanks libwww-5b12 ;-) |
493 |
s/(\d+)b/($1-1).'.'/e; |
494 |
s/(\d+)a/($1-2).'.'/e; |
495 |
|
496 |
# replace '-pre' by '0.' |
497 |
s/-pre([\.\d])/-0.$1/; |
498 |
s/\.\././g; |
499 |
s/(\d)_(\d)/$1$2/g; |
500 |
|
501 |
# chop '[-.]' and thelike |
502 |
s/\W$//; |
503 |
|
504 |
# ram's versions Storable-0.4@p |
505 |
s/\@/./; |
506 |
|
507 |
if (s/[-_]?(\d+)\.(0\d+)\.(\d+)$//) { |
508 |
return($_, $1 + "0.$2" + $3 / 1000000); |
509 |
} elsif (s/[-_]?(\d+)\.(\d+)\.(\d+)$//) { |
510 |
return($_, $1 + $2/1000 + $3 / 1000000); |
511 |
} elsif (s/[-_]?(\d+\.[\d_]+)$//) { |
512 |
return($_, $1); |
513 |
} elsif (s/[-_]?([\d_]+)$//) { |
514 |
return($_, $1); |
515 |
} elsif (s/-(\d+.\d+)-/-/) { # perl-4.019-ref-guide |
516 |
return($_, $1); |
517 |
} else { |
518 |
if ($_ =~ /\d/) { # smells like an unknown scheme |
519 |
warn "Odd version Numbering: '$File::Find::name'\n"; |
520 |
return($_, undef); |
521 |
} else { # assume version 0 |
522 |
warn "No version Numbering: '$File::Find::name'\n"; |
523 |
return($_, 0); |
524 |
} |
525 |
|
526 |
} |
527 |
} |
528 |
|
529 |
sub wanted { |
530 |
my $mtime = shift; # called by parse_file_ls(); |
531 |
|
532 |
return unless /^(.*)\.tar(\.gz|\.Z)$/; |
533 |
my ($archive, $version) = version($1); |
534 |
|
535 |
unless (defined $version) { |
536 |
warn "Skipping $1\n"; |
537 |
return; |
538 |
} |
539 |
|
540 |
# Check for file alias |
541 |
$archive = $ALIAS{$archive} if $ALIAS{$archive}; |
542 |
|
543 |
# Check for path alias. |
544 |
if ($File::Find::name =~ m(/CPAN/(?:source/)?(.*\Q$archive\E))) { |
545 |
if ($ALIAS{$1}) { |
546 |
$archive = $ALIAS{$1}; |
547 |
} |
548 |
} |
549 |
|
550 |
if ($OPT{trust_mtime}) { |
551 |
$version = $mtime; |
552 |
} else { |
553 |
$version =~ s/(\d)_/$1/; |
554 |
$version ||= $mtime; # mtime |
555 |
} |
556 |
|
557 |
if (!exists $ARCHIVE{$archive} |
558 |
or $VERSION{$archive} < $version) { |
559 |
$ARCHIVE{$archive} = $File::Find::name; |
560 |
$VERSION{$archive} = $version; |
561 |
} |
562 |
} |
563 |
|
564 |
sub clean_database { |
565 |
my %parm = @_; |
566 |
|
567 |
my $db = WAIT::Database->open( |
568 |
name => $parm{database}, |
569 |
'directory' => $parm{dir}, |
570 |
) |
571 |
or die "Could not open database '$parm{dir}/$parm{database}': $@"; |
572 |
my $tbl = $db->table(name => $parm{table}); |
573 |
if ($tbl) { |
574 |
$tbl->drop or |
575 |
die "Could not open table '$parm{tabel}': $@"; |
576 |
} |
577 |
|
578 |
$db->close; |
579 |
} |
580 |
|
581 |
sub create_table { |
582 |
my %parm = @_; |
583 |
|
584 |
my $access = bless {}, 'WAIT::Document::Find'; |
585 |
|
586 |
my $stem = [{ |
587 |
'prefix' => ['isotr', 'isolc'], |
588 |
'intervall' => ['isotr', 'isolc'], |
589 |
}, 'isotr', 'isolc', 'split2', 'stop', 'Stem']; |
590 |
my $text = [{ |
591 |
'prefix' => ['isotr', 'isolc'], |
592 |
'intervall' => ['isotr', 'isolc'], |
593 |
}, |
594 |
'isotr', 'isolc', 'split2', 'stop']; |
595 |
my $sound = ['isotr', 'isolc', 'split2', 'Soundex'],; |
596 |
|
597 |
my $tb = |
598 |
$parm{db}->create_table |
599 |
(name => $parm{table}, |
600 |
attr => ['docid', 'headline', 'source', 'size', 'parent'], |
601 |
keyset => [['docid']], |
602 |
layout => $parm{layout}, |
603 |
access => $access, |
604 |
invindex => |
605 |
[ |
606 |
'name' => $stem, |
607 |
'synopsis' => $stem, |
608 |
'bugs' => $stem, |
609 |
'description' => $stem, |
610 |
'text' => $stem, |
611 |
'environment' => $text, |
612 |
'example' => $text, 'example' => $stem, |
613 |
'author' => $sound, 'author' => $stem, |
614 |
] |
615 |
); |
616 |
die "Could not create table '$parm{table}'" unless $tb; |
617 |
$tb; |
618 |
} |
619 |
|
620 |
my %MON; |
621 |
my $YEAR; |
622 |
|
623 |
BEGIN { |
624 |
my $i = 1; |
625 |
for (qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec)) { |
626 |
$MON{$_} = $i++; |
627 |
} |
628 |
$YEAR = (localtime(time))[5]; |
629 |
} |
630 |
|
631 |
# We could/should use Date::GetDate here |
632 |
use Time::Local; |
633 |
sub mtime { |
634 |
my ($mon, $mday, $time) = @_; |
635 |
my ($hour, $min, $year, $monn) = (0,0); |
636 |
|
637 |
if ($time =~ /(\d+):(\d+)/) { |
638 |
($hour, $min) = ($1, $2); |
639 |
$year = $YEAR; |
640 |
} else { |
641 |
$year = $time; |
642 |
} |
643 |
$monn = $MON{$mon} || $MON{ucfirst lc $mon} || warn "Unknown month: '$mon'"; |
644 |
my $guess = timelocal(0,$min,$hour,$mday,$monn-1,$year); |
645 |
if ($guess > time) { |
646 |
$guess = timelocal(0,$min,$hour,$mday,$monn-1,$year-1); |
647 |
} |
648 |
$guess; |
649 |
} |
650 |
|
651 |
|
652 |
__END__ |
653 |
## ################################################################### |
654 |
## pod |
655 |
## ################################################################### |
656 |
|
657 |
=head1 NAME |
658 |
|
659 |
cpan - generate an WAIT index for CPAN |
660 |
|
661 |
=head1 SYNOPSIS |
662 |
|
663 |
B<cpan> |
664 |
[B<-clean>] [B<-noclean>] |
665 |
[B<-cpan> I<url or directory>] |
666 |
[B<-database> I<dbname>] |
667 |
[B<-dir> I<directory>] |
668 |
[B<-force>] [B<-noforce>] |
669 |
[B<-keep> I<directory>] |
670 |
[B<-match> I<regexp>] |
671 |
[B<-table> I<table name>] |
672 |
[B<-test> I<level>] |
673 |
[B<-trust_mtime>] [B<-notrust_mtime>] |
674 |
|
675 |
=head1 DESCRIPTION |
676 |
|
677 |
TBS |
678 |
|
679 |
=head1 OPTIONS |
680 |
|
681 |
=over 5 |
682 |
|
683 |
=item B<-clean> / B<-noclean> |
684 |
|
685 |
Clean the table befor indexing. Default is B<off>. |
686 |
|
687 |
=item B<-cpan> I<url or directory> |
688 |
|
689 |
Default directory or URL for indexing. If an URL is given, there |
690 |
currently must be a file F<indices/find-ls.gz> relative to it which |
691 |
contains the output of C<find . -ls | gzip>. |
692 |
Default is F<ftp://ftp.rz.ruhr-uni-bochum.de/pub/CPAN>. |
693 |
|
694 |
|
695 |
=item B<-database> I<dbname> |
696 |
|
697 |
Specify database name. Default is F<DB>. |
698 |
|
699 |
=item B<-dir> I<directory> |
700 |
|
701 |
Alternate directory were databases are located. Default is the |
702 |
directory specified during configuration of WAIT. |
703 |
|
704 |
=item B<-force> |
705 |
|
706 |
Force reindexing, even if B<cpan> thinks files are up to date. |
707 |
Default is B<off> |
708 |
|
709 |
=item B<-keep> I<directory> |
710 |
|
711 |
If fetching from a remote server, keep files in I<directory>. Default is |
712 |
F</app/unido-i06/src/share/lang/perl/96a/CPAN/sources>. |
713 |
|
714 |
=item B<-match> I<regexp> |
715 |
|
716 |
Limit to patches matching I<regexp>. Default is F<authors/id/>. |
717 |
|
718 |
=item B<-table> I<table name> |
719 |
|
720 |
Specify an alternate table name. Default is C<cpan>. |
721 |
|
722 |
=item B<-test> I<level> |
723 |
|
724 |
Set test level, were B<0> means normal operation, B<1> means, don't |
725 |
really index and B<2> means, don't even get archives and examine them. |
726 |
|
727 |
=item B<-trust_mtime> / B<-notrust_mtime> |
728 |
|
729 |
If B<on>, the files mtimes are used to decide, which version of an |
730 |
archive is the newest. If b<off>, the version extracted is used |
731 |
(beware, there are far more version numbering schemes than B<cpan> can |
732 |
parse). |
733 |
|
734 |
=head1 AUTHOR |
735 |
|
736 |
Ulrich Pfeifer E<lt>F<pfeifer@ls6.informatik.uni-dortumund.de>E<gt> |