]> git.deb.at Git - deb/packages.git/blob - lib/Packages/DoShow.pm
[ARCHIVE] I don't extract changelogs, yet
[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                         moreinfo( name => $pkg, data => $page, vars => \%contents,
245                                   opts => $opts,
246                                   env => \%FTP_SITES,
247                                   bugreports => 1, sourcedownload => 1,
248                                   changesandcopy => 0, maintainers => 1,
249                                   search => 1 );
250                     } else { # unless $page->is_virtual
251                         $contents{is_virtual} = 1;
252                         $contents{desc}{short} = $cat->g( "virtual package" );
253                         $contents{subsection} = 'virtual';
254
255                         my $provided_by = $page->{provided_by};
256                         $contents{providers} = [];
257                         pkg_list( \%packages, $opts, $provided_by, $contents{providers} );
258
259                     } # else (unless $page->is_virtual)
260                 } else { # unless $opts->{source}
261                     $contents{is_source} = 1;
262
263                     for my $entry (@results) {
264                         debug( join(":", @$entry), 1 ) if DEBUG;
265                         my (undef, $archive, undef, $section, $subsection,
266                             $priority, $version) = @$entry;
267
268                         my $data = $sources_all{"$archive $suite $pkg"};
269                         $page->merge_data($pkg, $suite, $archive, $data)
270                             or debug( "Merging $pkg $version FAILED", 2 ) if DEBUG;
271                     }
272                     $version = $page->{version};
273                     $contents{version} = $version;
274
275                     my $st1 = new Benchmark;
276                     my $std = timediff($st1, $st0);
277                     debug( "Data search and merging took ".timestr($std) ) if DEBUG;
278
279                     $archive = $page->get_newest( 'archive' );
280                     $contents{archive} = $archive;
281                     $section = $page->get_newest( 'section' );
282                     $contents{section} = $section;
283                     $subsection = $page->get_newest( 'subsection' );
284                     $contents{subsection} = $subsection;
285
286                     my $binaries = find_binaries( $pkg, $archive, $suite, \%src2bin );
287                     if ($binaries && @$binaries) {
288                         $contents{binaries} = [];
289                         pkg_list( \%packages, $opts, $binaries, $contents{binaries} );
290                     }
291
292                     #
293                     # display dependencies
294                     #
295                     build_deps( \%packages, $opts, $pkg,
296                                 $page->get_dep_field('build-depends'),
297                                 'build-depends', \%contents );
298                     build_deps( \%packages, $opts, $pkg,
299                                 $page->get_dep_field('build-depends-indep'),
300                                 'build-depends-indep', \%contents );
301
302                     #
303                     # Source package download
304                     #
305                     my $source_files = $page->get_src( 'files' );
306                     my $source_dir = $page->get_src( 'directory' );
307
308                     $contents{srcfiles} = [];
309                     foreach( @$source_files ) {
310                         my ($src_file_md5, $src_file_size, $src_file_name)
311                             = split /\s+/, $_;
312                         my $server = $FTP_SITES{lc $archive}
313                             || $FTP_SITES{us};
314                         my $path = "/$source_dir/$src_file_name";
315
316                         push @{$contents{srcfiles}}, { server => $server, path => $path, filename => $src_file_name,
317                                                        size => floor(($src_file_size/102.4)+0.5)/10,
318                                                        md5sum => $src_file_md5 };
319                     }
320
321                     #
322                     # more information
323                     #
324                     moreinfo( name => $pkg, data => $page, vars => \%contents,
325                               opts => $opts,
326                               env => \%FTP_SITES,
327                               bugreports => 1,
328                               changesandcopy => 0, maintainers => 1,
329                               search => 1, is_source => 1 );
330
331                 } # else (unless $opts->{source})
332             } # else (unless @results)
333         } # else (unless (@results || @non_results ))
334     }
335
336 #    use Data::Dumper;
337 #    debug( "Final page object:\n".Dumper(\%contents), 3 ) if DEBUG;
338
339     %$page_contents = %contents;
340 }
341
342 sub moreinfo {
343     my %info = @_;
344     
345     my $name = $info{name} or return;
346     my $env = $info{env} or return;
347     my $opts = $info{opts} or return;
348     my $page = $info{data} or return;
349     my $contents = $info{vars} or return;
350     my $is_source = $info{is_source};
351     my $suite = $opts->{suite}[0];
352
353     my $source = $page->get_src( 'package' );
354     my $source_version = $page->get_src( 'version' );
355     my $src_dir = $page->get_src('directory');
356     if ($info{sourcedownload}) {
357         $contents->{src}{url} = make_url($source,'',{source=>'source'});
358         $contents->{src}{pkg} = $source;
359
360         my @downloads;
361         my $files = $page->get_src( 'files' );
362         if (defined($files) and @$files) {
363             foreach( @$files ) {
364                 my ($src_file_md5, $src_file_size, $src_file_name) = split /\s/o, $_;
365                 my ($server, $path);
366                 $server = $env->{lc $page->get_newest('archive')}||$env->{us};
367                 $path = "/$src_dir/$src_file_name";
368                 push @downloads, { name => $src_file_name, server => $server, path => $path };
369             }
370         }
371         $contents->{src}{downloads} = \@downloads;
372     }
373
374     if ($info{changesandcopy}) {
375         if ( $src_dir ) {
376             (my $src_basename = $source_version) =~ s,^\d+:,,; # strip epoche
377             $src_basename = "${source}_$src_basename";
378             $src_dir =~ s,pool/updates,pool,o;
379
380             $contents->{files}{changelog}{path} = "$src_dir/$src_basename/changelog";
381             $contents->{files}{copyright}{path} = "$src_dir/$src_basename/".( $is_source ? 'copyright' : "$name.copyright" );
382         }
383    }
384
385     if ($info{maintainers}) {
386         my $uploaders = $page->get_src( 'uploaders' );
387         if ($uploaders && @$uploaders) {
388             my @maintainers = map { { name => $_->[0], mail => $_->[1] } } @$uploaders;
389             $contents->{maintainers} = \@maintainers;
390         }
391     }
392
393 }
394
395 sub providers {
396     my ($suite, $entry, $also) = @_;
397     my %tmp = map { $_ => 1 } split /\s/, $entry;
398     my @provided_by = keys %tmp; # weed out duplicates
399     my %out = ( also => $also,
400                 pkgs => \@provided_by );
401     return \%out;
402 }
403
404 sub build_deps {
405     my ( $packages, $opts, $pkg, $relations, $type, $contents) = @_;
406     my %dep_type = ('depends' => 'dep', 'recommends' => 'rec', 
407                     'suggests' => 'sug', 'build-depends' => 'adep',
408                     'build-depends-indep' => 'idep' );
409     my $suite = $opts->{suite}[0];
410     my $cat = $opts->{cat};
411
412     my %out = ( id => $dep_type{$type}, terms => [] );
413
414 #    use Data::Dumper;
415 #    debug( "print_deps called:\n".Dumper( $pkg, $relations, \$type ), 3 ) if DEBUG;
416
417     foreach my $rel (@$relations) {
418         my %rel_out;
419         $rel_out{is_old_pkgs} = $rel->[0];
420         $rel_out{alternatives} = [];
421
422         foreach my $rel_alt ( @$rel ) {
423             next unless ref($rel_alt);
424             my ( $p_name, $pkg_version, $arch_neg,
425                  $arch_str, $subsection, $available ) = @$rel_alt;
426
427             if ($arch_str ||= '') {
428                 if ($arch_neg) {
429                     $arch_str = $cat->g("not %s", "$arch_str" );
430                 } else {
431                     $arch_str = $arch_str;
432                 }
433             }
434
435             my %rel_alt_out = ( name => $p_name,
436                                 version => $pkg_version,
437                                 arch_str => $arch_str,
438                                 arch_neg => $arch_neg );
439                              
440             my @results;
441             my %entries;
442             my $entry = $entries{$p_name} ||
443                 read_entry_simple( $packages, $p_name, $opts->{h_archives}, $suite);
444             my $short_desc = $entry->[-1];
445             my $desc_md5 = $entry->[-2] || '';
446             my $arch = $entry->[3];
447             my $archive = $entry->[1];
448             my $p_suite = $entry->[2];
449             if ( $short_desc ) {
450                 $rel_alt_out{desc} = $short_desc;
451                 my $trans_desc = $desctrans{$desc_md5};
452                 if ($trans_desc) {
453                     my %trans_desc = split /\000|\001/, $trans_desc;
454                     my %sdescs;
455                     while (my ($l, $d) = each %trans_desc) {
456                         $d =~ s/\n.*//os;
457
458                         $sdescs{$l} = $d;
459                     }
460                     $rel_alt_out{trans_desc} = \%sdescs;
461                 }
462                 $rel_alt_out{suite} = $p_suite;
463                 if ( $rel_out{is_old_pkgs} ) {
464                 } elsif (defined $entry->[1]) {
465                     $entries{$p_name} ||= $entry;
466                     $rel_alt_out{providers} = providers( $p_suite,
467                                                         $entry->[0],
468                                                         1 ) if defined $entry->[0];
469                 } elsif (defined $entry->[0]) {
470                     $rel_alt_out{desc} = undef;
471                     $rel_alt_out{providers} = providers( $p_suite,
472                                                         $entry->[0] );
473                     #FIXME: we don't handle virtual packages from
474                     # the fallback suite correctly here
475                     $rel_alt_out{suite} = $suite;
476                 }
477             } elsif ( $rel_out{is_old_pkgs} ) {
478             } else {
479                 $rel_alt_out{desc} = $cat->g( "Package not available" );
480                 $rel_alt_out{suite} = '';
481             }
482             push @{$rel_out{alternatives}}, \%rel_alt_out;
483         }
484
485         push @{$out{terms}}, \%rel_out;
486     }
487
488     $contents->{relations} ||= [];
489     push @{$contents->{relations}}, \%out if @{$out{terms}};
490 } # end print_deps
491
492 sub pkg_list {
493     my ( $packages, $opts, $pkgs, $list ) = @_;
494     my $suite = $opts->{suite}[0];
495
496     foreach my $p ( sort @$pkgs ) {
497
498         # we don't deal with virtual packages here because for the
499         # current uses of this function this isn't needed
500         my $data = read_entry_simple( $packages, $p, $opts->{h_archives}, $suite);
501         my ($desc_md5, $short_desc) = ($data->[-2],$data->[-1]);
502
503         if ( $short_desc ) {
504             my $trans_desc = $desctrans{$desc_md5};
505             my %sdescs;
506             if ($trans_desc) {
507                 my %trans_desc = split /\000|\001/, $trans_desc;
508                 while (my ($l, $d) = each %trans_desc) {
509                     $d =~ s/\n.*//os;
510
511                     $sdescs{$l} = $d;
512                 }
513             }
514             push @$list, { name => $p, desc => $short_desc,
515                            trans_desc => \%sdescs, available => 1 };
516         } else {
517             push @$list, { name => $p,
518                            desc => $opts->{cat}->g("Not available") };
519         }
520     }
521 }
522
523
524 1;
525