lib/Packages/CGI.pm

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