lib/Packages/CGI.pm

   1 package Packages::CGI;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Exporter;
   7
   8 our @ISA = qw( Exporter );
   9 our @EXPORT = qw( DEBUG debug fatal_error get_mime );
  10 our @EXPORT_OK = qw( error hint msg note get_all_messages
  11                      make_url make_search_url );
  12
  13 # define this to 0 in production mode
  14 use constant DEBUG => 1;
  15 our $debug = 0;
  16
  17 my %mime_types = (
  18                   txt => 'text/plain',
  19                   'txt.gz' => 'text/plain',
  20                   html => 'text/html',
  21                   rss => 'application/rss+xml',
  22                   rfc822 => 'text/plain',
  23                   );
  24
  25 sub get_mime {
  26     return $mime_types{$_[0]} || $_[1] || 'text/html';
  27 }
  28
  29 our (@fatal_errors, @errors, @debug, @msgs, @hints, @notes);
  30 our $http_code;
  31
  32 sub reset {
  33     @fatal_errors = @errors = @debug = @msgs = @hints = @notes = ();
  34     $http_code = 200;
  35 }
  36
  37 sub fatal_error {
  38     push @fatal_errors, $_[0];
  39     $http_code = $_[1] if $_[1];
  40 }
  41 sub error {
  42     push @errors, $_[0];
  43 }
  44 sub hint {
  45     push @hints, $_[0];
  46 }
  47 sub debug {
  48     my $lvl = $_[1] || 0;
  49     push(@debug, $_[0]) if $debug > $lvl;
  50 }
  51 sub msg {
  52     push @msgs, $_[0];
  53 }
  54 sub note {
  55     push @notes, [ @_ ];
  56 }
  57 sub get_errors { (@fatal_errors, @errors) }
  58 sub get_debug {
  59     return unless $debug && @debug;
  60     return @debug;
  61 }
  62 sub get_msgs { @msgs };
  63 sub get_hints { @hints };
  64 sub get_notes { @notes };
  65 sub get_all_messages {
  66     return {
  67         errors => [ @fatal_errors, @errors ],
  68         debugs => $debug ? \@debug : [],
  69         msgs => \@msgs,
  70         hints => \@hints,
  71         notes => \@notes,
  72     };
  73 }
  74
  75 our $USE_PAGED_MODE = 1;
  76 use constant DEFAULT_PAGE => 1;
  77 use constant DEFAULT_RES_PER_PAGE => 50;
  78 our %page_params = ( page => { default => DEFAULT_PAGE,
  79                                match => '(\d+)' },
  80                      number => { default => DEFAULT_RES_PER_PAGE,
  81                                  match => '(\d+)' } );
  82
  83 sub parse_params {
  84     my ( $cgi, $params_def, $opts ) = @_;
  85
  86     my %params_ret = ( values => {}, errors => {} );
  87     my %params;
  88     if ($USE_PAGED_MODE) {
  89         debug( "Use PAGED_MODE", 2 ) if DEBUG;
  90         %params = %$params_def;
  91         foreach (keys %page_params) {
  92             delete $params{$_};
  93         }
  94         %params = ( %params, %page_params );
  95     } else {
  96         %params = %$params_def;
  97     }
  98
  99     foreach my $param ( keys %params ) {
 100
 101         debug( "Param <strong>$param</strong>", 2 ) if DEBUG;
 102
 103         my $p_value_orig = $cgi->param($param);
 104
 105         if (!defined($p_value_orig)
 106             && defined $params_def->{$param}{alias}
 107             && defined $cgi->param($params_def->{$param}{alias})) {
 108             $p_value_orig = $cgi->param($params_def->{$param}{alias});
 109             debug( "Used alias <strong>$params_def->{$param}{alias}</strong>",
 110                    2 );
 111         }
 112
 113         my @p_value = ($p_value_orig);
 114
 115         debug( "Value (Orig) ".($p_value_orig||""), 2 ) if DEBUG;
 116
 117         if ($params_def->{$param}{array} && defined $p_value_orig) {
 118             @p_value = split /$params_def->{$param}{array}/, $p_value_orig;
 119             debug( "Value (Array Split) ". join('##',@p_value), 2 ) if DEBUG;
 120         }
 121
 122         if ($params_def->{$param}{match} && defined $p_value_orig) {
 123             @p_value = map
 124             { $_ =~ m/$params_def->{$param}{match}/; $_ = $1 }
 125             @p_value;
 126         }
 127         @p_value = grep { defined $_ } @p_value;
 128
 129         debug( "Value (Match) ". join('##',@p_value), 2 ) if DEBUG;
 130
 131         unless (@p_value) {
 132             if (defined $params{$param}{default}) {
 133                 @p_value = ($params{$param}{default});
 134             } else {
 135                 @p_value = undef;
 136                 $params_ret{errors}{$param} = "undef";
 137                 next;
 138             }
 139         }
 140
 141         debug( "Value (Default) ". join('##',@p_value), 2 ) if DEBUG;
 142         my @p_value_no_replace = @p_value;
 143
 144         if ($params{$param}{replace} && @p_value) {
 145             foreach my $pattern (keys %{$params{$param}{replace}}) {
 146                 my @p_value_tmp = @p_value;
 147                 @p_value = ();
 148                 foreach (@p_value_tmp) {
 149                     if ($_ eq $pattern) {
 150                         my $replacement = $params{$param}{replace}{$_};
 151                         if (ref $replacement) {
 152                             push @p_value, @$replacement;
 153                         } else {
 154                             push @p_value, $replacement;
 155                         }
 156                     } else {
 157                         push @p_value, $_;
 158                     }
 159                 }
 160             }
 161         }
 162
 163         debug( "Value (Final) ". join('##',@p_value), 2 ) if DEBUG;
 164
 165         if ($params_def->{$param}{array}) {
 166             $params_ret{values}{$param} = {
 167                 orig => $p_value_orig,
 168                 no_replace => \@p_value_no_replace,
 169                 final => \@p_value,
 170             };
 171             @{$params_def->{$param}{var}} = @p_value
 172                 if $params_def->{$param}{var};
 173         } else {
 174             $params_ret{values}{$param} = {
 175                 orig => $p_value_orig,
 176                 no_replace => $p_value_no_replace[0],
 177                 final => $p_value[0],
 178             };
 179             ${$params_def->{$param}{var}} = $p_value[0]
 180                 if $params_def->{$param}{var};
 181         }
 182         $opts->{$param} = $params_ret{values}{$param}{final} if $opts;
 183     }
 184
 185     if ($USE_PAGED_MODE) {
 186         $cgi->delete( "page" );
 187         $cgi->delete( "number" );
 188     }
 189
 190     return %params_ret;
 191 }
 192
 193 sub start {
 194     my $params = shift;
 195
 196     my $page = $params->{values}{page}{final}
 197     || DEFAULT_PAGE;
 198     my $res_per_page = $params->{values}{number}{final}
 199     || DEFAULT_RES_PER_PAGE;
 200
 201     return 1 if $res_per_page =~ /^all$/i;
 202     return $res_per_page * ($page - 1) + 1;
 203 }
 204
 205 sub end {
 206     my $params = shift;
 207
 208     use Data::Dumper;
 209     debug( "end: ".Dumper($params) ) if DEBUG;
 210     my $page = $params->{page}
 211     || DEFAULT_PAGE;
 212     my $res_per_page = $params->{number}
 213     || DEFAULT_RES_PER_PAGE;
 214
 215     return $page * $res_per_page;
 216 }
 217
 218 sub indexline {
 219     my ($cgi, $params, $num_res) = @_;
 220
 221     my $index_line = "";
 222     my $page = $params->{page}
 223     || DEFAULT_PAGE;
 224     my $res_per_page = $params->{number}
 225     || DEFAULT_RES_PER_PAGE;
 226     my $numpages = ceil($num_res /
 227                         $res_per_page);
 228     for (my $i = 1; $i <= $numpages; $i++) {
 229         if ($i == $page) {
 230             $index_line .= $i;
 231         } else {
 232             $index_line .= "<a href=\"".encode_entities($cgi->self_url).
 233                 "&amp;page=$i&amp;number=$res_per_page\">".
 234                 "$i</a>";
 235         }
 236         if ($i < $numpages) {
 237            $index_line .= " | ";
 238         }
 239     }
 240     return $index_line;
 241 }
 242
 243 sub nextlink {
 244     my ($cgi, $params, $no_results ) = @_;
 245
 246     my $page = $params->{page}
 247     || DEFAULT_PAGE;
 248     $page++;
 249     my $res_per_page = $params->{number}
 250     || DEFAULT_RES_PER_PAGE;
 251
 252     if ((($page-1)*$res_per_page + 1) > $no_results) {
 253         return "&gt;&gt;";
 254     }
 255
 256     return "<a href=\"".encode_entities($cgi->self_url).
 257         "&amp;page=$page&amp;number=$res_per_page\">&gt;&gt;</a>";
 258 }
 259
 260 sub prevlink {
 261     my ($cgi, $params ) = @_;
 262
 263     my $page = $params->{page}
 264     || DEFAULT_PAGE;
 265     $page--;
 266     if (!$page) {
 267         return "&lt;&lt;";
 268     }
 269
 270     my $res_per_page = $params->{number}
 271     || DEFAULT_RES_PER_PAGE;
 272
 273     return "<a href=\"".encode_entities($cgi->self_url).
 274         "&amp;page=$page&amp;number=$res_per_page\">&lt;&lt;</a>";
 275 }
 276
 277 sub resperpagelink {
 278     my ($cgi, $params, $res_per_page ) = @_;
 279
 280     my $page;
 281     if ($res_per_page =~ /^all$/i) {
 282         $page = 1;
 283     } else {
 284         $page = ceil(start( $params ) / $res_per_page);
 285     }
 286
 287     return "<a href=\"".encode_entities($cgi->self_url).
 288         "&amp;page=$page&amp;number=$res_per_page\">$res_per_page</a>";
 289 }
 290
 291 sub printindexline {
 292     my ( $input, $no_results, $opts ) = @_;
 293
 294     my $index_line;
 295     if ($no_results > $opts->{number}) {
 296
 297         $index_line = prevlink( $input, $opts)." | ".
 298             indexline( $input, $opts, $no_results)." | ".
 299             nextlink( $input, $opts, $no_results);
 300
 301         print "<p style=\"text-align:center\">$index_line</p>";
 302     }
 303 }
 304
 305 #sub multipageheader {
 306 #    my ( $input, $no_results, $opts ) = @_;
 307 #
 308 #    my ($start, $end);
 309 #    if ($opts->{number} =~ /^all$/i) {
 310 #       $start = 1;
 311 #       $end = $no_results;
 312 #       $opts->{number} = $no_results;
 313 #       $opts->{number_all}++;
 314 #    } else {
 315 #       $start = Packages::Search::start( $opts );
 316 #       $end = Packages::Search::end( $opts );
 317 #       if ($end > $no_results) { $end = $no_results; }
 318 #    }
 319 #
 320 #       print "<p>Found <em>$no_results</em> matching packages,";
 321 #    if ($end == $start) {
 322 #       print " displaying package $end.</p>";
 323 #    } else {
 324 #       print " displaying packages $start to $end.</p>";
 325 #    }
 326 #
 327 #    printindexline( $input, $no_results, $opts );
 328 #
 329 #    if ($no_results > 100) {
 330 #       print "<p>Results per page: ";
 331 #       my @resperpagelinks;
 332 #       for (50, 100, 200) {
 333 #           if ($opts->{number} == $_) {
 334 #               push @resperpagelinks, $_;
 335 #           } else {
 336 #               push @resperpagelinks, resperpagelink($input,$opts,$_);
 337 #           }
 338 #       }
 339 #       if ($opts->{number_all}) {
 340 #           push @resperpagelinks, "all";
 341 #       } else {
 342 #           push @resperpagelinks, resperpagelink($input, $opts, "all");
 343 #       }
 344 #       print join( " | ", @resperpagelinks )."</p>";
 345 #    }
 346 #    return ( $start, $end );
 347 #}
 348
 349 sub string2id {
 350     my $string = "@_";
 351
 352     $string =~ s/[^\w:.-]/_/g;
 353     return $string;
 354 }
 355
 356 our ( %url_params, %query_params );
 357
 358 sub init_url {
 359     my ($input, $params, $opts) = @_;
 360
 361     %url_params = ();
 362     %query_params = ();
 363
 364     if ($params->{values}{lang}{orig} &&
 365         (my $l = $params->{values}{lang}{no_replace})) {
 366         $url_params{lang} = $l;
 367     }
 368     if ($params->{values}{source}{no_replace}) {
 369         $url_params{source} = 'source';
 370         $query_params{source} = 1;
 371     }
 372     foreach my $p (qw(suite arch)) {
 373         if ($params->{values}{$p}{orig}
 374             && (ref $params->{values}{$p}{final} eq 'ARRAY')
 375             && @{$params->{values}{$p}{final}}) {
 376             if (@{$params->{values}{$p}{final}} == 1) {
 377                 $url_params{$p} = $params->{values}{$p}{final}[0];
 378             } else {
 379                 $url_params{$p} =
 380                     join(",",@{$params->{values}{$p}{no_replace}});
 381             }
 382         }
 383     }
 384     foreach my $p (qw(format searchon mode exact debug)) {
 385         if ($params->{values}{$p}{orig}
 386             && (my $pv = $params->{values}{$p}{no_replace})) {
 387             $url_params{$p} = $pv;
 388         }
 389     }
 390
 391     use Data::Dumper;
 392     debug( join("\n",Dumper(\%url_params,\%query_params)), 2 ) if DEBUG;
 393 }
 394
 395 sub make_url {
 396     my ($add_path, $add_query, @override) = @_;
 397     my (@path, @query_string) = ()x2;
 398     my $override = {};
 399     if (ref $override[0]) {
 400         $override = $override[0];
 401     } elsif (@override) {
 402         $override = { @override };
 403     }
 404
 405     push @path, $Packages::Config::ROOT;
 406     foreach my $p (qw(lang source suite archive arch)) {
 407         my $val = $url_params{$p};
 408         $val = $override->{$p} if exists $override->{$p};
 409         push @path, $val if $val;
 410     }
 411     foreach my $p (qw(format debug)) {
 412         my $val = $url_params{$p};
 413         $val = $query_params{$p} if exists $query_params{$p};
 414         $val = $override->{$p} if exists $override->{$p};
 415         push @query_string, "$p=$val" if $val;
 416     }
 417     push @path, $add_path if $add_path and $add_path ne '/';
 418     push @query_string, $add_query if $add_query;
 419
 420     my $path = join( '/', @path );
 421     my $query_string = join( '&', @query_string );
 422     $path .= '/' if $add_path and $add_path eq '/';
 423     $path .= "?$query_string" if $query_string;
 424
 425     return $path;
 426 }
 427
 428 sub make_search_url {
 429     my ($add_path, $add_query, @override) = @_;
 430     my (@path, @query_string) = ()x2;
 431     my $override ||= {};
 432     if (ref $override[0]) {
 433         $override = $override[0];
 434     } elsif (@override) {
 435         $override = { @override };
 436     }
 437
 438     push @path, $Packages::Config::SEARCH_URL
 439         if $Packages::Config::SEARCH_URL;
 440     foreach my $p (qw(lang source suite archive section subsection
 441                       arch exact mode searchon format debug)) {
 442         my $val = $url_params{$p};
 443         $val = $query_params{$p} if exists $query_params{$p};
 444         $val = $override->{$p} if exists $override->{$p};
 445         push @query_string, "$p=$val" if $val;
 446     }
 447     push @path, $add_path if $add_path;
 448     push @query_string, $add_query if $add_query;
 449
 450     my $path = join( '/', @path );
 451     my $query_string = join( '&amp;', @query_string );
 452
 453     return "$path?$query_string";
 454 }
 455
 456 1;