lib/Packages/DoFilelist.pm

   1 package Packages::DoFilelist;
   2
   3 use strict;
   4 use warnings;
   5
   6 use POSIX;
   7 use URI::Escape;
   8 use HTML::Entities;
   9 use DB_File;
  10 use Benchmark ':hireswallclock';
  11 use Exporter;
  12
  13 use Deb::Versions;
  14 use Packages::Config qw( $DBDIR $ROOT @SUITES @ARCHIVES @SECTIONS
  15                          @ARCHITECTURES %FTP_SITES );
  16 use Packages::I18N::Locale;
  17 use Packages::CGI;
  18 use Packages::DB;
  19 use Packages::Search qw( :all );
  20 use Packages::HTML;
  21 use Packages::Page ();
  22 use Packages::SrcPage ();
  23
  24 our @ISA = qw( Exporter );
  25 our @EXPORT = qw( do_filelist );
  26
  27 sub do_filelist {
  28     my ($params, $opts, $html_header, $menu, $page_content) = @_;
  29
  30     if ($params->{errors}{package}) {
  31         fatal_error( _g( "package not valid or not specified" ) );
  32     }
  33     if ($params->{errors}{suite}) {
  34         fatal_error( _g( "suite not valid or not specified" ) );
  35     }
  36     if ($params->{errors}{arch}) {
  37         fatal_error( _g( "architecture not valid or not specified" ) );
  38     }
  39
  40     $$menu = '';
  41     my $pkg = $opts->{package};
  42     my $suite = $opts->{suite}[0];
  43     my $arch = $opts->{arch}[0] ||'';
  44
  45     %$html_header = ( title => sprintf( _g( "Filelist of package <em>%s</em> in <em>%s</em> of architecture <em>%s</em>" ), $pkg, $suite, $arch ),
  46                       title_tag => sprintf( _g( "Filelist of package %s/%s/%s" ), $pkg, $suite, $arch ),
  47                       lang => $opts->{lang},
  48                       keywords => "debian, $suite, $arch, filelist",
  49                       print_title => 1,
  50                       );
  51
  52     unless (@Packages::CGI::fatal_errors) {
  53         if (tie my %contents, 'DB_File', "$DBDIR/contents/filelists_${suite}_${arch}.db",
  54             O_RDONLY, 0666, $DB_BTREE) {
  55
  56             unless (exists $contents{$pkg}) {
  57                 fatal_error( _g( "No such package in this suite on this architecture." ) );
  58             } else {
  59                 my @files = unpack "L/(CC/a)", $contents{$pkg};
  60                 my $file = "";
  61                 $$page_content .= '<div id="pfilelist"><pre>';
  62                 for (my $i=0; $i<scalar @files;) {
  63                     $file = substr($file, 0, $files[$i++]).$files[$i++];
  64                     $$page_content .= "/$file\n";
  65                 }
  66                 $$page_content .= '</pre></div>';
  67             }
  68         } else {
  69             fatal_error( _g( "Invalid suite/architecture combination" ) );
  70         }
  71     }
  72 }
  73
  74 1;