src/Modules/Debian.pl

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