src/Modules/Debian.pl

   1 #
   2 #   Debian.pl: Frontend to debian contents and packages files
   3 #      Author: dms
   4 #     Version: v0.8 (20000918)
   5 #     Created: 20000106
   6 #
   7
   8
   9 # XXX Add uploader field support
  10
  11 package Debian;
  12
  13 use strict;
  14 no strict 'refs';    # FIXME: dstats aborts if set
  15
  16 my $announce    = 0;
  17 my $defaultdist = 'sid';
  18 my $refresh =
  19   &::getChanConfDefault( 'debianRefreshInterval', 7, $::chan ) * 60 * 60 * 24;
  20 my $debug      = 0;
  21 my $debian_dir = $::bot_state_dir . '/debian';
  22 my $country  = 'nl';     # well .config it yourself then. ;-)
  23 my $protocol = 'http';
  24
  25 # EDIT THIS (i386, amd64, powerpc, [etc.]):
  26 my $arch = "i386";
  27
  28 # format: "alias=real".
  29 my %dists = (
  30     'unstable'     => 'sid',
  31     'testing'      => 'lenny',
  32     'stable'       => 'etch',
  33     'experimental' => 'experimental',
  34     'oldstable'    => 'sarge',
  35     'incoming'     => 'incoming',
  36 );
  37
  38 my %archived_dists = (
  39     woody  => 'woody',
  40     potato => 'potato',
  41     hamm   => 'hamm',
  42     buzz   => 'buzz',
  43     bo     => 'bo',
  44     rex    => 'rex',
  45     slink  => 'slink',
  46 );
  47
  48 my %archiveurlcontents =
  49   ( "Contents-##DIST-$arch.gz" =>
  50         "$protocol://debian.crosslink.net/debian-archive"
  51       . "/dists/##DIST/Contents-$arch.gz", );
  52
  53 my %archiveurlpackages = (
  54         "Packages-##DIST-main-$arch.gz" =>
  55                 "$protocol://debian.crosslink.net/debian-archive".
  56                 "/dists/##DIST/main/binary-$arch/Packages.gz",
  57         "Packages-##DIST-contrib-$arch.gz" =>
  58                 "$protocol://debian.crosslink.net/debian-archive".
  59                 "/dists/##DIST/contrib/binary-$arch/Packages.gz",
  60         "Packages-##DIST-non-free-$arch.gz" =>
  61                 "$protocol://debian.crosslink.net/debian-archive".
  62                 "/dists/##DIST/non-free/binary-$arch/Packages.gz",
  63 );
  64
  65 my %urlcontents = (
  66     "Contents-##DIST-$arch.gz" => "$protocol://ftp.$country.debian.org"
  67       . "/debian/dists/##DIST/Contents-$arch.gz",
  68     "Contents-##DIST-$arch-non-US.gz" => "$protocol://non-us.debian.org"
  69       . "/debian-non-US/dists/##DIST/non-US/Contents-$arch.gz",
  70 );
  71
  72 my %urlpackages = (
  73     "Packages-##DIST-main-$arch.gz" => "$protocol://ftp.$country.debian.org"
  74       . "/debian/dists/##DIST/main/binary-$arch/Packages.gz",
  75     "Packages-##DIST-contrib-$arch.gz" => "$protocol://ftp.$country.debian.org"
  76       . "/debian/dists/##DIST/contrib/binary-$arch/Packages.gz",
  77     "Packages-##DIST-non-free-$arch.gz" => "$protocol://ftp.$country.debian.org"
  78       . "/debian/dists/##DIST/non-free/binary-$arch/Packages.gz",
  79 );
  80
  81 #####################
  82 ### COMMON FUNCTION....
  83 #######################
  84
  85 ####
  86 # Usage: &DebianDownload($dist, %hash);
  87 sub DebianDownload {
  88     my ( $dist, %urls ) = @_;
  89     my $bad  = 0;
  90     my $good = 0;
  91
  92     if ( !-d $debian_dir ) {
  93         &::status("Debian: creating debian dir.");
  94         mkdir( $debian_dir, 0755 );
  95     }
  96
  97     # fe dists.
  98     # Download the files.
  99     my $file;
 100     foreach $file ( keys %urls ) {
 101         my $url = $urls{$file};
 102         $url  =~ s/##DIST/$dist/g;
 103         $file =~ s/##DIST/$dist/g;
 104         my $update = 0;
 105
 106         if ( -f $file ) {
 107             my $last_refresh = ( stat $file )[9];
 108             $update++ if ( time() - $last_refresh > $refresh );
 109         }
 110         else {
 111             $update++;
 112         }
 113
 114         next unless ($update);
 115
 116         &::DEBUG("announce == $announce.") if ($debug);
 117         if ( $good + $bad == 0 and !$announce ) {
 118             &::status("Debian: Downloading files for '$dist'.");
 119             &::msg( $::who, "Updating debian files... please wait." );
 120             $announce++;
 121         }
 122
 123         if ( exists $::debian{$url} ) {
 124             &::DEBUG( "2: " . ( time - $::debian{$url} ) . " <= $refresh" )
 125               if ($debug);
 126             next if ( time() - $::debian{$url} <= $refresh );
 127             &::DEBUG("stale for url $url; updating!") if ($debug);
 128         }
 129
 130         if ( $url =~ /^ftp:\/\/(.*?)\/(\S+)\/(\S+)$/ ) {
 131             my ( $host, $path, $thisfile ) = ( $1, $2, $3 );
 132
 133             if ( !&::ftpGet( $host, $path, $thisfile, $file ) ) {
 134                 &::WARN("deb: down: $file == BAD.");
 135                 $bad++;
 136                 next;
 137             }
 138
 139         }
 140         elsif ( $url =~ /^http:\/\/\S+\/\S+$/ ) {
 141
 142             if ( !&::getURLAsFile( $url, $file ) ) {
 143                 &::WARN("deb: down: http: $file == BAD.");
 144                 $bad++;
 145                 next;
 146             }
 147
 148         }
 149         else {
 150             &::ERROR("Debian: invalid format of url => ($url).");
 151             $bad++;
 152             next;
 153         }
 154
 155         if ( !-f $file ) {
 156             &::WARN("deb: down: http: !file");
 157             $bad++;
 158             next;
 159         }
 160
 161         #       my $exit = system("/bin/gzip -t $file");
 162         #       if ($exit) {
 163         #           &::WARN("deb: $file is corrupted ($exit) :/");
 164         #           unlink $file;
 165         #           next;
 166         #       }
 167
 168         &::DEBUG("deb: download: good.") if ($debug);
 169         $good++;
 170     }
 171
 172     # ok... lets just run this.
 173     &::miscCheck() if ( &::whatInterface() =~ /IRC/ );
 174
 175     if ($good) {
 176         &generateIndex($dist);
 177         return 1;
 178     }
 179     else {
 180         return -1 unless ($bad);    # no download.
 181         &::DEBUG("DD: !good and bad($bad). :(");
 182         return 0;
 183     }
 184 }
 185
 186 ###########################
 187 # DEBIAN CONTENTS SEARCH FUNCTIONS.
 188 ########
 189
 190 ####
 191 # Usage: &searchContents($query);
 192 sub searchContents {
 193     my ( $dist, $query ) = &getDistroFromStr( $_[0] );
 194     &::status("Debian: Contents search for '$query' in '$dist'.");
 195     my $dccsend = 0;
 196
 197     $dccsend++ if ( $query =~ s/^dcc\s+//i );
 198
 199     $query =~ s/\\([\^\$])/$1/g;    # hrm?
 200     $query =~ s/^\s+|\s+$//g;
 201
 202     if ( !&::validExec($query) ) {
 203         &::msg( $::who, 'search string looks fuzzy.' );
 204         return;
 205     }
 206
 207     my %urls = fixDist( $dist, 'contents' );
 208     if ( $dist eq 'incoming' ) {    # nothing yet.
 209         &::DEBUG('sC: dist = "incoming". no contents yet.');
 210         return;
 211     }
 212     else {
 213
 214         # download contents file.
 215         &::DEBUG('deb: download 1.') if ($debug);
 216         if ( !&DebianDownload( $dist, %urls ) ) {
 217             &::WARN('Debian: could not download files.');
 218         }
 219     }
 220
 221     # start of search.
 222     my $start_time = &::timeget();
 223
 224     my $found = 0;
 225     my $front = 0;
 226     my %contents;
 227     my $grepRE;
 228     ### TODO: search properly if /usr/bin/blah is done.
 229     if ( $query =~ s/\$$// ) {
 230         &::DEBUG("deb: search-regex found.") if ($debug);
 231         $grepRE = "$query\[ \t]";
 232     }
 233     elsif ( $query =~ s/^\^// ) {
 234         &::DEBUG("deb: front marker regex found.") if ($debug);
 235         $front  = 1;
 236         $grepRE = $query;
 237     }
 238     else {
 239         $grepRE = "$query*\[ \t]";
 240     }
 241
 242     # fix up grepRE for "*".
 243     $grepRE =~ s/\*/.*/g;
 244
 245     my @files;
 246     foreach ( keys %urls ) {
 247         next unless ( -f $_ );
 248         push( @files, $_ );
 249     }
 250
 251     if ( !scalar @files ) {
 252         &::ERROR("sC: no files?");
 253         &::msg( $::who, "failed." );
 254         return;
 255     }
 256
 257     my $files = join( ' ', @files );
 258
 259     my $regex = $query;
 260     $regex =~ s/\./\\./g;
 261     $regex =~ s/\*/\\S*/g;
 262     $regex =~ s/\?/./g;
 263
 264     open( IN, "zegrep -h '$grepRE' $files |" );
 265
 266     # wonderful abuse of if, last, next, return, and, unless ;)
 267     while (<IN>) {
 268         last if ( $found > 100 );
 269
 270         next unless (/^\.?\/?(.*?)[\t\s]+(\S+)\n$/);
 271         my ( $file, $package ) = ( "/" . $1, $2 );
 272
 273         if ( $query =~ /[\/\*\\]/ ) {
 274             next unless ( eval { $file =~ /$regex/ } );
 275             return unless &checkEval($@);
 276         }
 277         else {
 278             my ($basename) = $file =~ /^.*\/(.*)$/;
 279             next unless ( eval { $basename =~ /$regex/ } );
 280             return unless &checkEval($@);
 281         }
 282         next if ( $query !~ /\.\d\.gz/ and $file =~ /\/man\// );
 283         next if ( $front and eval { $file !~ /^\/$query/ } );
 284         return unless &checkEval($@);
 285
 286         $contents{$package}{$file} = 1;
 287         $found++;
 288     }
 289     close IN;
 290
 291     my $pkg;
 292
 293     ### send results with dcc.
 294     if ($dccsend) {
 295         if ( exists $::dcc{'SEND'}{$::who} ) {
 296             &::msg( $::who, "DCC already active!" );
 297             return;
 298         }
 299
 300         if ( !scalar %contents ) {
 301             &::msg( $::who, "search returned no results." );
 302             return;
 303         }
 304
 305         my $file = "$::param{tempDir}/$::who.txt";
 306         if ( !open OUT, ">$file" ) {
 307             &::ERROR("Debian: cannot write file for dcc send.");
 308             return;
 309         }
 310
 311         foreach $pkg ( keys %contents ) {
 312             foreach ( keys %{ $contents{$pkg} } ) {
 313
 314                 # TODO: correct padding.
 315                 print OUT "$_\t\t\t$pkg\n";
 316             }
 317         }
 318         close OUT;
 319
 320         &::shmWrite( $::shm, "DCC SEND $::who $file" );
 321
 322         return;
 323     }
 324
 325     &::status("Debian: $found contents results found.");
 326
 327     my @list;
 328     foreach $pkg ( keys %contents ) {
 329         my @tmplist = &::fixFileList( keys %{ $contents{$pkg} } );
 330         my @sublist = sort { length $a <=> length $b } @tmplist;
 331
 332         pop @sublist while ( scalar @sublist > 3 );
 333
 334         $pkg =~ s/\,/\037\,\037/g;    # underline ','.
 335         push( @list, "(" . join( ', ', @sublist ) . ") in $pkg" );
 336     }
 337
 338     # sort the total list from shortest to longest...
 339     @list = sort { length $a <=> length $b } @list;
 340
 341     # show how long it took.
 342     my $delta_time = &::timedelta($start_time);
 343     &::status( sprintf( "Debian: %.02f sec to complete query.", $delta_time ) )
 344       if ( $delta_time > 0 );
 345
 346     my $prefix = "Debian Search of '$query' ";
 347     if ( scalar @list ) {    # @list.
 348         &::performStrictReply( &::formListReply( 0, $prefix, @list ) );
 349         return;
 350     }
 351
 352     # !@list.
 353     &::DEBUG("deb: ok, !\@list, searching desc for '$query'.") if ($debug);
 354     @list = &searchDesc($query);
 355
 356     if ( !scalar @list ) {
 357         my $prefix = "Debian Package/File/Desc Search of '$query' ";
 358         &::performStrictReply( &::formListReply( 0, $prefix, ) );
 359
 360     }
 361     elsif ( scalar @list == 1 ) {    # list = 1.
 362         &::DEBUG("deb: list == 1; showing package info of '$list[0]'.");
 363         &infoPackages( "info", $list[0] );
 364
 365     }
 366     else {                           # list > 1.
 367         my $prefix = "Debian Desc Search of '$query' ";
 368         &::performStrictReply( &::formListReply( 0, $prefix, @list ) );
 369     }
 370 }
 371
 372 ####
 373 # Usage: &searchAuthor($query);
 374 sub searchAuthor {
 375     my ( $dist, $query ) = &getDistroFromStr( $_[0] );
 376     &::DEBUG("deb: searchAuthor: dist => '$dist', query => '$query'.")
 377       if ($debug);
 378     $query =~ s/^\s+|\s+$//g;
 379
 380     # start of search.
 381     my $start_time = &::timeget();
 382     &::status("Debian: starting author search.");
 383
 384     my %urls = fixDist( $dist, 'packages' );
 385     my $files;
 386     my ( $bad, $good ) = ( 0, 0 );
 387     foreach ( keys %urls ) {
 388         if ( !-f $_ ) {
 389             $bad++;
 390             next;
 391         }
 392
 393         $good++;
 394         $files .= " " . $_;
 395     }
 396
 397     &::DEBUG("deb: good = $good, bad = $bad...") if ($debug);
 398
 399     if ( $good == 0 and $bad != 0 ) {
 400         &::DEBUG("deb: download 2.");
 401
 402         if ( !&DebianDownload( $dist, %urls ) ) {
 403             &::ERROR("Debian(sA): could not download files.");
 404             return;
 405         }
 406     }
 407
 408     my ( %maint, %pkg, $package );
 409     open( IN, "zegrep -h '^Package|^Maintainer' $files |" );
 410     while (<IN>) {
 411         if (/^Package: (\S+)$/) {
 412             $package = $1;
 413
 414         }
 415         elsif (/^Maintainer: (.*) \<(\S+)\>$/) {
 416             my ( $name, $email ) = ( $1, $2 );
 417             if ( $package eq "" ) {
 418                 &::DEBUG("deb: sA: package == NULL.");
 419                 next;
 420             }
 421             $maint{$name}{$email} = 1;
 422             $pkg{$name}{$package} = 1;
 423             $package              = "";
 424
 425         }
 426         else {
 427             chop;
 428             &::WARN("debian: invalid line: '$_' (1).");
 429         }
 430     }
 431     close IN;
 432
 433     my %hash;
 434
 435     # TODO: can we use 'map' here?
 436     foreach ( grep /\Q$query\E/i, keys %maint ) {
 437         $hash{$_} = 1;
 438     }
 439
 440     # TODO: should we only search email if '@' is used?
 441     if ( scalar keys %hash < 15 ) {
 442         my $name;
 443
 444         foreach $name ( keys %maint ) {
 445             my $email;
 446
 447             foreach $email ( keys %{ $maint{$name} } ) {
 448                 next unless ( $email =~ /\Q$query\E/i );
 449                 next if ( exists $hash{$name} );
 450                 $hash{$name} = 1;
 451             }
 452         }
 453     }
 454
 455     my @list = keys %hash;
 456     if ( scalar @list != 1 ) {
 457         my $prefix = "Debian Author Search of '$query' ";
 458         &::performStrictReply( &::formListReply( 0, $prefix, @list ) );
 459         return 1;
 460     }
 461
 462     &::DEBUG("deb: showing all packages by '$list[0]'...") if ($debug);
 463
 464     my @pkg = sort keys %{ $pkg{ $list[0] } };
 465
 466     # show how long it took.
 467     my $delta_time = &::timedelta($start_time);
 468     &::status( sprintf( "Debian: %.02f sec to complete query.", $delta_time ) )
 469       if ( $delta_time > 0 );
 470
 471     my $email = join( ', ', keys %{ $maint{ $list[0] } } );
 472     my $prefix = "Debian Packages by $list[0] \002<\002$email\002>\002 ";
 473     &::performStrictReply( &::formListReply( 0, $prefix, @pkg ) );
 474 }
 475
 476 ####
 477 # Usage: &searchDesc($query);
 478 sub searchDesc {
 479     my ( $dist, $query ) = &getDistroFromStr( $_[0] );
 480     &::DEBUG("deb: searchDesc: dist => '$dist', query => '$query'.")
 481       if ($debug);
 482     $query =~ s/^\s+|\s+$//g;
 483
 484     # start of search.
 485     my $start_time = &::timeget();
 486     &::status("Debian: starting desc search.");
 487
 488     my $files;
 489     my ( $bad, $good ) = ( 0, 0 );
 490     my %urls = fixDist( $dist, 'packages' );
 491
 492     # XXX This should be abstracted elsewhere.
 493     foreach ( keys %urls ) {
 494         if ( !-f $_ ) {
 495             $bad++;
 496             next;
 497         }
 498
 499         $good++;
 500         $files .= " $_";
 501     }
 502
 503     &::DEBUG("deb(2): good = $good, bad = $bad...") if ($debug);
 504
 505     if ( $good == 0 and $bad != 0 ) {
 506         &::DEBUG("deb: download 2c.") if ($debug);
 507
 508         if ( !&DebianDownload( $dist, %urls ) ) {
 509             &::ERROR("deb: sD: could not download files.");
 510             return;
 511         }
 512     }
 513
 514     my $regex = $query;
 515     $regex =~ s/\./\\./g;
 516     $regex =~ s/\*/\\S*/g;
 517     $regex =~ s/\?/./g;
 518
 519     my ( %desc, $package );
 520     open( IN, "zegrep -h '^Package|^Description' $files |" );
 521     while (<IN>) {
 522         if (/^Package: (\S+)$/) {
 523             $package = $1;
 524         }
 525         elsif (/^Description: (.*)$/) {
 526             my $desc = $1;
 527             next unless ( eval { $desc =~ /$regex/i } );
 528             return unless &checkEval($@);
 529
 530             if ( $package eq "" ) {
 531                 &::WARN("sD: package == NULL?");
 532                 next;
 533             }
 534
 535             $desc{$package} = $desc;
 536             $package = "";
 537
 538         }
 539         else {
 540             chop;
 541             &::WARN("debian: invalid line: '$_'. (2)");
 542         }
 543     }
 544     close IN;
 545
 546     # show how long it took.
 547     my $delta_time = &::timedelta($start_time);
 548     &::status( sprintf( "Debian: %.02f sec to complete query.", $delta_time ) )
 549       if ( $delta_time > 0 );
 550
 551     return keys %desc;
 552 }
 553
 554 ####
 555 # Usage: &generateIncoming();
 556 sub generateIncoming {
 557     my $pkgfile = $debian_dir . "/Packages-incoming";
 558     my $idxfile = $pkgfile . ".idx";
 559     my $stale   = 0;
 560     $stale++ if ( &::isStale( $pkgfile . ".gz", $refresh ) );
 561     $stale++ if ( &::isStale( $idxfile, $refresh ) );
 562     &::DEBUG("deb: gI: stale => '$stale'.") if ($debug);
 563     return 0 unless ($stale);
 564
 565     ### STATIC URL.
 566     my %ftp = &::ftpList( "llug.sep.bnl.gov", "/pub/debian/Incoming/" );
 567
 568     if ( !open PKG, ">$pkgfile" ) {
 569         &::ERROR("cannot write to pkg $pkgfile.");
 570         return 0;
 571     }
 572     if ( !open IDX, ">$idxfile" ) {
 573         &::ERROR("cannot write to idx $idxfile.");
 574         return 0;
 575     }
 576
 577     print IDX "*$pkgfile.gz\n";
 578     my $file;
 579     foreach $file ( sort keys %ftp ) {
 580         next unless ( $file =~ /deb$/ );
 581
 582         if ( $file =~ /^(\S+)\_(\S+)\_(\S+)\.deb$/ ) {
 583             print IDX "$1\n";
 584             print PKG "Package: $1\n";
 585             print PKG "Version: $2\n";
 586             print PKG "Architecture: ", ( defined $4 ) ? $4 : "all", "\n";
 587         }
 588         print PKG "Filename: $file\n";
 589         print PKG "Size: $ftp{$file}\n";
 590         print PKG "\n";
 591     }
 592     close IDX;
 593     close PKG;
 594
 595     system("gzip -9fv $pkgfile");    # lame fix.
 596
 597     &::status("Debian: generateIncoming() complete.");
 598 }
 599
 600
 601 ##############################
 602 # DEBIAN PACKAGE INFO FUNCTIONS.
 603 #########
 604
 605 # Usage: &getPackageInfo($query,$file);
 606 sub getPackageInfo {
 607     my ( $package, $file ) = @_;
 608
 609     if ( !-f $file ) {
 610         &::status("gPI: file $file does not exist?");
 611         return 'NULL';
 612     }
 613
 614     my $found = 0;
 615     my ( %pkg, $pkg );
 616
 617     open( IN, "/bin/zcat $file 2>&1 |" );
 618
 619     my $done = 0;
 620     while ( !eof IN ) {
 621         $_ = <IN>;
 622
 623         next if (/^ \S+/);    # package long description.
 624
 625         # package line.
 626         if (/^Package: (.*)\n$/) {
 627             $pkg = $1;
 628             if ( $pkg =~ /^\Q$package\E$/i ) {
 629                 $found++;     # we can use pkg{'package'} instead.
 630                 $pkg{'package'} = $pkg;
 631             }
 632
 633             next;
 634         }
 635
 636         if ($found) {
 637             chop;
 638
 639             if (/^Version: (.*)$/) {
 640                 $pkg{'version'} = $1;
 641             }
 642             elsif (/^Priority: (.*)$/) {
 643                 $pkg{'priority'} = $1;
 644             }
 645             elsif (/^Section: (.*)$/) {
 646                 $pkg{'section'} = $1;
 647             }
 648             elsif (/^Size: (.*)$/) {
 649                 $pkg{'size'} = $1;
 650             }
 651             elsif (/^Installed-Size: (.*)$/i) {
 652                 $pkg{'installed'} = $1;
 653             }
 654             elsif (/^Description: (.*)$/) {
 655                 $pkg{'desc'} = $1;
 656             }
 657             elsif (/^Filename: (.*)$/) {
 658                 $pkg{'find'} = $1;
 659             }
 660             elsif (/^Pre-Depends: (.*)$/) {
 661                 $pkg{'depends'} = "pre-depends on $1";
 662             }
 663             elsif (/^Depends: (.*)$/) {
 664                 if ( exists $pkg{'depends'} ) {
 665                     $pkg{'depends'} .= "; depends on $1";
 666                 }
 667                 else {
 668                     $pkg{'depends'} = "depends on $1";
 669                 }
 670             }
 671             elsif (/^Maintainer: (.*)$/) {
 672                 $pkg{'maint'} = $1;
 673             }
 674             elsif (/^Provides: (.*)$/) {
 675                 $pkg{'provides'} = $1;
 676             }
 677             elsif (/^Suggests: (.*)$/) {
 678                 $pkg{'suggests'} = $1;
 679             }
 680             elsif (/^Conflicts: (.*)$/) {
 681                 $pkg{'conflicts'} = $1;
 682             }
 683
 684 ###         &::DEBUG("=> '$_'.");
 685         }
 686
 687         # blank line.
 688         if (/^$/) {
 689             undef $pkg;
 690             last if ($found);
 691             next;
 692         }
 693
 694         next if ( defined $pkg );
 695     }
 696
 697     close IN;
 698
 699     %pkg;
 700 }
 701
 702 # Usage: &infoPackages($query,$package);
 703 sub infoPackages {
 704     my ( $query, $dist, $package ) = ( $_[0], &getDistroFromStr( $_[1] ) );
 705
 706     &::status("Debian: Searching for package '$package' in '$dist'.");
 707
 708     # download packages file.
 709     # hrm...
 710     my %urls = &fixDist( $dist, 'packages' );
 711     if ( $dist ne "incoming" ) {
 712         &::DEBUG("deb: download 3.") if ($debug);
 713
 714         if ( !&DebianDownload( $dist, %urls ) ) {    # no good download.
 715             &::WARN("Debian(iP): could not download ANY files.");
 716         }
 717     }
 718
 719     # check if the package is valid.
 720     my $incoming = 0;
 721     my @files = &validPackage( $package, $dist );
 722     if ( !scalar @files ) {
 723         &::status("Debian: no valid package found; checking incoming.");
 724         @files = &validPackage( $package, "incoming" );
 725
 726         if ( scalar @files ) {
 727             &::status("Debian: cool, it exists in incoming.");
 728             $incoming++;
 729         }
 730         else {
 731             &::msg( $::who, "Package '$package' does not exist." );
 732             return 0;
 733         }
 734     }
 735
 736     if ( scalar @files > 1 ) {
 737         &::WARN("same package in more than one file; random.");
 738         &::DEBUG("THIS SHOULD BE FIXED SOMEHOW!!!");
 739         $files[0] = &::getRandom(@files);
 740     }
 741
 742     if ( !-f $files[0] ) {
 743         &::WARN("files[0] ($files[0]) doesn't exist.");
 744         &::msg( $::who, "FIXME: $files[0] does not exist?" );
 745         return 'NULL';
 746     }
 747
 748     ### TODO: if specific package is requested, note down that a version
 749     ###         exists in incoming.
 750
 751     my $found = 0;
 752     my $file  = $files[0];
 753     my ($pkg);
 754
 755     ### TODO: use fe, dump to a hash. if only one version of the package
 756     ###         exists. do as normal otherwise list all versions.
 757     if ( !-f $file ) {
 758         &::ERROR("D:iP: file '$file' DOES NOT EXIST!!! should never happen.");
 759         return 0;
 760     }
 761     my %pkg = &getPackageInfo( $package, $file );
 762
 763     $query = "info" if ( $query eq "dinfo" );
 764
 765     # 'fm'-like output.
 766     if ( $query eq "info" ) {
 767         if ( scalar keys %pkg <= 5 ) {
 768             &::DEBUG( "deb: running debianCheck() due to problems ("
 769                   . scalar( keys %pkg )
 770                   . ")." );
 771             &debianCheck();
 772             &::DEBUG("deb: end of debianCheck()");
 773
 774             &::msg( $::who,
 775 "Debian: Package appears to exist but I could not retrieve info about it..."
 776             );
 777             return;
 778         }
 779
 780         $pkg{'info'} = "\002(\002" . $pkg{'desc'} . "\002)\002";
 781         $pkg{'info'} .= ", section " . $pkg{'section'};
 782         $pkg{'info'} .= ", is " . $pkg{'priority'};
 783
 784         #       $pkg{'info'} .= ". Version: \002$pkg{'version'}\002";
 785         $pkg{'info'} .= ". Version: \002$pkg{'version'}\002 ($dist)";
 786         $pkg{'info'} .=
 787           ", Packaged size: \002" . int( $pkg{'size'} / 1024 ) . "\002 kB";
 788         $pkg{'info'} .= ", Installed size: \002$pkg{'installed'}\002 kB";
 789
 790         if ($incoming) {
 791             &::status("iP: info requested and pkg is in incoming, too.");
 792             my %incpkg =
 793               &getPackageInfo( $query, $debian_dir . "/Packages-incoming" );
 794
 795             if ( scalar keys %incpkg ) {
 796                 $pkg{'info'} .= ". Is in incoming ($incpkg{'file'}).";
 797             }
 798             else {
 799                 &::ERROR(
 800 "iP: pkg $query is in incoming but we couldn't get any info?"
 801                 );
 802             }
 803         }
 804     }
 805
 806     if ( $dist eq "incoming" ) {
 807         $pkg{'info'} .= "Version: \002$pkg{'version'}\002";
 808         $pkg{'info'} .=
 809           ", Packaged size: \002" . int( $pkg{'size'} / 1024 ) . "\002 kB";
 810         $pkg{'info'} .= ", is in incoming!!!";
 811     }
 812
 813     if ( !exists $pkg{$query} ) {
 814         if ( $query eq "suggests" ) {
 815             $pkg{$query} = "has no suggestions";
 816         }
 817         elsif ( $query eq "conflicts" ) {
 818             $pkg{$query} = "does not conflict with any other package";
 819         }
 820         elsif ( $query eq "depends" ) {
 821             $pkg{$query} = "does not depend on anything";
 822         }
 823         elsif ( $query eq "maint" ) {
 824             $pkg{$query} = "has no maintainer";
 825         }
 826         else {
 827             $pkg{$query} = "has nothing about $query";
 828         }
 829     }
 830
 831     &::performStrictReply("$package: $pkg{$query}");
 832 }
 833
 834 # Usage: &infoStats($dist);
 835 sub infoStats {
 836     my ($dist) = @_;
 837     $dist = &getDistro($dist);
 838     return unless ( defined $dist );
 839
 840     &::DEBUG("deb: infoS: dist => '$dist'.");
 841
 842     # download packages file if needed.
 843     my %urls = &fixDist( $dist, 'packages' );
 844     &::DEBUG("deb: download 4.");
 845     if ( !&DebianDownload( $dist, %urls ) ) {
 846         &::WARN("Debian(iS): could not download ANY files.");
 847         &::msg( $::who, "Debian(iS): internal error." );
 848         return;
 849     }
 850
 851     my %stats;
 852     my %total = ( count => 0, maint => 0, isize => 0, csize => 0 );
 853     my $file;
 854     foreach $file ( keys %urls ) {
 855         &::DEBUG("deb: file => '$file'.");
 856         if ( exists $stats{$file}{'count'} ) {
 857             &::DEBUG("deb: hrm... duplicate open with $file???");
 858             next;
 859         }
 860
 861         open( IN, "zcat $file 2>&1 |" );
 862
 863         if ( !-e "$file" ) {
 864             &::DEBUG("deb: iS: $file does not exist.");
 865             next;
 866         }
 867
 868         while ( !eof IN ) {
 869             $_ = <IN>;
 870
 871             next if (/^ \S+/);    # package long description.
 872
 873             if (/^Package: (.*)\n$/) {    # counter.
 874                 $stats{$file}{'count'}++;
 875                 $total{'count'}++;
 876             }
 877             elsif (/^Maintainer: .* <(\S+)>$/) {
 878                 $stats{$file}{'maint'}{$1}++;
 879                 $total{'maint'}{$1}++;
 880             }
 881             elsif (/^Size: (.*)$/) {      # compressed size.
 882                 $stats{$file}{'csize'} += $1;
 883                 $total{'csize'}        += $1;
 884             }
 885             elsif (/^i.*size: (.*)$/i) {    # installed size.
 886                 $stats{$file}{'isize'} += $1;
 887                 $total{'isize'}        += $1;
 888             }
 889
 890 ###         &::DEBUG("=> '$_'.");
 891         }
 892         close IN;
 893     }
 894
 895     ### TODO: don't count ppl with multiple email addresses.
 896
 897     &::performStrictReply( "Debian Distro Stats on $dist... "
 898           . "\002$total{'count'}\002 packages, " . "\002"
 899           . scalar( keys %{ $total{'maint'} } )
 900           . "\002 maintainers, " . "\002"
 901           . int( $total{'isize'} / 1024 )
 902           . "\002 MB installed size, " . "\002"
 903           . int( $total{'csize'} / 1024 / 1024 )
 904           . "\002 MB compressed size." );
 905
 906 ### TODO: do individual stats? if so, we need _another_ arg.
 907     #    foreach $file (keys %stats) {
 908     #   foreach (keys %{ $stats{$file} }) {
 909     #       &::DEBUG("  '$file' '$_' '$stats{$file}{$_}'.");
 910     #   }
 911     #    }
 912
 913     return;
 914 }
 915
 916 ###
 917 # HELPER FUNCTIONS FOR INFOPACKAGES...
 918 ###
 919
 920 # Usage: &generateIndex();
 921 sub generateIndex {
 922     my (@dists) = @_;
 923     &::DEBUG( "D: generateIndex($dists[0]) called! " . join( ':', caller(), ) );
 924     if ( !scalar @dists or $dists[0] eq '' ) {
 925         &::ERROR("gI: no dists to generate index.");
 926         return 1;
 927     }
 928
 929     foreach (@dists) {
 930         my $dist = &getDistro($_);    # incase the alias is returned, possible?
 931         my $idx = $debian_dir . "/Packages-$dist.idx";
 932         my %urls = fixDist( $_, 'packages' );
 933
 934         # TODO: check if any of the Packages file have been updated then
 935         #       regenerate it, even if it's not stale.
 936         # TODO: also, regenerate the index if the packages file is newer
 937         #       than the index.
 938         next unless ( &::isStale( $idx, $refresh ) );
 939
 940         if (/^incoming$/i) {
 941             &::DEBUG("deb: gIndex: calling generateIncoming()!");
 942             &generateIncoming();
 943             next;
 944         }
 945
 946         #       if (/^sarge$/i) {
 947         #           &::DEBUG("deb: Copying old index of sarge to -old");
 948         #           system("cp $idx $idx-old");
 949         #       }
 950
 951         &::DEBUG("deb: gIndex: calling DebianDownload($dist, ...).")
 952           if ($debug);
 953         &DebianDownload( $dist, &fixDist( $dist, 'packages' ) );
 954
 955         &::status("Debian: generating index for '$dist'.");
 956         if ( !open OUT, ">$idx" ) {
 957             &::ERROR("cannot write to $idx.");
 958             return 0;
 959         }
 960
 961         my $packages;
 962         foreach $packages ( keys %urls ) {
 963             if ( !-e $packages ) {
 964                 &::ERROR("gIndex: '$packages' does not exist?");
 965                 next;
 966             }
 967
 968             print OUT "*$packages\n";
 969             open( IN, "zcat $packages |" );
 970
 971             while (<IN>) {
 972                 next unless (/^Package: (.*)\n$/);
 973                 print OUT $1 . "\n";
 974             }
 975             close IN;
 976         }
 977         close OUT;
 978     }
 979
 980     return 1;
 981 }
 982
 983 # Usage: &validPackage($package, $dist);
 984 sub validPackage {
 985     my ( $package, $dist ) = @_;
 986     my @files;
 987     my $file;
 988
 989     ### this majorly sucks, we need some standard in place.
 990     # why is this needed... need to investigate later.
 991     my $olddist = $dist;
 992     $dist = &getDistro($dist);
 993
 994     &::DEBUG("deb: validPackage($package, $dist) called.") if ($debug);
 995
 996     my $error = 0;
 997     while ( !open IN, $debian_dir . "/Packages-$dist.idx" ) {
 998         if ($error) {
 999             &::ERROR("Packages-$dist.idx does not exist (#1).");
1000             return;
1001         }
1002
1003         &generateIndex($dist);
1004
1005         $error++;
1006     }
1007
1008     my $count = 0;
1009     while (<IN>) {
1010         if (/^\*(.*)\n$/) {
1011             $file = $1;
1012             next;
1013         }
1014
1015         if (/^\Q$package\E\n$/) {
1016             push( @files, $file );
1017         }
1018         $count++;
1019     }
1020     close IN;
1021
1022     &::VERB( "vP: scanned $count items in index.", 2 );
1023
1024     return @files;
1025 }
1026
1027 sub searchPackage {
1028     my ( $dist, $query ) = &getDistroFromStr( $_[0] );
1029     my $file  = $debian_dir . "/Packages-$dist.idx";
1030     my $warn  = ( $query =~ tr/A-Z/a-z/ ) ? 1 : 0;
1031     my $error = 0;
1032     my @files;
1033
1034     &::status("Debian: Search package matching '$query' in '$dist'.");
1035     unlink $file if ( -z $file );
1036
1037     while ( !open IN, $file ) {
1038         if ( $dist eq "incoming" ) {
1039             &::DEBUG("deb: sP: dist == incoming; calling gI().");
1040             &generateIncoming();
1041         }
1042
1043         if ($error) {
1044             &::ERROR("could not generate index ($file)!");
1045             return;
1046         }
1047
1048         $error++;
1049         &::DEBUG("deb: should we be doing this?");
1050         &generateIndex( ($dist) );
1051     }
1052
1053     while (<IN>) {
1054         chop;
1055
1056         if (/^\*(.*)$/) {
1057             $file = $1;
1058
1059             if ( &::isStale( $file, $refresh ) ) {
1060                 &::DEBUG("deb: STALE $file! regen.") if ($debug);
1061                 &generateIndex( ($dist) );
1062 ###             @files = searchPackage("$query $dist");
1063                 &::DEBUG("deb: EVIL HACK HACK HACK.") if ($debug);
1064                 last;
1065             }
1066
1067             next;
1068         }
1069
1070         if (/\Q$query\E/) {
1071             push( @files, $_ );
1072         }
1073     }
1074     close IN;
1075
1076     if ( scalar @files and $warn ) {
1077         &::msg( $::who,
1078             "searching for package name should be fully lowercase!" );
1079     }
1080
1081     return @files;
1082 }
1083
1084 sub getDistro {
1085     my $dist = $_[0];
1086
1087     if ( !defined $dist or $dist eq "" ) {
1088         &::DEBUG("deb: gD: dist == NULL; dist = defaultdist.");
1089         $dist = $defaultdist;
1090     }
1091
1092     if ( exists $dists{$dist} ) {
1093         &::VERB( "gD: returning dists{$dist} ($dists{$dist})", 2 );
1094         return $dists{$dist};
1095
1096     }
1097     elsif ( exists $archived_dists{$dist} ) {
1098         &::VERB( "gD: returning archivedists{$dist} ($archived_dists{$dist})",
1099             2 );
1100         return $archived_dists{$dist};
1101     }
1102     else {
1103         if (    !grep( /^\Q$dist\E$/i, %dists )
1104             and !grep( /^\Q$dist\E$/i, %archived_dists ) )
1105         {
1106             &::msg( $::who, "invalid dist '$dist'." );
1107             return;
1108         }
1109
1110         &::VERB( "gD: returning $dist (no change or conversion)", 2 );
1111         return $dist;
1112     }
1113 }
1114
1115 sub getDistroFromStr {
1116     my ($str) = @_;
1117     my $dists = join '|', %dists, %archived_dists;
1118     my $dist = $defaultdist;
1119
1120     if ( $str =~ s/\s+($dists)$//i ) {
1121         $dist = &getDistro( lc $1 );
1122         $str =~ s/\\+$//;
1123     }
1124     $str =~ s/\\([\$\^])/$1/g;
1125
1126     return ( $dist, $str );
1127 }
1128
1129 sub fixDist {
1130     my ( $dist, $type ) = @_;
1131     my %new;
1132     my ( $key, $val );
1133     my %dist_urls;
1134
1135     if ( exists $archived_dists{$dist} ) {
1136         if ( $type eq 'contents' ) {
1137             %dist_urls = %archiveurlcontents;
1138         }
1139         else {
1140             %dist_urls = %archiveurlpackages;
1141         }
1142     }
1143     else {
1144         if ( $type eq 'contents' ) {
1145             %dist_urls = %urlcontents;
1146         }
1147         else {
1148             %dist_urls = %urlpackages;
1149         }
1150     }
1151
1152     while ( ( $key, $val ) = each %dist_urls ) {
1153         $key =~ s/##DIST/$dist/;
1154         $val =~ s/##DIST/$dist/;
1155         ### TODO: what should we do if the sar wasn't done.
1156         $new{ $debian_dir . "/" . $key } = $val;
1157     }
1158
1159     return %new;
1160 }
1161
1162 sub DebianFind {
1163
1164     # HACK! HACK! HACK!
1165     my ($str) = @_;
1166     my ( $dist, $query ) = &getDistroFromStr($str);
1167     my @results = sort &searchPackage($str);
1168
1169     if ( !scalar @results ) {
1170         &::Forker( "Debian", sub { &searchContents($str); } );
1171     }
1172     elsif ( scalar @results == 1 ) {
1173         &::status(
1174 "searchPackage returned one result; getting info of package instead!"
1175         );
1176         &::Forker( "Debian",
1177             sub { &infoPackages( "info", "$results[0] $dist" ); } );
1178     }
1179     else {
1180         my $prefix = "Debian Package Listing of '$query' ";
1181         &::performStrictReply( &::formListReply( 0, $prefix, @results ) );
1182     }
1183 }
1184
1185 sub debianCheck {
1186     my $error = 0;
1187
1188     &::status("debianCheck() called.");
1189
1190     ### TODO: remove the following loop (check if dir exists before)
1191     while (1) {
1192         last if ( opendir( DEBIAN, $debian_dir ) );
1193
1194         if ($error) {
1195             &::ERROR("dC: cannot opendir debian.");
1196             return;
1197         }
1198
1199         mkdir $debian_dir, 0755;
1200         $error++;
1201     }
1202
1203     my $retval = 0;
1204     my $file;
1205     while ( defined( $file = readdir DEBIAN ) ) {
1206         next unless ( $file =~ /(gz|bz2)$/ );
1207
1208         # TODO: add bzip2 support (debian doesn't do .bz2 anyway)
1209         my $exit = system("/bin/gzip -t '$debian_dir/$file'");
1210         next unless ($exit);
1211         &::DEBUG( "deb: hmr... => "
1212               . ( time() - ( stat( $debian_dir / $file ) )[8] )
1213               . "'." );
1214         next unless ( time() - ( stat($file) )[8] > 3600 );
1215
1216         #&::DEBUG("deb: dC: exit => '$exit'.");
1217         &::WARN("dC: '$debian_dir/$file' corrupted? deleting!");
1218         unlink $debian_dir . "/" . $file;
1219         $retval++;
1220     }
1221
1222     return $retval;
1223 }
1224
1225 sub checkEval {
1226     my ($str) = @_;
1227
1228     if ($str) {
1229         &::WARN("cE: $str");
1230         return 0;
1231     }
1232     else {
1233         return 1;
1234     }
1235 }
1236
1237 sub searchDescFE {
1238
1239     #    &::DEBUG("deb: FE called for searchDesc");
1240     my ($query) = @_;
1241     my @list = &searchDesc($query);
1242
1243     if ( !scalar @list ) {
1244         my $prefix = "Debian Desc Search of '$query' ";
1245         &::performStrictReply( &::formListReply( 0, $prefix, ) );
1246     }
1247     elsif ( scalar @list == 1 ) {    # list = 1.
1248         &::DEBUG("deb: list == 1; showing package info of '$list[0]'.");
1249         &infoPackages( "info", $list[0] );
1250     }
1251     else {                           # list > 1.
1252         my $prefix = "Debian Desc Search of '$query' ";
1253         &::performStrictReply( &::formListReply( 0, $prefix, @list ) );
1254     }
1255 }
1256
1257 1;
1258
1259 # vim:ts=4:sw=4:expandtab:tw=80