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