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