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