/[wait]/trunk/script/cpanwait
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Annotation of /trunk/script/cpanwait

Parent Directory Parent Directory | Revision Log Revision Log


Revision 102 - (hide annotations)
Fri Jun 25 19:15:49 2004 UTC (19 years, 10 months ago) by dpavlin
File size: 26303 byte(s)
update of ALIAS for currnet cpan, create compressed data files (using IO::Zlib)

1 dpavlin 86 #!/usr/bin/perl -w
2 ulpfr 10 ######################### -*- Mode: Perl -*- #########################
3     ##
4     ## $Basename: cpanwait $
5     ## $Revision: 1.7 $
6     ##
7     ## Author : Ulrich Pfeifer
8     ## Created On : Sat Jan 4 18:09:28 1997
9     ##
10     ## Last Modified By : Ulrich Pfeifer
11     ## Last Modified On : Sun Nov 22 18:44:36 1998
12     ##
13     ## Copyright (c) 1996-1997, Ulrich Pfeifer
14     ##
15     ##
16     ######################################################################
17    
18     use strict;
19    
20     use File::Path;
21     use DB_File;
22     use Getopt::Long;
23     use File::Find;
24     use File::Basename;
25     use IO::File;
26 dpavlin 102 use IO::Zlib;
27 ulpfr 10
28 dpavlin 86 use lib '/data/wait/lib';
29    
30 ulpfr 10 require WAIT::Config;
31     require WAIT::Database;
32     require WAIT::Parse::Pod;
33     require WAIT::Document::Tar;
34    
35 dpavlin 86 sub fname($);
36 ulpfr 10
37 dpavlin 86 # maximum number of archives to index (set to -1 for unlimited)
38     my $max = -1;
39    
40 ulpfr 10 my %OPT = (database => 'DB',
41     dir => $WAIT::Config->{WAIT_home} || '/tmp',
42     table => 'cpan',
43     clean => 0,
44     remove => [],
45     force => 0,
46 dpavlin 86 # cpan => '/usr/src/perl/CPAN/sources',
47     cpan => '/rest/cpan/CPAN/',
48 ulpfr 10 trust_mtime => 1,
49     match => 'authors/id/',
50     test => 0,
51     # cpan => 'ftp://ftp.rz.ruhr-uni-bochum.de/pub/CPAN',
52 dpavlin 86 # cpan => 'ftp://ftp.uni-hamburg.de:/pub/soft/lang/perl/CPAN',
53     keep => '/tmp/CPAN/',
54 ulpfr 10 );
55    
56     GetOptions(\%OPT,
57     'database=s',
58     'dir=s',
59     'cpan=s',
60     'table=s',
61     'keep=s',
62     'match=s',
63     'clean!',
64     'test=i', # test level 0: normal
65     # 1: don't change db
66     # 2: don't look at archives even
67    
68     'remove=s@',
69     'force!', # force indexing even if seen
70     'trust_mtime!', # use mtime instead of version number
71 dpavlin 86 'max=i',
72     'reorg!',
73 ulpfr 10 ) || die "Usage: ...\n";
74    
75 dpavlin 86 $max ||= $OPT{max};
76 ulpfr 10
77     clean_database(
78     database => $OPT{database},
79     dir => $OPT{dir},
80     table => $OPT{table},
81     ) if $OPT{clean};
82    
83     my $db = WAIT::Database->open(
84     name => $OPT{database},
85     'directory' => $OPT{dir},
86     )
87     || WAIT::Database->create(
88     name => $OPT{database},
89     'directory' => $OPT{dir},
90     )
91     or die "Could not open/create database '$OPT{dir}/$OPT{database}': $@";
92    
93     my $layout= new WAIT::Parse::Pod;
94    
95     my $tb = $db->table(name => $OPT{table})
96     || create_table(db => $db, table => $OPT{table}, layout => $layout);
97    
98     # Map e.g. '.../latest' to 'perl'. Used in wanted(). Effects version
99     # considerations. Value *must* match common prefix. Aliasing should be
100     # used if CPAN contains serveral distributions with different name but
101     # same root directory.
102     # We still have a problem if there are different root directories!
103    
104     my %ALIAS = (# tar name real (root) name
105 dpavlin 102 'Games-Scrabble' => 'Games',
106     'HTML-ParseBrowser' => 'HTML',
107     'iodbc_ext' => 'iodbc-ext-0.1',
108     'sol-inst' => 'Solaris',
109     'WebService-Validator-CSS-223C' => 'WebService-Validator-CSS-W3C-0.02',
110     'MPEG-ID3212Tag' => 'MPEG-ID3v2Tag-0.36',
111     'WebService-GoogleHack' => 'WebService',
112     'Db-Mediasurface-ReadConfig' => 'ReadConfig',
113     'Tie-Array-RestrictUpdates' => 'Tie',
114     'HTML-Lister' => 'HTML',
115     'Net-253950-AsyncZ' => 'Net-Z3950-AsyncZ-0.08',
116     'ChildExit_0' => 'ChildExit-0.1',
117     'Tie-TieConstant' => 'TieConstant.pm',
118     'Crypt-OpenSSL-23509' => 'Crypt-OpenSSL-X509-0.2',
119     'subclustv' => 'blib',
120     'finance-yahooquote' => 'Finance-YahooQuote-0.20',
121     'HPUX-FS' => 'FS',
122     'Business-DE-Konto' => 'Business',
123     'Digest-MD5-124p' => 'Digest-MD5-M4p-0.01',
124     'AKDB_Okewo_de' => 'AKDB',
125     'ExtUtils-0577' => 'ExtUtils-F77-1.14',
126     'LispFmt' => 'Lisp::Fmt-0.00',
127     'Acme-Stegano' => 'Acme',
128     'Acme-RTB' => 'Acme',
129     'WWW-Search-PRWire' => 'work',
130     'Video-Capture-214l' => 'Video-Capture-V4l-0.224',
131     'Tie-DirHandle' => 'Tie',
132     'DB2' => 'DBD-DB2-0.71a',
133     'Tie-Scalar-RestrictUpdates' => 'Tie',
134     'Math-MVPoly' => 'MVPoly',
135     'PlugIn' => 'PlugIn.pm',
136     'Lingua-ID-Nums2Words' => 'Nums2Words-0.01',
137     'chronos-1.' => 'Chronos',
138     'jp_beta' => 'jperl_beta_r1',
139     'Bundle-223C-Validator' => 'Bundle-W3C-Validator-0.6.5',
140     'Text-199' => 'Text-T9-1.0',
141     'Games-Literati' => 'Games',
142     'VMS-IndexedFile' => 'VMS',
143     'authen-rbac' => 'Authen',
144     'Graphics-EPS' => 'EPS.pm',
145     'new.spirit-2.' => 'new.spirit',
146     'Tk-MListbox' => 'MListbox-1.11',
147     'DBD-SQLrelay' => 'SQLRelay.pm',
148     'Tie-RDBM-Cached' => 'RDBM',
149     'PDL_IO_HDF' => 'HDF',
150     'HPUX-LVM' => 'LVM',
151     'Parse-Nibbler' => 'Parse',
152     'Digest-Perl-MD4' => 'MD4',
153     'Crypt-Imail' => 'Imail',
154     'ubertext' => 'Text-UberText-0.95',
155     'MP3-123U' => 'M3U',
156     'Qmail-Control' => 'Qmail',
157     'T-LXS' => 'Text-LevenshteinXS-0.02',
158     'HTML-Paginator' => 'HTML',
159     'swig' => 'SWIG1.1p5',
160     'MIDI-Realtime' => 'MIDI',
161     'sparky-public' => 'Sparky-Public-1.06',
162     'Chemistry-MolecularMass' => 'Chemistry',
163     'Net-253950-SimpleServer' => 'Net-Z3950-SimpleServer-0.08',
164     'NewsClipper-OpenSource' => 'NewsClipper-1.32-OpenSource',
165     'Win32API-Resources' => 'Resources.pm',
166     'Unicode-Collate-Standard-2131_1' => 'Unicode-Collate-Standard-V3_1_1-0.1',
167     'Net-026Term' => 'Net-C6Term-0.11',
168     'BitArray1' => 'BitArray',
169     'Audio-Radio-214L' => 'Audio-Radio-V4L-0.01',
170     'Devel-AutoProfiler' => 'Devel',
171     'Brasil-Checar-CGC' => 'Brasil',
172     'AI-NeuralNet-SOM' => 'SOM.pm',
173     'Net-BitTorrent-File-fix' => 'Net-BitTorrent-File-1.01',
174     'VMS-FindFile' => 'VMS',
175     'LoadHtml.' => 'README',
176     'Time-Compare' => 'Time',
177     'ShiftJIS-230213-MapUTF' => 'ShiftJIS-X0213-MapUTF-0.21',
178     'Image-WMF' => 'Image',
179     'sdf-2.0.eta' => 'sdf-2.001beta1',
180     'Math-Expr-LATEST' => 'Math-Expr-0.4',
181     'MP3-Player-PktConcert' => 'MP3',
182     'Apache-OWA' => 'OWA',
183     'Audio-Gramofile' => 'Audio',
184     'DBIx-Copy' => 'Copy',
185     'P4-024' => 'P4-C4-2.021',
186     'Disassemble-2386' => 'Disassemble-X86-0.13',
187     'Proc-Swarm' => 'Swarm-0.5',
188     'Smil' => 'perlysmil',
189     'Net-SSH-2232Perl' => 'Net-SSH-W32Perl-0.05',
190     'Win32-SerialPort' => 'SerialPort-0.19',
191     'Lingua-ID-Words2Nums' => 'Words2Nums-0.01',
192     'Parse-Text' => 'Text',
193     'DBIx-HTMLView-LATEST' => 'DBIx-HTMLView-0.9',
194     'Apache-NNTPGateway' => 'NNTPGateway-0.9',
195     'XPathToXML' => 'XPathToXML.pm',
196     'XML-WMM-ASX' => 'XML',
197     'CGISession' => 'CGI',
198     'Net-SMS-142' => 'Net-SMS-O2-0.019',
199     'Search-253950' => 'Search-Z3950-0.05',
200     'Date-Christmas' => 'Christmas',
201     'Win32-InternetExplorer-Window' => 'Win32',
202     'Apache-WAP-MailPeek' => 'MailPeek',
203     'Statistics-Table-F' => 'Statistics',
204     'BerkeleyDB_Locks' => 'BerkeleyDB-Locks-0_2',
205     'HookPrePostCall' => 'PrePostCall-1.2',
206     'Oak-AAS-Service-DBI_13_PAM' => 'Oak-AAS-Service-DBI_N_PAM-1.8',
207     'Math-Vector' => 'Vector.pm',
208     'Audio-124pDecrypt' => 'Audio-M4pDecrypt-0.04',
209     'libao-perl_0.03' => 'libao-perl-0.03',
210     'CGI-EZForm' => 'EZForm',
211     'Data-Locations-fixed' => 'Data-Locations-5.2-fixed',
212     'HTML-Template-Filter-Dreamweaver' => 'Dreamweaver',
213     'LineByLine' => 'LineByLine.pm',
214     'Geo-0400' => 'Geo-E00-0.05',
215     'WebService-Validator-HTML-223C' => 'WebService-Validator-HTML-W3C-0.03',
216     'DateTime-Format-223CDTF' => 'DateTime-Format-W3CDTF-0.04',
217     'DBD_SQLFLEX' => 'DBD-Sqlflex',
218     'Text-Number' => 'Number',
219     'DBIx-DataLookup' => 'DBIx',
220     'MP3-ID3211Tag' => 'MP3-ID3v1Tag-1.11',
221     'Text-Striphigh' => 'Striphigh-0.02',
222     'Tie-SortHash' => 'SortHash',
223     'Apache-AccessAbuse' => 'AccessAbuse',
224     'MP3-123U-Parser' => 'MP3-M3U-Parser',
225     'Net-253950' => 'Net-Z3950-0.44',
226     'Net-RBLClient' => 'RBLCLient-0.2',
227     'CGI-EasyCGI' => 'CGI',
228     'http-handle' => 'HTTP::Handle',
229     'JPEG-Comment' => 'JPEG',
230     'router-lg' => 'Router',
231     'Db-Mediasurface' => 'Mediasurface',
232     'Text-BarGraph' => 'bargraph',
233     'TL' => 'Text-Levenshtein-0.04',
234     'Config-Vars' => 'Config-0.01',
235     'Tie-PerfectHash' => 'Tie',
236     'DNS-TinyDNS' => 'DNS',
237     'DesignPattern-Factory' => 'Factory',
238     'WWW-01_Rail' => 'WWW-B_Rail-0.01',
239     'Win32-Exchange' => 'blib',
240     'Math-RPN' => 'Math',
241     'Db-Mediasurface-Cache' => 'Cache',
242     'perl_archie.' => 'Archie.pm',
243     'Acme-PGPSign' => 'Acme',
244     'HTML-Widget-sideBar' => 'HTML-Widget-SideBar-1.00',
245     'log' => 'Games',
246     'File-List' => 'File',
247     'Schedule-Cronchik' => 'Schedule',
248     'Curses-Devkit' => 'Cdk',
249     'Pod-PalmDoc' => 'Pod',
250     'Easy-WML' => 'Easy WML 0.1',
251     'Interval.' => 'Date',
252     'Brasil-Checar-CPF' => 'Brasil',
253     'Apache-WAP-AutoIndex' => 'AutoIndex',
254    
255     'SOM.pm' => 'SOM.pm',
256     'PlugIn.pm' => 'PlugIn.pm',
257     'XPathToXML.pm' => 'XPathToXML.pm',
258     'Vector.pm' => 'Vector.pm',
259     'LineByLine.pm' => 'LineByLine.pm',
260     'Archie.pm' => 'Archie.pm',
261     'TieConstant.pm' => 'TieConstant.pm',
262     'EPS.pm' => 'EPS.pm',
263     'SQLRelay.pm' => 'SQLRelay.pm',
264     'Resources.pm' => 'Resources.pm',
265     'README' => 'README',
266    
267     );
268 ulpfr 10 my %NEW_ALIAS; # found in this pass
269    
270     # Map module names to pathes. Generated by wanted() doing alisaing.
271     my %ARCHIVE;
272    
273     # Map module names to latest version. Generated by wanted()
274     my %VERSION;
275    
276    
277     # Mapping for modules with common root not matching modules name that
278     # are not aliased. This is just for prefix stripping and not strictly
279     # necessary. Takes effect after version considerations.
280     my %TR = (# tar name root to strip
281     'Net_SSLeay.pm' => 'SSLeay/',
282     'EventDrivenServer' => 'Server/',
283     'bio_lib.pl.' => '',
284     'AlarmCall' => 'Sys/',
285     'Cdk-ext' => 'Cdk/',
286     'Sx' => '\d.\d/',
287     'DumpStack' => 'Devel/',
288     'StatisticsDescriptive'=> 'Statistics/',
289     'Term-Gnuplot' => 'Gnuplot/',
290     'iodbc_ext' => 'iodbc-ext-\d.\d/',
291     'UNIVERSAL' => '',
292     'Term-Query' => 'Query/',
293     'SelfStubber' => 'Devel/',
294     'CallerItem' => 'Devel/',
295     );
296    
297     my $DIR = $tb->dir;
298     my $DATA = $tb->dir . "/data";
299     my $LWP;
300    
301    
302     if (@{$OPT{remove}}) {
303     my $pod;
304     for $pod (@{$OPT{remove}}) {
305     unless (-e $pod) {
306     $pod = "$DIR/$pod";
307     }
308     index_pod(file => $pod, remove => 1) if -f $pod;
309     unlink $pod or warn "Could not unlink '$pod': $!\n";
310     #$tb->sync;
311     }
312     $tb->close;
313     $db->close;
314     exit;
315     }
316    
317     # Now get the beef
318     if ($OPT{cpan} =~ /^(http|ftp):/) {
319     $LWP = 1;
320     require LWP::Simple;
321     LWP::Simple->import();
322    
323     mkpath($DATA,1,0755) or
324     die "Could not generate '$DATA/': $!"
325     unless -d $DATA;
326    
327     if (! -f "$DATA/find-ls.gz" or -M "$DATA/find-ls.gz" > 0.5) {
328     my $status = mirror("$OPT{cpan}/indices/find-ls.gz", "$DATA/find-ls.gz");
329     if ($status != &RC_OK and $status != &RC_NOT_MODIFIED) {
330     # we could use Net:FTP here ...
331     die "Was unable to mirror '$OPT{cpan}/indices/find-ls.gz'\n";
332     }
333     }
334     my $fh = new IO::File "gzip -cd $DATA/find-ls.gz |";
335     die "Could not open 'gzip -cd $DATA/find-ls.gz': !$\n" unless $fh;
336    
337     my $line;
338     while (defined ($line = <$fh>)) {
339     chomp($line);
340     my ($mon, $mday, $time, $file, $is_link) = (split ' ', $line)[7..11];
341    
342     next if defined $is_link;
343     my $mtime = mtime($mon, $mday, $time);
344    
345     $file =~ s:^\./::;
346     ($_) = fileparse($file);
347     $File::Find::name = $file;
348     wanted($mtime);
349     }
350     } else {
351     find(sub {&wanted((stat($_))[9])}, $OPT{cpan});
352     }
353    
354     ARCHIVE:
355     for my $tar (sort keys %ARCHIVE) {
356     next if $OPT{match} and $ARCHIVE{$tar} !~ /$OPT{match}/o;
357     my $base = (split /\//, $ARCHIVE{$tar})[-1];
358     my $parent;
359    
360     # logging
361     if ($OPT{trust_mtime}) {
362     printf "%-20s %10s %s\t", $tar,
363     substr(scalar(localtime($VERSION{$tar})),0,10), $base;
364     } else {
365     printf "%-20s %10.5f %s\t", $tar, $VERSION{$tar}, $base;
366     }
367    
368     # Remember the archive
369     # We should have an extra table for the tar file data ...
370     if (!$OPT{force} and $tb->have(docid => $base)) {
371     print "skipping\n";
372     next ARCHIVE;
373     } else {
374     $parent = $tb->insert(docid => $base,
375     headline => $ARCHIVE{$tar}) unless $OPT{test};
376     print "indexing\n";
377     }
378    
379     next ARCHIVE if $OPT{test} > 1;
380    
381     my $TAR = myget($tar);
382    
383     next ARCHIVE unless $TAR; # not able to fetch it
384    
385     my %tar;
386     tie (%tar,
387     'WAIT::Document::Tar',
388 dpavlin 86 sub { $_[0] =~ /\.(pm|pod|PL)$/i or $_[0] =~ /readme/i},
389 ulpfr 10 #sub { $_[0] !~ m:/$: },
390     $TAR)
391     or warn "Could not tie '$TAR'\n";
392    
393     my $sloppy;
394     my ($key, $val);
395    
396     FILE:
397     while (($key, $val) = each %tar) {
398     my $file = fname($key);
399    
400     # don't index directories
401     next if $file =~ /\/$/;
402    
403     # is it a POD file?
404     next FILE unless $file =~ /readme/i or $val =~ /\n=head/;
405    
406     # remove directory prefix
407     unless ($sloppy # no common root
408     or $file =~ s:^\Q$tar\E[^/]*/:: # common root, maybe alias
409     or ($TR{$tar} # common root, not aliased
410     and $file =~ s:^\Q$TR{$tar}\E::)
411     ) {
412     # try to determine an alias
413     warn "Bad directory prefix: '$file'\n";
414     my ($prefix) = split /\//, $file;
415    
416     while ($key = (tied %tar)->NEXTKEY) {
417     my $file = fname($key);
418    
419     next if $file =~ /\/$/;
420     unless ($file =~ m:^$prefix/: or $file eq $prefix) {
421     warn "Archive contains different prefixes: $prefix,$file\n";
422     $prefix = '';
423     last;
424     }
425     }
426     if ($prefix) {
427     print "Please alias '$tar' to '$prefix' next time!\n";
428     print "See alias table later.\n";
429     $NEW_ALIAS{$tar} = $prefix;
430     $tb->delete_by_key($parent);
431     next ARCHIVE;
432     } else {
433     print "Assuming that tar file name $tar is a valid prefix\n";
434     $sloppy = 1;
435    
436     # We may reset too much here! But that this is not exact
437     # science anyway. Maybe we should ignore using 'next ARCHIVE'.
438    
439     $key = (tied %tar)->FIRSTKEY;
440     redo FILE;
441     }
442     }
443    
444     # remove /lib prefix
445     $file =~ s:^lib/::;
446    
447     # generate new path
448     my $path = "$DATA/$tar/$file";
449    
450     my ($sbase, $sdir) = fileparse($path);
451     my $fh;
452    
453     unless ($OPT{test}) {
454     if (-f $path) {
455     index_pod(file => $path, remove => 1);
456     unlink $path or warn "Could not unlink '$path' $!\n";
457     } elsif (!-d $sdir) {
458     mkpath($sdir,1,0755) or die "Could not mkpath($sdir): $!\n";
459     }
460 dpavlin 102 # $fh = new IO::File "> $path";
461     $fh = new IO::Zlib "$path.gz","wb";
462 ulpfr 10 die "Could not write '$path': $!\n" unless $fh;
463     }
464    
465     if ($file =~ /readme|install/i) { # make READMEs verbatim pods
466     $val =~ s/\n/\n /g;
467     $val = "=head1 NAME\n\n$tar $file\n\n=head1 DESCRIPTION\n\n $val"
468     unless $val =~ /^=head/m;
469     } else { # remove non-pod stuff
470     my $nval = $val; $val = '';
471     my $cutting = 1;
472    
473     for (split /\n/, $nval) {
474     if (/^=cut|!NO!SUBS!/) {
475     $cutting = 1;
476     } elsif ($cutting and /^=head/) {
477     $cutting = 0;
478     }
479     unless ($cutting) {
480     $val .= $_ . "\n";
481     }
482     }
483     }
484     unless ($OPT{test}) {
485     $fh->print($val);
486     index_pod(file => $path, parent => $parent,
487     text => $val, source => $ARCHIVE{$tar});
488     }
489     }
490    
491     if ($LWP and !$OPT{keep}) {
492     unlink $TAR or warn
493     "Could not unlink '$TAR': $!\n";
494     }
495     }
496    
497     if (%NEW_ALIAS) {
498     print "\%ALIAS = (\n";
499     for (keys %NEW_ALIAS) {
500     print "\t'$_'\t=> '$NEW_ALIAS{$_}',\n";
501     }
502     print "\t);\n";
503     }
504    
505 dpavlin 86 if ($OPT{reorg}) {
506     my $now = time;
507     warn "Starting reorg\n";
508     $tb->set(top=>1);
509     warn sprintf "Finished reorg %d seconds\n", time - $now;
510     }
511    
512 ulpfr 10 # we are done
513     $db->close();
514     exit;
515    
516     sub fname ($) {
517     my $key = shift;
518     my ($ntar, $file) = split $;, $key;
519    
520     # remove leading './' - shudder
521     $file =~ s/^\.\///;
522    
523     return($file);
524     }
525    
526     sub myget {
527     my $tar = shift;
528     my $TAR;
529    
530     if ($LWP) { # fetch the archive
531     if ($OPT{keep}) {
532     $TAR = "$OPT{keep}/$ARCHIVE{$tar}";
533     print "Keeping in '$TAR'\n" unless -e $TAR;
534     my ($base, $path) = fileparse($TAR);
535     unless (-d $path) {
536     mkpath($path,1,0755) or
537     die "Could not mkpath($path)\n";
538     }
539     } else {
540     $TAR = "/tmp/$tar.tar.gz";
541     }
542     unless (-e $TAR) { # lwp mirror seems to fetch ftp: in any case?
543     print "Fetching $OPT{cpan}/$ARCHIVE{$tar}\n";
544     my $status = mirror("$OPT{cpan}/$ARCHIVE{$tar}", $TAR);
545     if ($status != &RC_OK and $status != &RC_NOT_MODIFIED) {
546     warn "Was unable to mirror '$ARCHIVE{$tar}, skipping'\n";
547     return;
548     }
549     }
550 dpavlin 86 } else {
551     $TAR = $ARCHIVE{$tar};
552 ulpfr 10 }
553     $TAR;
554     }
555    
556     sub index_pod {
557     my %parm = @_;
558     my $did = $parm{file};
559     my $rel_did = $did;
560     my $abs_did = $did;
561    
562     if ($rel_did =~ s:$DIR/::) {
563     $abs_did = "$DIR/$rel_did";
564     }
565    
566     undef $did;
567    
568     # check for both variants
569     if ($tb->have('docid' => $rel_did)) {
570     $did = $rel_did;
571     } elsif ($tb->have('docid' => $abs_did)) {
572     $did = $abs_did;
573     }
574     if ($did) { # have it version
575     if (!$parm{remove}) {
576     warn "duplicate: $did\n";
577     return;
578     }
579     } else { # not seen yet
580     $did = $rel_did;
581     if ($parm{remove}) {
582     print "missing: $did\n";
583     return;
584     }
585     }
586    
587     $parm{'text'} ||= WAIT::Document::Find->FETCH($abs_did);
588    
589     unless (defined $parm{'text'}) {
590     print "unavailable: $did\n";
591     return;
592     }
593    
594     my $record = $layout->split($parm{'text'});
595 dpavlin 86
596     if (! $record) {
597     print "empty pod: $did\n";
598     return;
599     }
600    
601 ulpfr 10 $record->{size} = length($parm{'text'});
602     my $headline = $record->{name} || $did;
603    
604     $headline =~ s/^$DATA//o; # $did
605     $headline =~ s/\s+/ /g; $headline =~ s/^\s+//;
606    
607     printf "%s %s\n", ($parm{remove})?'-':'+', substr($headline,0,70);
608     if ($parm{remove}) {
609     $tb->delete('docid' => $did,
610     headline => $headline,
611     %{$record});
612     } else {
613     $tb->insert('docid' => $did,
614     headline => $headline,
615     source => $parm{source},
616     parent => $parm{parent},
617     %{$record});
618     }
619     }
620    
621     # This *must* remove the version in *any* case. It should compute a
622     # resonable version number - but usually mtimes should be used.
623     sub version {
624     local ($_) = @_;
625    
626     # remove alpha/beta postfix
627     s/([-_\d])(a|b|alpha|beta|src)$/$1/;
628    
629     # jperl1.3@4.019.tar.gz
630     s/@\d.\d+//;
631    
632     # oraperl-v2.4-gk.tar.gz
633     s/-v(\d)/$1/;
634    
635     # lettered versions - shudder
636     s/([-_\d\.])([a-z])([\d\._])/sprintf "$1%02d$3", ord(lc $2) - ord('a') /ei;
637     s/([-_\d\.])([a-z])$/sprintf "$1%02d", ord(lc $2) - ord('a') /ei;
638    
639     # thanks libwww-5b12 ;-)
640     s/(\d+)b/($1-1).'.'/e;
641     s/(\d+)a/($1-2).'.'/e;
642    
643     # replace '-pre' by '0.'
644     s/-pre([\.\d])/-0.$1/;
645     s/\.\././g;
646     s/(\d)_(\d)/$1$2/g;
647    
648     # chop '[-.]' and thelike
649     s/\W$//;
650    
651     # ram's versions Storable-0.4@p
652     s/\@/./;
653    
654     if (s/[-_]?(\d+)\.(0\d+)\.(\d+)$//) {
655     return($_, $1 + "0.$2" + $3 / 1000000);
656     } elsif (s/[-_]?(\d+)\.(\d+)\.(\d+)$//) {
657     return($_, $1 + $2/1000 + $3 / 1000000);
658     } elsif (s/[-_]?(\d+\.[\d_]+)$//) {
659     return($_, $1);
660     } elsif (s/[-_]?([\d_]+)$//) {
661     return($_, $1);
662     } elsif (s/-(\d+.\d+)-/-/) { # perl-4.019-ref-guide
663     return($_, $1);
664     } else {
665     if ($_ =~ /\d/) { # smells like an unknown scheme
666     warn "Odd version Numbering: '$File::Find::name'\n";
667     return($_, undef);
668     } else { # assume version 0
669     warn "No version Numbering: '$File::Find::name'\n";
670     return($_, 0);
671     }
672    
673     }
674     }
675    
676     sub wanted {
677     my $mtime = shift; # called by parse_file_ls();
678    
679     return unless /^(.*)\.tar(\.gz|\.Z)$/;
680 dpavlin 86
681     return if (! $max);
682     $max--;
683    
684 ulpfr 10 my ($archive, $version) = version($1);
685    
686     unless (defined $version) {
687     warn "Skipping $1\n";
688     return;
689     }
690    
691     # Check for file alias
692     $archive = $ALIAS{$archive} if $ALIAS{$archive};
693    
694     # Check for path alias.
695     if ($File::Find::name =~ m(/CPAN/(?:source/)?(.*\Q$archive\E))) {
696     if ($ALIAS{$1}) {
697     $archive = $ALIAS{$1};
698     }
699     }
700    
701     if ($OPT{trust_mtime}) {
702     $version = $mtime;
703     } else {
704     $version =~ s/(\d)_/$1/;
705     $version ||= $mtime; # mtime
706     }
707    
708     if (!exists $ARCHIVE{$archive}
709     or $VERSION{$archive} < $version) {
710     $ARCHIVE{$archive} = $File::Find::name;
711     $VERSION{$archive} = $version;
712     }
713     }
714    
715     sub clean_database {
716     my %parm = @_;
717    
718     my $db = WAIT::Database->open(
719     name => $parm{database},
720     'directory' => $parm{dir},
721     )
722     or die "Could not open database '$parm{dir}/$parm{database}': $@";
723     my $tbl = $db->table(name => $parm{table});
724     if ($tbl) {
725     $tbl->drop or
726     die "Could not open table '$parm{tabel}': $@";
727     }
728    
729     $db->close;
730     }
731    
732     sub create_table {
733     my %parm = @_;
734    
735     my $access = bless {}, 'WAIT::Document::Find';
736    
737     my $stem = [{
738     'prefix' => ['isotr', 'isolc'],
739     'intervall' => ['isotr', 'isolc'],
740     }, 'isotr', 'isolc', 'split2', 'stop', 'Stem'];
741     my $text = [{
742     'prefix' => ['isotr', 'isolc'],
743     'intervall' => ['isotr', 'isolc'],
744     },
745     'isotr', 'isolc', 'split2', 'stop'];
746     my $sound = ['isotr', 'isolc', 'split2', 'Soundex'],;
747    
748     my $tb =
749     $parm{db}->create_table
750     (name => $parm{table},
751     attr => ['docid', 'headline', 'source', 'size', 'parent'],
752     keyset => [['docid']],
753     layout => $parm{layout},
754     access => $access,
755     invindex =>
756     [
757     'name' => $stem,
758     'synopsis' => $stem,
759     'bugs' => $stem,
760     'description' => $stem,
761     'text' => $stem,
762     'environment' => $text,
763     'example' => $text, 'example' => $stem,
764     'author' => $sound, 'author' => $stem,
765     ]
766     );
767     die "Could not create table '$parm{table}'" unless $tb;
768     $tb;
769     }
770    
771     my %MON;
772     my $YEAR;
773    
774     BEGIN {
775     my $i = 1;
776     for (qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec)) {
777     $MON{$_} = $i++;
778     }
779     $YEAR = (localtime(time))[5];
780     }
781    
782     # We could/should use Date::GetDate here
783     use Time::Local;
784     sub mtime {
785     my ($mon, $mday, $time) = @_;
786     my ($hour, $min, $year, $monn) = (0,0);
787    
788     if ($time =~ /(\d+):(\d+)/) {
789     ($hour, $min) = ($1, $2);
790     $year = $YEAR;
791     } else {
792     $year = $time;
793     }
794     $monn = $MON{$mon} || $MON{ucfirst lc $mon} || warn "Unknown month: '$mon'";
795     my $guess = timelocal(0,$min,$hour,$mday,$monn-1,$year);
796     if ($guess > time) {
797     $guess = timelocal(0,$min,$hour,$mday,$monn-1,$year-1);
798     }
799     $guess;
800     }
801    
802    
803     __END__
804     ## ###################################################################
805     ## pod
806     ## ###################################################################
807    
808     =head1 NAME
809    
810 dpavlin 86 cpanwait - generate an WAIT index for CPAN
811 ulpfr 10
812     =head1 SYNOPSIS
813    
814 dpavlin 86 B<cpanwait>
815 ulpfr 10 [B<-clean>] [B<-noclean>]
816     [B<-cpan> I<url or directory>]
817     [B<-database> I<dbname>]
818     [B<-dir> I<directory>]
819     [B<-force>] [B<-noforce>]
820     [B<-keep> I<directory>]
821     [B<-match> I<regexp>]
822     [B<-table> I<table name>]
823     [B<-test> I<level>]
824     [B<-trust_mtime>] [B<-notrust_mtime>]
825    
826     =head1 DESCRIPTION
827    
828     TBS
829    
830     =head1 OPTIONS
831    
832     =over 5
833    
834     =item B<-clean> / B<-noclean>
835    
836     Clean the table befor indexing. Default is B<off>.
837    
838     =item B<-cpan> I<url or directory>
839    
840     Default directory or URL for indexing. If an URL is given, there
841     currently must be a file F<indices/find-ls.gz> relative to it which
842     contains the output of C<find . -ls | gzip>.
843     Default is F<ftp://ftp.rz.ruhr-uni-bochum.de/pub/CPAN>.
844    
845    
846     =item B<-database> I<dbname>
847    
848     Specify database name. Default is F<DB>.
849    
850     =item B<-dir> I<directory>
851    
852     Alternate directory were databases are located. Default is the
853     directory specified during configuration of WAIT.
854    
855     =item B<-force>
856    
857     Force reindexing, even if B<cpan> thinks files are up to date.
858     Default is B<off>
859    
860     =item B<-keep> I<directory>
861    
862     If fetching from a remote server, keep files in I<directory>. Default is
863     F</app/unido-i06/src/share/lang/perl/96a/CPAN/sources>.
864    
865     =item B<-match> I<regexp>
866    
867     Limit to patches matching I<regexp>. Default is F<authors/id/>.
868    
869     =item B<-table> I<table name>
870    
871     Specify an alternate table name. Default is C<cpan>.
872    
873     =item B<-test> I<level>
874    
875     Set test level, were B<0> means normal operation, B<1> means, don't
876     really index and B<2> means, don't even get archives and examine them.
877    
878     =item B<-trust_mtime> / B<-notrust_mtime>
879    
880     If B<on>, the files mtimes are used to decide, which version of an
881     archive is the newest. If b<off>, the version extracted is used
882     (beware, there are far more version numbering schemes than B<cpan> can
883     parse).
884    
885     =head1 AUTHOR
886    
887     Ulrich Pfeifer E<lt>F<pfeifer@ls6.informatik.uni-dortumund.de>E<gt>

Properties

Name Value
cvs2svn:cvs-rev 1.1
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26