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