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