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