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