]> git.deb.at Git - deb/packages.git/blob - lib/Packages/DoShow.pm
Merge branch 'archive-master' of git+ssh://git.debian.org/git/webwml/packages into...
[deb/packages.git] / lib / Packages / DoShow.pm
1 package Packages::DoShow;
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 @SUITES @ARCHIVES @SECTIONS
15                          @ARCHITECTURES %FTP_SITES
16                          @LANGUAGES @DDTP_LANGUAGES);
17 use Packages::CGI qw( :DEFAULT make_url make_search_url );
18 use Packages::DB;
19 use Packages::Search qw( :all );
20 use Packages::Page ();
21 use Packages::SrcPage ();
22
23 our @ISA = qw( Exporter );
24 our @EXPORT = qw( do_show );
25
26 sub do_show {
27     my ($params, $opts, $page_contents) = @_;
28     my $cat = $opts->{cat};
29
30     if ($params->{errors}{package}) {
31         fatal_error( $cat->g( "package not valid or not specified" ) );
32     }
33     if ($params->{errors}{suite}) {
34         fatal_error( $cat->g( "suite not valid or not specified" ) );
35     }
36     if (@{$opts->{suite}} > 1) {
37         fatal_error( $cat->g( "more than one suite specified for show (%s)",
38                               "@{$opts->{suite}}" ) );
39     }
40
41     my %contents;
42     $contents{make_url} = sub { return &Packages::CGI::make_url(@_) };
43
44     my $pkg = $opts->{package};
45     $contents{pkg} = $pkg;
46     my $suite = $opts->{suite}[0];
47     $contents{suite} = $suite;
48     my $archive = $opts->{archive}[0] ||'';
49     
50     our (%packages_all, %sources_all);
51     my (@results, @non_results);
52     my $page = $opts->{source} ?
53         new Packages::SrcPage( $pkg ) :
54         new Packages::Page( $pkg );
55     my ($short_desc, $version, $section, $subsection) = ("")x5;
56     
57     my $st0 = new Benchmark;
58     unless (@Packages::CGI::fatal_errors) {
59         tie %packages_all, 'DB_File', "$DBDIR/packages_all_$suite.db",
60         O_RDONLY, 0666, $DB_BTREE
61             or die "couldn't tie DB $DBDIR/packages_all_$suite.db: $!";
62         tie %sources_all, 'DB_File', "$DBDIR/sources_all_$suite.db",
63         O_RDONLY, 0666, $DB_BTREE
64             or die "couldn't tie DB $DBDIR/sources_all_$suite.db: $!";
65
66         unless ($opts->{source}) {
67             read_entry_all( \%packages, $pkg, \@results, \@non_results, $opts );
68         } else {
69             read_src_entry_all( \%sources, $pkg, \@results, \@non_results, $opts );
70         }
71
72         unless (@results || @non_results ) {
73             fatal_error( $cat->g( "No such package.") );
74             #sprintf( _g( '<a href="%s">Search for the package</a>' ), make_search_url('','keywords='.uri_escape($pkg)) ) );
75         } else {
76             my %all_suites;
77             foreach (@results, @non_results) {
78                 my $a = $_->[1];
79                 my $s = $_->[2];
80                 $all_suites{$s}++;
81             }
82             $contents{suites} = [ suites_sort(keys %all_suites) ];
83
84             unless (@results) {
85                 fatal_error( $cat->g( "Package not available in this suite." ) );
86             } else {
87                 $contents{page} = $page;
88                 unless ($opts->{source}) {
89
90                     for my $entry (@results) {
91                         debug( join(":", @$entry), 1 ) if DEBUG;
92                         my (undef, $archive, undef, $arch, $section, $subsection,
93                             $priority, $version, undef, $provided_by) = @$entry;
94                         
95                         if ($arch ne 'virtual') {
96                             my %data = split /\000/, $packages_all{"$pkg $arch $version"};
97                             $data{package} = $pkg;
98                             $data{architecture} = $arch;
99                             $data{version} = $version;
100                             $page->merge_package(\%data)
101                                 or debug( "Merging $pkg $arch $version FAILED", 2 ) if DEBUG;
102                         } else {
103                             $page->add_provided_by([split /\s+/, $provided_by]);
104                         }
105                     }
106
107                     unless ($page->is_virtual()) {
108                         $version = $page->{newest};
109                         $contents{version} = $version;
110                         my $source = $page->get_newest( 'source' );
111                         $archive = $page->get_newest( 'archive' );
112                         $contents{archive} = $archive;
113
114                         debug( "find source package: source=$source", 1) if DEBUG;
115                         my $src_data = $sources_all{"$archive $suite $source"};
116                         #FIXME: should be $main_archive or similar, not hardcoded "us"
117                         $src_data = $sources_all{"us $suite $source"} unless $src_data;
118                         $page->add_src_data( $source, $src_data )
119                             if $src_data;
120
121                         my $st1 = new Benchmark;
122                         my $std = timediff($st1, $st0);
123                         debug( "Data search and merging took ".timestr($std) ) if DEBUG;
124
125                         my @similar = find_similar( $pkg, "$DBDIR/xapian/",
126                                                     \%did2pkg );
127                         $contents{similar} = \@similar;
128
129                         my $did = $page->get_newest( 'description' );
130                         my $desc_md5 = $page->get_newest( 'description-md5' );
131                         my @complete_tags = split(/, /, $page->get_newest( 'tag' )||'' );
132                         my @tags;
133                         foreach (@complete_tags) {
134                             my ($facet, $tag) = split( /::/, $_, 2);
135                             next if $facet =~ /^special/;
136                             next if $tag =~ /^special:/;
137                             push @tags, [ $facet, $tag ];
138                         }
139
140                         $contents{tags} = \@tags;
141                         $contents{debtags_voc} = \%debtags;
142
143                         $section = $page->get_newest( 'section' );
144                         $contents{section} = $section;
145                         $subsection = $page->get_newest( 'subsection' );
146                         $contents{subsection} = $subsection;
147
148                         my $archives = $page->get_arch_field( 'archive' );
149                         my $versions = $page->get_arch_field( 'version' );
150                         my $sizes_inst = $page->get_arch_field( 'installed-size' );
151                         my $sizes_deb = $page->get_arch_field( 'size' );
152                         my @archs = sort $page->get_architectures;
153
154                         # process description
155                         #
156                         sub process_description {
157                             my ($desc) = @_;
158
159                             my $short_desc = encode_entities( $1, "<>&\"" )
160                                 if $desc =~ s/^(.*)$//m;
161                             my $long_desc = encode_entities( $desc, "<>&\"" );
162
163                             $long_desc =~ s,((ftp|http|https)://[\S~-]+?/?)((\&gt\;)?[)]?[']?[:.\,]?(\s|$)),<a href=\"$1\">$1</a>$3,go; # syntax highlighting -> '];
164                             $long_desc =~ s/\A //o;
165                             $long_desc =~ s/\n /\n/sgo;
166                             $long_desc =~ s/\n.\n/\n<p>\n/go;
167                             $long_desc =~ s/(((\n|\A) [^\n]*)+)/\n<pre>$1\n<\/pre>/sgo;
168
169                             return ($short_desc, $long_desc);
170                         }
171
172                         my $desc = $descriptions{$did};
173                         my $long_desc;
174                         ($short_desc, $long_desc) = process_description($desc);
175
176                         $contents{desc}{en} = { short => $short_desc,
177                                                 long => $long_desc, };
178
179                         debug( "desc_md5=$desc_md5", 2)
180                             if DEBUG;
181                         my $trans_desc = $desctrans{$desc_md5};
182                         if ($trans_desc) {
183                             my %trans_desc = split /\000|\001/, $trans_desc;
184                             my %all_langs = map { $_ => 1 } (@LANGUAGES, keys %trans_desc);
185                             $contents{used_langs} = [ keys %all_langs ];
186                             debug( "TRANSLATIONS: ".join(" ",keys %trans_desc), 2)
187                                 if DEBUG;
188                             while (my ($l, $d) = each %trans_desc) {
189                                 my ($short_t, $long_t) = process_description($d);
190
191                                 $contents{desc}{$l} = { short => $short_t,
192                                                         long => $long_t, };
193                             }
194                         }
195
196                         my $v_str = $version;
197                         my $multiple_versions = grep { $_ ne $version } values %$versions;
198                         $v_str .= $cat->g(" and others") if $multiple_versions;
199                         $contents{versions} = { short => $v_str,
200                                                 multiple => $multiple_versions };
201
202                         my $provided_by = $page->{provided_by};
203                         $contents{providers} = [];
204                         pkg_list( \%packages, $opts, $provided_by, $contents{providers} ) if $provided_by;
205
206                         #
207                         # display dependencies
208                         #
209                         build_deps( \%packages, $opts, $pkg,
210                                     $page->get_dep_field('pre-depends'),
211                                     'depends', \%contents );
212                         build_deps( \%packages, $opts, $pkg,
213                                     $page->get_dep_field('depends'),
214                                     'depends', \%contents );
215                         build_deps( \%packages, $opts, $pkg,
216                                     $page->get_dep_field('recommends'),
217                                     'recommends', \%contents );
218                         build_deps( \%packages, $opts, $pkg,
219                                     $page->get_dep_field('suggests'),
220                                     'suggests', \%contents );
221
222                         #
223                         # Download package
224                         #
225                         my @downloads;
226                         foreach my $a ( @archs ) {
227                             my %d = ( arch => $a,
228                                       pkgsize => floor(($sizes_deb->{$a}/102.4)+0.5)/10,
229                                       instsize => $sizes_inst->{$a}, );
230
231                             $d{version} = $versions->{$a} if $multiple_versions;
232                             $d{archive} = $archives->{$a};
233                             if ( ($suite ne "woody") && ($suite ne "bo")
234                                  && ($subsection ne 'debian-installer')) {
235                                 $d{contents_avail} = 1;
236                             }
237                             push @downloads, \%d;
238                         }
239                         $contents{downloads} = \@downloads;
240
241                         #
242                         # more information
243                         #
244                         my $changesandcopy = 0;
245                         $changesandcopy = 1 if suites_cmp($suite, "woody") >= 0;
246                         moreinfo( name => $pkg, data => $page, vars => \%contents,
247                                   opts => $opts,
248                                   env => \%FTP_SITES,
249                                   bugreports => 1, sourcedownload => 1,
250                                   changesandcopy => $changesandcopy, maintainers => 1,
251                                   search => 1 );
252                     } else { # unless $page->is_virtual
253                         $contents{is_virtual} = 1;
254                         $contents{desc}{short} = $cat->g( "virtual package" );
255                         $contents{subsection} = 'virtual';
256
257                         my $provided_by = $page->{provided_by};
258                         $contents{providers} = [];
259                         pkg_list( \%packages, $opts, $provided_by, $contents{providers} );
260
261                     } # else (unless $page->is_virtual)
262                 } else { # unless $opts->{source}
263                     $contents{is_source} = 1;
264
265                     for my $entry (@results) {
266                         debug( join(":", @$entry), 1 ) if DEBUG;
267                         my (undef, $archive, undef, $section, $subsection,
268                             $priority, $version) = @$entry;
269
270                         my $data = $sources_all{"$archive $suite $pkg"};
271                         $page->merge_data($pkg, $suite, $archive, $data)
272                             or debug( "Merging $pkg $version FAILED", 2 ) if DEBUG;
273                     }
274                     $version = $page->{version};
275                     $contents{version} = $version;
276
277                     my $st1 = new Benchmark;
278                     my $std = timediff($st1, $st0);
279                     debug( "Data search and merging took ".timestr($std) ) if DEBUG;
280
281                     $archive = $page->get_newest( 'archive' );
282                     $contents{archive} = $archive;
283                     $section = $page->get_newest( 'section' );
284                     $contents{section} = $section;
285                     $subsection = $page->get_newest( 'subsection' );
286                     $contents{subsection} = $subsection;
287
288                     my $binaries = find_binaries( $pkg, $archive, $suite, \%src2bin );
289                     if ($binaries && @$binaries) {
290                         $contents{binaries} = [];
291                         pkg_list( \%packages, $opts, $binaries, $contents{binaries} );
292                     }
293
294                     #
295                     # display dependencies
296                     #
297                     build_deps( \%packages, $opts, $pkg,
298                                 $page->get_dep_field('build-depends'),
299                                 'build-depends', \%contents );
300                     build_deps( \%packages, $opts, $pkg,
301                                 $page->get_dep_field('build-depends-indep'),
302                                 'build-depends-indep', \%contents );
303
304                     #
305                     # Source package download
306                     #
307                     my $source_files = $page->get_src( 'files' );
308                     my $source_dir = $page->get_src( 'directory' );
309
310                     $contents{srcfiles} = [];
311                     foreach( @$source_files ) {
312                         my ($src_file_md5, $src_file_size, $src_file_name)
313                             = split /\s+/, $_;
314                         my $server = $FTP_SITES{lc $archive}
315                             || $FTP_SITES{us};
316                         my $path = "/$source_dir/$src_file_name";
317
318                         push @{$contents{srcfiles}}, { server => $server, path => $path, filename => $src_file_name,
319                                                        size => floor(($src_file_size/102.4)+0.5)/10,
320                                                        md5sum => $src_file_md5 };
321                     }
322
323                     #
324                     # more information
325                     #
326                     my $changesandcopy = 0;
327                     $changesandcopy = 1 if suites_cmp($suite, "woody") >= 0;
328                     moreinfo( name => $pkg, data => $page, vars => \%contents,
329                               opts => $opts,
330                               env => \%FTP_SITES,
331                               bugreports => 1,
332                               changesandcopy => $changesandcopy, maintainers => 1,
333                               search => 1, is_source => 1 );
334
335                 } # else (unless $opts->{source})
336             } # else (unless @results)
337         } # else (unless (@results || @non_results ))
338     }
339
340 #    use Data::Dumper;
341 #    debug( "Final page object:\n".Dumper(\%contents), 3 ) if DEBUG;
342
343     %$page_contents = %contents;
344 }
345
346 sub moreinfo {
347     my %info = @_;
348     
349     my $name = $info{name} or return;
350     my $env = $info{env} or return;
351     my $opts = $info{opts} or return;
352     my $page = $info{data} or return;
353     my $contents = $info{vars} or return;
354     my $is_source = $info{is_source};
355     my $suite = $opts->{suite}[0];
356
357     my $source = $page->get_src( 'package' );
358     my $source_version = $page->get_src( 'version' );
359     my $src_dir = $page->get_src('directory');
360     if ($info{sourcedownload}) {
361         $contents->{src}{url} = make_url($source,'',{source=>'source'});
362         $contents->{src}{pkg} = $source;
363         $contents->{src}{version} = $source_version;
364
365         my @downloads;
366         my $files = $page->get_src( 'files' );
367         if (defined($files) and @$files) {
368             foreach( @$files ) {
369                 my ($src_file_md5, $src_file_size, $src_file_name) = split /\s/o, $_;
370                 my ($server, $path);
371                 $server = $env->{lc $page->get_newest('archive')}||$env->{us};
372                 $path = "/$src_dir/$src_file_name";
373                 push @downloads, { name => $src_file_name, server => $server, path => $path };
374             }
375         }
376         $contents->{src}{downloads} = \@downloads;
377     }
378
379     if ($info{changesandcopy}) {
380         if ( $src_dir ) {
381             (my $src_basename = $source_version) =~ s,^\d+:,,; # strip epoche
382             $src_basename = "${source}_$src_basename";
383             $src_dir =~ s,pool/updates,pool,o;
384
385             $contents->{files}{changelog}{path} = "$src_dir/$src_basename/changelog";
386             $contents->{files}{copyright}{path} = "$src_dir/$src_basename/".( $is_source ? 'copyright' : "$name.copyright" );
387         }
388    }
389
390     if ($info{maintainers}) {
391         my $uploaders = $page->get_src( 'uploaders' );
392         if ($uploaders && @$uploaders) {
393             my @maintainers = map { { name => $_->[0], mail => $_->[1] } } @$uploaders;
394             $contents->{maintainers} = \@maintainers;
395         }
396     }
397
398 }
399
400 sub providers {
401     my ($suite, $entry, $also) = @_;
402     my %tmp = map { $_ => 1 } split /\s/, $entry;
403     my @provided_by = keys %tmp; # weed out duplicates
404     my %out = ( also => $also,
405                 pkgs => \@provided_by );
406     return \%out;
407 }
408
409 sub build_deps {
410     my ( $packages, $opts, $pkg, $relations, $type, $contents) = @_;
411     my %dep_type = ('depends' => 'dep', 'recommends' => 'rec', 
412                     'suggests' => 'sug', 'build-depends' => 'adep',
413                     'build-depends-indep' => 'idep' );
414     my $suite = $opts->{suite}[0];
415     my $cat = $opts->{cat};
416
417     my %out = ( id => $dep_type{$type}, terms => [] );
418
419 #    use Data::Dumper;
420 #    debug( "print_deps called:\n".Dumper( $pkg, $relations, \$type ), 3 ) if DEBUG;
421
422     foreach my $rel (@$relations) {
423         my %rel_out;
424         $rel_out{is_old_pkgs} = $rel->[0];
425         $rel_out{alternatives} = [];
426
427         foreach my $rel_alt ( @$rel ) {
428             next unless ref($rel_alt);
429             my ( $p_name, $pkg_version, $arch_neg,
430                  $arch_str, $subsection, $available ) = @$rel_alt;
431
432             if ($arch_str ||= '') {
433                 if ($arch_neg) {
434                     $arch_str = $cat->g("not %s", "$arch_str" );
435                 } else {
436                     $arch_str = $arch_str;
437                 }
438             }
439
440             my %rel_alt_out = ( name => $p_name,
441                                 version => $pkg_version,
442                                 arch_str => $arch_str,
443                                 arch_neg => $arch_neg );
444                              
445             my @results;
446             my %entries;
447             my $entry = $entries{$p_name} ||
448                 read_entry_simple( $packages, $p_name, $opts->{h_archives}, $suite);
449             my $short_desc = $entry->[-1];
450             my $desc_md5 = $entry->[-2] || '';
451             my $arch = $entry->[3];
452             my $archive = $entry->[1];
453             my $p_suite = $entry->[2];
454             if ( $short_desc ) {
455                 $rel_alt_out{desc} = $short_desc;
456                 my $trans_desc = $desctrans{$desc_md5};
457                 if ($trans_desc) {
458                     my %trans_desc = split /\000|\001/, $trans_desc;
459                     my %sdescs;
460                     while (my ($l, $d) = each %trans_desc) {
461                         $d =~ s/\n.*//os;
462
463                         $sdescs{$l} = $d;
464                     }
465                     $rel_alt_out{trans_desc} = \%sdescs;
466                 }
467                 $rel_alt_out{suite} = $p_suite;
468                 if ( $rel_out{is_old_pkgs} ) {
469                 } elsif (defined $entry->[1]) {
470                     $entries{$p_name} ||= $entry;
471                     $rel_alt_out{providers} = providers( $p_suite,
472                                                         $entry->[0],
473                                                         1 ) if defined $entry->[0];
474                 } elsif (defined $entry->[0]) {
475                     $rel_alt_out{desc} = undef;
476                     $rel_alt_out{providers} = providers( $p_suite,
477                                                         $entry->[0] );
478                     #FIXME: we don't handle virtual packages from
479                     # the fallback suite correctly here
480                     $rel_alt_out{suite} = $suite;
481                 }
482             } elsif ( $rel_out{is_old_pkgs} ) {
483             } else {
484                 $rel_alt_out{desc} = $cat->g( "Package not available" );
485                 $rel_alt_out{suite} = '';
486             }
487             push @{$rel_out{alternatives}}, \%rel_alt_out;
488         }
489
490         push @{$out{terms}}, \%rel_out;
491     }
492
493     $contents->{relations} ||= [];
494     push @{$contents->{relations}}, \%out if @{$out{terms}};
495 } # end print_deps
496
497 sub pkg_list {
498     my ( $packages, $opts, $pkgs, $list ) = @_;
499     my $suite = $opts->{suite}[0];
500
501     foreach my $p ( sort @$pkgs ) {
502
503         # we don't deal with virtual packages here because for the
504         # current uses of this function this isn't needed
505         my $data = read_entry_simple( $packages, $p, $opts->{h_archives}, $suite);
506         my ($desc_md5, $short_desc) = ($data->[-2],$data->[-1]);
507
508         if ( $short_desc ) {
509             my $trans_desc = $desctrans{$desc_md5};
510             my %sdescs;
511             if ($trans_desc) {
512                 my %trans_desc = split /\000|\001/, $trans_desc;
513                 while (my ($l, $d) = each %trans_desc) {
514                     $d =~ s/\n.*//os;
515
516                     $sdescs{$l} = $d;
517                 }
518             }
519             push @$list, { name => $p, desc => $short_desc,
520                            trans_desc => \%sdescs, available => 1 };
521         } else {
522             push @$list, { name => $p,
523                            desc => $opts->{cat}->g("Not available") };
524         }
525     }
526 }
527
528
529 1;
530