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