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