src/Modules/Debian.pl

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