]> git.deb.at Git - deb/packages.git/blob - cgi-bin/dispatcher.pl
e776a83086c7293205f6df2013a9da74c770a370
[deb/packages.git] / cgi-bin / dispatcher.pl
1 #!/usr/bin/perl -T
2 # $Id: search_packages.pl 91 2006-02-10 22:18:31Z jeroen $
3 # dispatcher.pl -- CGI interface for packages.debian.org
4 #
5 # Copyright (C) 2004-2006 Frank Lichtenheld
6 #
7 # use is allowed under the terms of the GNU Public License (GPL)                              
8 # see http://www.fsf.org/copyleft/gpl.html for a copy of the license
9
10 use strict;
11 use warnings;
12
13 use lib '../lib';
14 use CGI;
15 use POSIX;
16 use URI::Escape;
17 use HTML::Entities;
18 use DB_File;
19 use Benchmark ':hireswallclock';
20 use I18N::AcceptLanguage;
21 use Locale::gettext;
22
23 use Deb::Versions;
24 use Packages::Config qw( $DBDIR $ROOT @SUITES @SECTIONS @ARCHIVES @ARCHITECTURES @LANGUAGES $LOCALES );
25 use Packages::CGI;
26 use Packages::DB;
27 use Packages::Search qw( :all );
28 use Packages::HTML ();
29 use Packages::Sections;
30 use Packages::I18N::Locale;
31
32 use Packages::DoSearch;
33 use Packages::DoSearchContents;
34 use Packages::DoShow;
35 use Packages::DoIndex;
36 use Packages::DoDownload;
37 use Packages::DoFilelist;
38
39 &Packages::CGI::reset;
40
41 # clean up env
42 $ENV{PATH} = "/bin:/usr/bin";
43 delete $ENV{'LANGUAGE'};
44 delete $ENV{'LANG'};
45 delete $ENV{'LC_ALL'};
46 delete $ENV{'LC_MESSAGES'};
47
48 # Read in all the variables set by the form
49 my $input;
50 if ($ARGV[0] && ($ARGV[0] eq 'php')) {
51         $input = new CGI(\*STDIN);
52 } else {
53         $input = new CGI;
54 }
55
56 my $pet0 = new Benchmark;
57 my $tet0 = new Benchmark;
58 my $debug = DEBUG && $input->param("debug");
59 $debug = 0 if !defined($debug) || $debug !~ /^\d+$/o;
60 $Packages::CGI::debug = $debug;
61
62 &Packages::Config::init( '../' );
63 &Packages::DB::init();
64
65 my $acc = I18N::AcceptLanguage->new();
66 my $http_lang = $acc->accepts( $input->http("Accept-Language"),
67                                \@LANGUAGES );
68 debug( "LANGUAGES=@LANGUAGES header=".
69        $input->http("Accept-Language").
70        " http_lang=$http_lang", 2 );
71 bindtextdomain ( 'pdo', $LOCALES );
72 textdomain( 'pdo' );
73
74 my $what_to_do = 'show';
75 my $source = 0;
76 if (my $path = $input->path_info() || $input->param('PATH_INFO')) {
77     my @components = grep { $_ } map { lc $_ } split /\/+/, $path;
78
79     push @components, 'index' if $path =~ m,/$,;
80
81     debug( "components[0]=$components[0]", 2 ) if DEBUG and @components>0;
82     if (@components > 0 and $components[0] eq 'source') {
83         shift @components;
84         $input->param( 'source', 1 );
85     }
86     if (@components > 0 and $components[0] eq 'search') {
87         shift @components;
88         $what_to_do = 'search';
89         # Done
90         fatal_error( _g( "search doesn't take any more path elements" ) )
91             if @components;
92     } elsif (@components == 0) {
93         fatal_error( _g( "We're supposed to display the homepage here, instead of getting dispatch.pl" ) );
94     } elsif (@components == 1) {
95         $what_to_do = 'search';
96     } else {
97
98         for ($components[-1]) {
99             /^(index|changelog|copyright|download|filelist)$/ && do {
100                 pop @components;
101                 $what_to_do = $1;
102                 last;
103             };
104         }
105
106         my %SUITES = map { $_ => 1 } @SUITES;
107         my %SUITES_ALIAS = ( woody => 'oldstable',
108                              sarge => 'stable',
109                              etch => 'testing',
110                              sid => 'unstable', );
111         my %SECTIONS = map { $_ => 1 } @SECTIONS;
112         my %ARCHIVES = map { $_ => 1 } @ARCHIVES;
113         my %ARCHITECTURES = map { $_ => 1 } (@ARCHITECTURES, 'all');
114         my %params_set;
115         sub set_param_once {
116             my ($cgi, $params_set, $key, $val) = @_;
117             if ($params_set->{$key}++) {
118                 fatal_error( sprintf( _g( "%s set more than once in path" ), $key ) );
119             } else {
120                 $cgi->param( $key, $val );
121             }
122         }
123
124         my @tmp;
125         foreach (@components) {
126             if ($SUITES{$_}) {
127                 set_param_once( $input, \%params_set, 'suite', $_);
128 #possible conflicts with package names
129 #           } elsif (my $s = $SUITES_ALIAS{$_}) {
130 #               set_param_once( $input, \%params_set, 'suite', $s);
131             } elsif ($SECTIONS{$_}) {
132                 set_param_once( $input, \%params_set, 'section', $_);
133             } elsif ($ARCHIVES{$_}) {
134                 set_param_once( $input, \%params_set, 'archive', $_);
135             } elsif ($ARCHITECTURES{$_}) {
136                 set_param_once( $input, \%params_set, 'arch', $_);
137             } elsif ($sections_descs{$_}) {
138                 set_param_once( $input, \%params_set, 'subsection', $_);
139             } elsif ($_ eq 'source') {
140                 set_param_once( $input, \%params_set, 'source', 1);
141             } else {
142                 push @tmp, $_;
143             }
144         }
145         @components = @tmp;
146
147         if (@components > 1) {
148             fatal_error( sprintf( _g( "two or more packages specified (%s)" ), "@components" ) );
149         }
150     } # else if (@components == 1)
151     
152     if (@components) {
153         $input->param( 'keywords', $components[0] );
154         $input->param( 'package', $components[0] );
155     }
156 }
157
158 my ( $pkg, @suites, @sections, @subsections, @archives, @archs );
159
160 my %params_def = ( keywords => { default => undef,
161                                  match => '^\s*([-+\@\s\w\/.:]+)\s*$',
162                              },
163                    package => { default => undef,
164                                 match => '^([\w.+-]+)$',
165                                 var => \$pkg },
166                    suite => { default => 'all', match => '^([\w-]+)$',
167                               array => ',', var => \@suites,
168                               replace => { all => \@SUITES } },
169                    archive => { default => ($what_to_do eq 'search') ?
170                                     'all' : 'default',
171                                     match => '^([\w-]+)$',
172                                     array => ',', var => \@archives,
173                                     replace => { all => \@ARCHIVES,
174                                                  default => [qw(us security non-US)]} },
175                    exact => { default => 0, match => '^(\w+)$',  },
176                    lang => { default => $http_lang, match => '^(\w+)$',  },
177                    source => { default => 0, match => '^(\d+)$',  },
178                    searchon => { default => 'names', match => '^(\w+)$', },
179                    section => { default => 'all', match => '^([\w-]+)$',
180                                 alias => 'release', array => ',',
181                                 var => \@sections,
182                                 replace => { all => \@SECTIONS } },
183                    subsection => { default => 'default', match => '^([\w-]+)$',
184                                    array => ',', var => \@subsections,
185                                    replace => { default => [] } },
186                    arch => { default => 'any', match => '^([\w-]+)$',
187                              array => ',', var => \@archs, replace =>
188                              { any => \@ARCHITECTURES } },
189                    );
190 my %opts;
191 my %params = Packages::Search::parse_params( $input, \%params_def, \%opts );
192
193 my $locale = get_locale($opts{lang});
194 my $charset = get_charset($opts{lang});
195 setlocale ( LC_ALL, $locale )
196     or do { debug( "couldn't set locale $locale, using default" ) if DEBUG;
197             setlocale( LC_ALL, get_locale() )
198                 or do {
199                     debug( "couldn't set default locale either" ) if DEBUG;
200                     setlocale( LC_ALL, "C" );
201                 };
202         };
203 debug( "locale=$locale charset=$charset", 2 ) if DEBUG;
204
205 $opts{h_suites} = { map { $_ => 1 } @suites };
206 $opts{h_sections} = { map { $_ => 1 } @sections };
207 $opts{h_archives} = { map { $_ => 1 } @archives };
208 $opts{h_archs} = { map { $_ => 1 } @archs };
209
210 if ((($opts{searchon} eq 'names') && $opts{source}) ||
211     ($opts{searchon} eq 'sourcenames')) {
212     $opts{source} = 1;
213     $opts{searchon} = 'names',
214     $opts{searchon_form} = 'sourcenames';
215 } else {
216     $opts{searchon_form} = $opts{searchon};
217 }
218 if ($opts{searchon} eq 'contents' or $opts{searchon} eq 'filenames') {
219     $what_to_do = 'search_contents';
220 }
221
222 my $pet1 = new Benchmark;
223 my $petd = timediff($pet1, $pet0);
224 debug( "Parameter evaluation took ".timestr($petd) ) if DEBUG;
225
226 my (%html_header, $menu, $page_content);
227 unless (@Packages::CGI::fatal_errors) {
228     no strict 'refs';
229     &{"do_$what_to_do"}( \%params, \%opts, \%html_header,
230                          \$menu, \$page_content );
231 } else {
232     %html_header = ( title => _g('Error'),
233                      lang => $opts{lang},
234                      print_title => 1,
235                      print_search_field => 'packages',
236                      search_field_values => { 
237                          keywords => _g('search for a package'),
238                          searchon => 'default',
239                          arch => 'any',
240                          suite => 'all',
241                          section => 'all',
242                          exact => 1,
243                          debug => $debug,
244                      },
245                      );
246 }
247
248 print $input->header( -charset => $charset );
249
250 print Packages::HTML::header( %html_header );
251
252 print $menu||'';
253 print_errors();
254 print_hints();
255 print_msgs();
256 print_debug() if DEBUG;
257 print_notes();
258
259 unless (@Packages::CGI::fatal_errors) {
260     print $page_content;
261 }
262
263 my $tet1 = new Benchmark;
264 my $tetd = timediff($tet1, $tet0);
265 print "Total page evaluation took ".timestr($tetd)."<br>"
266     if DEBUG;
267
268 my $trailer = Packages::HTML::trailer( $ROOT );
269 $trailer =~ s/LAST_MODIFIED_DATE/gmtime()/e; #FIXME
270 print $trailer;
271
272 # vim: ts=8 sw=4
273