root/lang/perl/MENTA/branches/henta/extlib/CGI/Simple.pm @ 26170

Revision 26170, 41.1 kB (checked in by tokuhirom, 4 years ago)

remove pods

Line 
1package CGI::Simple;
2
3require 5.004;
4
5# this module is both strict (and warnings) compliant, but they are only used
6# in testing as they add an unnecessary compile time overhead in production.
7use strict;
8use warnings;
9use Carp;
10
11use vars qw(
12 $VERSION $USE_CGI_PM_DEFAULTS $DISABLE_UPLOADS $POST_MAX
13 $NO_UNDEF_PARAMS $USE_PARAM_SEMICOLONS $PARAM_UTF8 $HEADERS_ONCE
14 $NPH $DEBUG $NO_NULL $FATAL *in
15);
16
17$VERSION = "1.106";
18
19# you can hard code the global variable settings here if you want.
20# warning - do not delete the unless defined $VAR part unless you
21# want to permanently remove the ability to change the variable.
22sub _initialize_globals {
23
24  # set this to 1 to use CGI.pm default global settings
25  $USE_CGI_PM_DEFAULTS = 0
26   unless defined $USE_CGI_PM_DEFAULTS;
27
28  # see if user wants old CGI.pm defaults
29  if ( $USE_CGI_PM_DEFAULTS ) {
30    _use_cgi_pm_global_settings();
31    return;
32  }
33
34  # no file uploads by default, set to 0 to enable uploads
35  $DISABLE_UPLOADS = 1
36   unless defined $DISABLE_UPLOADS;
37
38  # use a post max of 100K, set to -1 for no limits
39  $POST_MAX = 102_400
40   unless defined $POST_MAX;
41
42  # set to 1 to not include undefined params parsed from query string
43  $NO_UNDEF_PARAMS = 0
44   unless defined $NO_UNDEF_PARAMS;
45
46  # separate the name=value pairs with ; rather than &
47  $USE_PARAM_SEMICOLONS = 0
48   unless defined $USE_PARAM_SEMICOLONS;
49
50  # return everything as utf-8
51  $PARAM_UTF8 ||= 0;
52  $PARAM_UTF8 and require Encode;
53
54  # only print headers once
55  $HEADERS_ONCE = 0
56   unless defined $HEADERS_ONCE;
57
58  # Set this to 1 to enable NPH scripts
59  $NPH = 0
60   unless defined $NPH;
61
62  # 0 => no debug, 1 => from @ARGV,  2 => from STDIN
63  $DEBUG = 0
64   unless defined $DEBUG;
65
66  # filter out null bytes in param - value pairs
67  $NO_NULL = 1
68   unless defined $NO_NULL;
69
70# set behavior when cgi_err() called -1 => silent, 0 => carp, 1 => croak
71  $FATAL = -1
72   unless defined $FATAL;
73}
74
75# I happen to disagree with many of the default global settings in CGI.pm
76# This sub is called if you set $CGI::Simple::USE_CGI_PM_GLOBALS = 1; or
77# invoke the '-default' pragma via a use CGI::Simple qw(-default);
78sub _use_cgi_pm_global_settings {
79  $USE_CGI_PM_DEFAULTS  = 1;
80  $DISABLE_UPLOADS      = 0 unless defined $DISABLE_UPLOADS;
81  $POST_MAX             = -1 unless defined $POST_MAX;
82  $NO_UNDEF_PARAMS      = 0 unless defined $NO_UNDEF_PARAMS;
83  $USE_PARAM_SEMICOLONS = 1 unless defined $USE_PARAM_SEMICOLONS;
84  $HEADERS_ONCE         = 0 unless defined $HEADERS_ONCE;
85  $NPH                  = 0 unless defined $NPH;
86  $DEBUG                = 1 unless defined $DEBUG;
87  $NO_NULL              = 0 unless defined $NO_NULL;
88  $FATAL                = -1 unless defined $FATAL;
89  $PARAM_UTF8           = 0 unless defined $PARAM_UTF8;
90}
91
92# this is called by new, we will never directly reference the globals again
93sub _store_globals {
94  my $self = shift;
95
96  $self->{'.globals'}->{'DISABLE_UPLOADS'}      = $DISABLE_UPLOADS;
97  $self->{'.globals'}->{'POST_MAX'}             = $POST_MAX;
98  $self->{'.globals'}->{'NO_UNDEF_PARAMS'}      = $NO_UNDEF_PARAMS;
99  $self->{'.globals'}->{'USE_PARAM_SEMICOLONS'} = $USE_PARAM_SEMICOLONS;
100  $self->{'.globals'}->{'HEADERS_ONCE'}         = $HEADERS_ONCE;
101  $self->{'.globals'}->{'NPH'}                  = $NPH;
102  $self->{'.globals'}->{'DEBUG'}                = $DEBUG;
103  $self->{'.globals'}->{'NO_NULL'}              = $NO_NULL;
104  $self->{'.globals'}->{'FATAL'}                = $FATAL;
105  $self->{'.globals'}->{'USE_CGI_PM_DEFAULTS'}  = $USE_CGI_PM_DEFAULTS;
106  $self->{'.globals'}->{'PARAM_UTF8'}           = $PARAM_UTF8;
107}
108
109# use the automatic calling of the import sub to set our pragmas. CGI.pm compat
110sub import {
111  my ( $self, @args ) = @_;
112
113# arguments supplied in the 'use CGI::Simple [ARGS];' will now be in @args
114  foreach ( @args ) {
115    $USE_CGI_PM_DEFAULTS = 1, next if m/^-default/i;
116    $DISABLE_UPLOADS     = 1, next if m/^-no.?upload/i;
117    $DISABLE_UPLOADS     = 0, next if m/^-upload/i;
118    $HEADERS_ONCE        = 1, next if m/^-unique.?header/i;
119    $NPH                 = 1, next if m/^-nph/i;
120    $DEBUG               = 0, next if m/^-no.?debug/i;
121    $DEBUG = defined $1 ? $1 : 2, next if m/^-debug(\d)?/i;
122    $USE_PARAM_SEMICOLONS = 1, next if m/^-newstyle.?url/i;
123    $USE_PARAM_SEMICOLONS = 0, next if m/^-oldstyle.?url/i;
124    $NO_UNDEF_PARAMS      = 1, next if m/^-no.?undef.?param/i;
125    $FATAL                = 0, next if m/^-carp/i;
126    $FATAL                = 1, next if m/^-croak/i;
127    croak "Pragma '$_' is not defined in CGI::Simple\n";
128  }
129}
130
131# used in CGI.pm .t files
132sub _reset_globals {
133  _use_cgi_pm_global_settings();
134}
135
136binmode STDIN;
137binmode STDOUT;
138
139# use correct encoding conversion to handle non ASCII char sets.
140# we import and install the complex routines only if we have to.
141BEGIN {
142
143  sub url_decode {
144    my ( $self, $decode ) = @_;
145    return () unless defined $decode;
146    $decode =~ tr/+/ /;
147    $decode =~ s/%([a-fA-F0-9]{2})/ pack "C", hex $1 /eg;
148    return $decode;
149  }
150
151  sub url_encode {
152    my ( $self, $encode ) = @_;
153    return () unless defined $encode;
154    $encode
155     =~ s/([^A-Za-z0-9\-_.!~*'() ])/ uc sprintf "%%%02x",ord $1 /eg;
156    $encode =~ tr/ /+/;
157    return $encode;
158  }
159
160  if ( "\t" ne "\011" ) {
161    eval { require CGI::Simple::Util };
162    if ( $@ ) {
163      croak
164       "Your server is using not using ASCII, you must install CGI::Simple::Util, error: $@";
165    }
166
167    # hack the symbol table and replace simple encode/decode subs
168    *CGI::Simple::url_encode
169     = sub { CGI::Simple::Util::escape( $_[1] ) };
170    *CGI::Simple::url_decode
171     = sub { CGI::Simple::Util::unescape( $_[1] ) };
172  }
173}
174
175################ The Guts ################
176
177sub new {
178  my ( $class, $init ) = @_;
179  $class = ref( $class ) || $class;
180  my $self = {};
181  bless $self, $class;
182  if ( $self->_mod_perl ) {
183    if ( $init ) {
184      $self->{'.mod_perl_request'} = $init;
185      undef $init;    # otherwise _initialize takes the wrong path
186    }
187    $self->_initialize_mod_perl();
188  }
189  $self->_initialize_globals;
190  $self->_store_globals;
191  $self->_initialize( $init );
192  return $self;
193}
194
195sub _mod_perl {
196  return (
197    exists $ENV{MOD_PERL}
198     or ( $ENV{GATEWAY_INTERFACE}
199      and $ENV{GATEWAY_INTERFACE} =~ m{^CGI-Perl/} )
200  );
201}
202
203# Return the global request object under mod_perl. If you use mod_perl 2
204# and you don't set PerlOptions +GlobalRequest then the request must be
205# passed in to the new() method.
206sub _mod_perl_request {
207  my $self = shift;
208
209  my $mp = $self->{'.mod_perl'};
210
211  return unless $mp;
212
213  my $req = $self->{'.mod_perl_request'};
214  return $req if $req;
215
216  $self->{'.mod_perl_request'} = do {
217    if ( $mp == 2 ) {
218      Apache2::RequestUtil->request;
219    }
220    else {
221      Apache->request;
222    }
223  };
224}
225
226sub _initialize_mod_perl {
227  my ( $self ) = @_;
228
229  eval "require mod_perl";
230
231  if ( defined $mod_perl::VERSION ) {
232
233    if ( $mod_perl::VERSION >= 2.00 ) {
234      $self->{'.mod_perl'} = 2;
235
236      require Apache2::RequestRec;
237      require Apache2::RequestIO;
238      require Apache2::RequestUtil;
239      require Apache2::Response;
240      require APR::Pool;
241
242      my $r = $self->_mod_perl_request();
243
244      if ( defined $r ) {
245        $r->subprocess_env unless exists $ENV{REQUEST_METHOD};
246        $r->pool->cleanup_register(
247          \&CGI::Simple::_initialize_globals );
248      }
249    }
250    else {
251      $self->{'.mod_perl'} = 1;
252
253      require Apache;
254
255      my $r = $self->_mod_perl_request();
256
257      if ( defined $r ) {
258        $r->register_cleanup( \&CGI::Simple::_initialize_globals );
259      }
260    }
261  }
262}
263
264sub _initialize {
265  my ( $self, $init ) = @_;
266
267  if ( !defined $init ) {
268
269    # initialize from QUERY_STRING, STDIN or @ARGV
270    $self->_read_parse();
271  }
272  elsif ( ( ref $init ) =~ m/HASH/i ) {
273
274    # initialize from param hash
275    for my $param ( keys %{$init} ) {
276      $self->_add_param( $param, $init->{$param} );
277    }
278  }
279
280  # chromatic's blessed GLOB patch
281  # elsif ( (ref $init) =~ m/GLOB/i ) { # initialize from a file
282  elsif ( UNIVERSAL::isa( $init, 'GLOB' ) ) {   # initialize from a file
283    $self->_init_from_file( $init );
284  }
285  elsif ( ( ref $init ) eq 'CGI::Simple' ) {
286
287    # initialize from a CGI::Simple object
288    require Data::Dumper;
289
290    # avoid problems with strict when Data::Dumper returns $VAR1
291    my $VAR1;
292    my $clone = eval( Data::Dumper::Dumper( $init ) );
293    if ( $@ ) {
294      $self->cgi_error( "Can't clone CGI::Simple object: $@" );
295    }
296    else {
297      $_[0] = $clone;
298    }
299  }
300  else {
301    $self->_parse_params( $init );    # initialize from a query string
302  }
303}
304
305sub _internal_read($\$;$) {
306  my ( $self, $buffer, $len ) = @_;
307  $len = 4096 if !defined $len;
308  if ( $self->{'.mod_perl'} ) {
309    my $r = $self->_mod_perl_request();
310    $r->read( $$buffer, $len );
311  }
312  else {
313    read( STDIN, $$buffer, $len );
314  }
315}
316
317sub _read_parse {
318  my $self   = shift;
319  my $data   = '';
320  my $type   = $ENV{'CONTENT_TYPE'} || 'No CONTENT_TYPE received';
321  my $length = $ENV{'CONTENT_LENGTH'} || 0;
322  my $method = $ENV{'REQUEST_METHOD'} || 'No REQUEST_METHOD received';
323
324  # first check POST_MAX Steve Purkis pointed out the previous bug
325  if (  ( $method eq 'POST' or $method eq "PUT" )
326    and $self->{'.globals'}->{'POST_MAX'} != -1
327    and $length > $self->{'.globals'}->{'POST_MAX'} ) {
328    $self->cgi_error(
329      "413 Request entity too large: $length bytes on STDIN exceeds \$POST_MAX!"
330    );
331
332    # silently discard data ??? better to just close the socket ???
333    while ( $length > 0 ) {
334      last unless _internal_read( $self, my $buffer );
335      $length -= length( $buffer );
336    }
337
338    return;
339  }
340
341  if ( $length and $type =~ m|^multipart/form-data|i ) {
342    my $got_length = $self->_parse_multipart;
343    if ( $length != $got_length ) {
344      $self->cgi_error(
345        "500 Bad read on multipart/form-data! wanted $length, got $got_length"
346      );
347    }
348
349    return;
350  }
351  elsif ( $method eq 'POST' or $method eq 'PUT' ) {
352    if ( $length ) {
353
354      # we may not get all the data we want with a single read on large
355      # POSTs as it may not be here yet! Credit Jason Luther for patch
356      # CGI.pm < 2.99 suffers from same bug
357      _internal_read( $self, $data, $length );
358      while ( length( $data ) < $length ) {
359        last unless _internal_read( $self, my $buffer );
360        $data .= $buffer;
361      }
362
363      unless ( $length == length $data ) {
364        $self->cgi_error( "500 Bad read on POST! wanted $length, got "
365           . length( $data ) );
366        return;
367      }
368
369      if ( $type !~ m|^application/x-www-form-urlencoded| ) {
370        $self->_add_param( $method . "DATA", $data );
371      }
372      else {
373        $self->_parse_params( $data );
374      }
375    }
376  }
377  elsif ( $method eq 'GET' or $method eq 'HEAD' ) {
378    $data
379     = $self->{'.mod_perl'}
380     ? $self->_mod_perl_request()->args()
381     : $ENV{'QUERY_STRING'}
382     || $ENV{'REDIRECT_QUERY_STRING'}
383     || '';
384    $self->_parse_params( $data );
385  }
386  else {
387    unless ( $self->{'.globals'}->{'DEBUG'}
388      and $data = $self->read_from_cmdline() ) {
389      $self->cgi_error( "400 Unknown method $method" );
390      return;
391    }
392
393    unless ( $data ) {
394
395# I liked this reporting but CGI.pm does not behave like this so
396# out it goes......
397# $self->cgi_error("400 No data received via method: $method, type: $type");
398      return;
399    }
400
401    $self->_parse_params( $data );
402  }
403}
404
405sub _parse_params {
406  my ( $self, $data ) = @_;
407  return () unless defined $data;
408  unless ( $data =~ /[&=;]/ ) {
409    $self->{'keywords'} = [ $self->_parse_keywordlist( $data ) ];
410    return;
411  }
412  my @pairs = split /[&;]/, $data;
413  for my $pair ( @pairs ) {
414    my ( $param, $value ) = split /=/, $pair, 2;
415    next unless defined $param;
416    $value = '' unless defined $value;
417    $self->_add_param( $self->url_decode( $param ),
418      $self->url_decode( $value ) );
419  }
420}
421
422sub _add_param {
423  my ( $self, $param, $value, $overwrite ) = @_;
424  return () unless defined $param and defined $value;
425  $param =~ tr/\000//d if $self->{'.globals'}->{'NO_NULL'};
426  @{ $self->{$param} } = () if $overwrite;
427  @{ $self->{$param} } = () unless exists $self->{$param};
428  my @values = ref $value ? @{$value} : ( $value );
429  for my $value ( @values ) {
430    next
431     if $value eq ''
432       and $self->{'.globals'}->{'NO_UNDEF_PARAMS'};
433    $value =~ tr/\000//d if $self->{'.globals'}->{'NO_NULL'};
434    $value = Encode::decode( utf8 => $value )
435     if $self->{'.globals'}->{PARAM_UTF8};
436    push @{ $self->{$param} }, $value;
437    unless ( $self->{'.fieldnames'}->{$param} ) {
438      push @{ $self->{'.parameters'} }, $param;
439      $self->{'.fieldnames'}->{$param}++;
440    }
441  }
442  return scalar @values;    # for compatibility with CGI.pm request.t
443}
444
445sub _parse_keywordlist {
446  my ( $self, $data ) = @_;
447  return () unless defined $data;
448  $data = $self->url_decode( $data );
449  $data =~ tr/\000//d if $self->{'.globals'}->{'NO_NULL'};
450  my @keywords = split /\s+/, $data;
451  return @keywords;
452}
453
454sub _parse_multipart {
455  my $self = shift;
456
457  # TODO: See 14838. We /could/ have a heuristic here for the case
458  # where no boundary is supplied.
459
460  my ( $boundary )
461   = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";,]+)\"?/;
462  unless ( $boundary ) {
463    $self->cgi_error(
464      '400 No boundary supplied for multipart/form-data' );
465    return 0;
466  }
467
468# BUG: IE 3.01 on the Macintosh uses just the boundary, forgetting the --
469  $boundary = '--' . $boundary
470   unless exists $ENV{'HTTP_USER_AGENT'}
471     && $ENV{'HTTP_USER_AGENT'} =~ m/MSIE\s+3\.0[12];\s*Mac/i;
472
473  $boundary = quotemeta $boundary;
474  my $got_data = 0;
475  my $data     = '';
476  my $length   = $ENV{'CONTENT_LENGTH'} || 0;
477  my $CRLF     = $self->crlf;
478
479  READ:
480
481  while ( $got_data < $length ) {
482    last READ unless _internal_read( $self, my $buffer );
483    $data .= $buffer;
484    $got_data += length $buffer;
485
486    BOUNDARY:
487
488    while ( $data =~ m/^$boundary$CRLF/ ) {
489      ## TAB and high ascii chars are definitivelly allowed in headers.
490      ## Not accepting them in the following regex prevents the upload of
491      ## files with filenames like "Espa�xt".
492      # next READ unless $data =~ m/^([\040-\176$CRLF]+?$CRLF$CRLF)/o;
493      next READ
494       unless $data =~ m/^([\x20-\x7E\x80-\xFF\x09$CRLF]+?$CRLF$CRLF)/o;
495      my $header = $1;
496      ( my $unfold = $1 ) =~ s/$CRLF\s+/ /og;
497      my ( $param ) = $unfold =~ m/form-data;\s+name="?([^\";]*)"?/;
498      my ( $filename )
499       = $unfold =~ m/name="?\Q$param\E"?;\s+filename="?([^\"]*)"?/;
500      if ( defined $filename ) {
501        my ( $mime ) = $unfold =~ m/Content-Type:\s+([-\w\/]+)/io;
502        $data =~ s/^\Q$header\E//;
503        ( $got_data, $data, my $fh, my $size )
504         = $self->_save_tmpfile( $boundary, $filename, $got_data,
505          $data );
506        $self->_add_param( $param, $filename );
507        $self->{'.upload_fields'}->{$param} = $filename;
508        $self->{'.filehandles'}->{$filename} = $fh if $fh;
509        $self->{'.tmpfiles'}->{$filename}
510         = { 'size' => $size, 'mime' => $mime }
511         if $size;
512        next BOUNDARY;
513      }
514      next READ
515       unless $data =~ s/^\Q$header\E(.*?)$CRLF(?=$boundary)//s;
516      $self->_add_param( $param, $1 );
517    }
518    unless ( $data =~ m/^$boundary/ ) {
519      ## In a perfect world, $data should always begin with $boundary.
520      ## But sometimes, IE5 prepends garbage boundaries into POST(ed) data.
521      ## Then, $data does not start with $boundary and the previous block
522      ## never gets executed. The following fix attempts to remove those
523      ## extra boundaries from readed $data and restart boundary parsing.
524      ## Note about performance: with well formed data, previous check is
525      ## executed (generally) only once, when $data value is "$boundary--"
526      ## at end of parsing.
527      goto BOUNDARY if ( $data =~ s/.*?$CRLF(?=$boundary$CRLF)//s );
528    }
529  }
530  return $got_data;
531}
532
533sub _save_tmpfile {
534  my ( $self, $boundary, $filename, $got_data, $data ) = @_;
535  my $fh;
536  my $CRLF      = $self->crlf;
537  my $length    = $ENV{'CONTENT_LENGTH'} || 0;
538  my $file_size = 0;
539  if ( $self->{'.globals'}->{'DISABLE_UPLOADS'} ) {
540    $self->cgi_error( "405 Not Allowed - File uploads are disabled" );
541  }
542  elsif ( $filename ) {
543    eval { require IO::File };
544    $self->cgi_error( "500 IO::File is not available $@" ) if $@;
545    $fh = new_tmpfile IO::File;
546    $self->cgi_error( "500 IO::File can't create new temp_file" )
547     unless $fh;
548  }
549
550# read in data until closing boundary found. buffer to catch split boundary
551# we do this regardless of whether we save the file or not to read the file
552# data from STDIN. if either uploads are disabled or no file has been sent
553# $fh will be undef so only do file stuff if $fh is true using $fh && syntax
554  $fh && binmode $fh;
555  while ( $got_data < $length ) {
556
557    my $buffer = $data;
558    last unless _internal_read( $self, $data );
559
560    # fixed hanging bug if browser terminates upload part way through
561    # thanks to Brandon Black
562    unless ( $data ) {
563      $self->cgi_error(
564        '400 Malformed multipart, no terminating boundary' );
565      undef $fh;
566      return $got_data;
567    }
568
569    $got_data += length $data;
570    if ( "$buffer$data" =~ m/$boundary/ ) {
571      $data = $buffer . $data;
572      last;
573    }
574
575    # we do not have partial boundary so print to file if valid $fh
576    $fh && print $fh $buffer;
577    $file_size += length $buffer;
578  }
579  $data =~ s/^(.*?)$CRLF(?=$boundary)//s;
580  $fh && print $fh $1;    # print remainder of file if valid $fh
581  $file_size += length $1;
582  return $got_data, $data, $fh, $file_size;
583}
584
585# Define the CRLF sequence.  You can't use a simple "\r\n" because of system
586# specific 'features'. On EBCDIC systems "\t" ne "\011" as the don't use ASCII
587sub crlf {
588  my ( $self, $CRLF ) = @_;
589  $self->{'.crlf'} = $CRLF if $CRLF;    # allow value to be set manually
590  unless ( $self->{'.crlf'} ) {
591    my $OS = $^O
592     || do { require Config; $Config::Config{'osname'} };
593    $self->{'.crlf'}
594     = ( $OS =~ m/VMS/i ) ? "\n"
595     : ( "\t" ne "\011" ) ? "\r\n"
596     :                      "\015\012";
597  }
598  return $self->{'.crlf'};
599}
600
601################ The Core Methods ################
602
603sub param {
604  my ( $self, $param, @p ) = @_;
605  unless ( defined $param ) {    # return list of all params
606    my @params
607     = $self->{'.parameters'} ? @{ $self->{'.parameters'} } : ();
608    return @params;
609  }
610  unless ( @p ) {                # return values for $param
611    return () unless exists $self->{$param};
612    return wantarray ? @{ $self->{$param} } : $self->{$param}->[0];
613  }
614  if ( $param =~ m/^-name$/i and @p == 1 ) {
615    return () unless exists $self->{ $p[0] };
616    return wantarray ? @{ $self->{ $p[0] } } : $self->{ $p[0] }->[0];
617  }
618
619  # set values using -name=>'foo',-value=>'bar' syntax.
620  # also allows for $q->param( 'foo', 'some', 'new', 'values' ) syntax
621  ( $param, undef, @p ) = @p
622   if $param =~ m/^-name$/i;     # undef represents -value token
623  $self->_add_param( $param, ( ref $p[0] eq 'ARRAY' ? $p[0] : [@p] ),
624    'overwrite' );
625  return wantarray ? @{ $self->{$param} } : $self->{$param}->[0];
626}
627
628#1;
629
630###############   The following methods only loaded on demand   ###############
631###############  Move commonly used methods above the __DATA__  ###############
632############### token if you are into recreational optimization ###############
633###############  You can not use Selfloader and the __DATA__    ###############
634###############   token under mod_perl, so comment token out    ###############
635
636#__DATA__
637
638# a new method that provides access to a new internal routine. Useage:
639# $q->add_param( $param, $value, $overwrite )
640# $param must be a plain scalar
641# $value may be either a scalar or an array ref
642# if $overwrite is a true value $param will be overwritten with new values.
643sub add_param {
644  _add_param( @_ );
645}
646
647sub param_fetch {
648  my ( $self, $param, @p ) = @_;
649  $param
650   = ( defined $param and $param =~ m/^-name$/i ) ? $p[0] : $param;
651  return undef unless defined $param;
652  $self->_add_param( $param, [] ) unless exists $self->{$param};
653  return $self->{$param};
654}
655
656# Return a parameter in the QUERY_STRING, regardless of whether a POST or GET
657sub url_param {
658  my ( $self, $param ) = @_;
659  return () unless $ENV{'QUERY_STRING'};
660  $self->{'.url_param'} = {};
661  bless $self->{'.url_param'}, 'CGI::Simple';
662  $self->{'.url_param'}->_parse_params( $ENV{'QUERY_STRING'} );
663  return $self->{'.url_param'}->param( $param );
664}
665
666sub keywords {
667  my ( $self, @values ) = @_;
668  $self->{'keywords'}
669   = ref $values[0] eq 'ARRAY' ? $values[0] : [@values]
670   if @values;
671  my @result
672   = defined( $self->{'keywords'} ) ? @{ $self->{'keywords'} } : ();
673  return @result;
674}
675
676sub Vars {
677  my $self = shift;
678  $self->{'.sep'} = shift || $self->{'.sep'} || "\0";
679  my ( %hash, %tied );
680  for my $param ( $self->param ) {
681    $hash{$param} = join $self->{'.sep'}, $self->param( $param );
682  }
683  tie %tied, "CGI::Simple", $self;
684  return wantarray ? %hash : \%tied;
685}
686
687sub TIEHASH { $_[1] ? $_[1] : new $_[0] }
688
689sub STORE {
690  my ( $q, $p, $v ) = @_;
691  $q->param( $p, split $q->{'.sep'}, $v );
692}
693
694sub FETCH {
695  my ( $q, $p ) = @_;
696  ref $q->{$p} eq "ARRAY" ? join $q->{'.sep'}, @{ $q->{$p} } : $q->{$p};
697}
698sub FIRSTKEY { my $a = scalar keys %{ $_[0] }; each %{ $_[0] } }
699sub NEXTKEY { each %{ $_[0] } }
700sub EXISTS  { exists $_[0]->{ $_[1] } }
701sub DELETE  { $_[0]->delete( $_[1] ) }
702sub CLEAR   { %{ $_[0] } = () }
703
704sub append {
705  my ( $self, $param, @p ) = @_;
706  return () unless defined $param;
707
708  # set values using $q->append(-name=>'foo',-value=>'bar') syntax
709  # also allows for $q->append( 'foo', 'some', 'new', 'values' ) syntax
710  ( $param, undef, @p ) = @p
711   if $param =~ m/^-name$/i;    # undef represents -value token
712  $self->_add_param( $param,
713    ( ( defined $p[0] and ref $p[0] ) ? $p[0] : [@p] ) );
714  return $self->param( $param );
715}
716
717sub delete {
718  my ( $self, $param ) = @_;
719  return () unless defined $param;
720  $param
721   = $param =~ m/^-name$/i
722   ? shift
723   : $param;                    # allow delete(-name=>'foo') syntax
724  return undef unless defined $self->{$param};
725  delete $self->{$param};
726  delete $self->{'.fieldnames'}->{$param};
727  $self->{'.parameters'}
728   = [ grep { $_ ne $param } @{ $self->{'.parameters'} } ];
729}
730
731sub Delete { CGI::Simple::delete( @_ ) }    # for method style interface
732
733sub delete_all {
734  my $self = shift;
735  undef %{$self};
736  $self->_store_globals;
737}
738
739sub Delete_all { $_[0]->delete_all }        # as used by CGI.pm
740
741sub upload {
742  my ( $self, $filename, $writefile ) = @_;
743  unless ( $filename ) {
744    $self->cgi_error( "No filename submitted for upload to $writefile" )
745     if $writefile;
746    return $self->{'.filehandles'}
747     ? keys %{ $self->{'.filehandles'} }
748     : ();
749  }
750  unless ( $ENV{'CONTENT_TYPE'} =~ m|^multipart/form-data|i ) {
751    $self->cgi_error(
752      'Oops! File uploads only work if you specify ENCTYPE="multipart/form-data" in your <FORM> tag'
753    );
754    return undef;
755  }
756  my $fh = $self->{'.filehandles'}->{$filename};
757
758  # allow use of upload fieldname to get filehandle
759  # this has limitation that in the event of duplicate
760  # upload field names there can only be one filehandle
761  # which will point to the last upload file
762  # access by filename does not suffer from this issue.
763  $fh
764   = $self->{'.filehandles'}->{ $self->{'.upload_fields'}->{$filename} }
765   if !$fh and defined $self->{'.upload_fields'}->{$filename};
766
767  if ( $fh ) {
768    seek $fh, 0, 0;    # get ready for reading
769    return $fh unless $writefile;
770    my $buffer;
771    unless ( open OUT, ">$writefile" ) {
772      $self->cgi_error( "500 Can't write to $writefile: $!\n" );
773      return undef;
774    }
775    binmode OUT;
776    binmode $fh;
777    print OUT $buffer while read( $fh, $buffer, 4096 );
778    close OUT;
779    $self->{'.filehandles'}->{$filename} = undef;
780    undef $fh;
781    return 1;
782  }
783  else {
784    $self->cgi_error(
785      "No filehandle for '$filename'. Are uploads enabled (\$DISABLE_UPLOADS = 0)? Is \$POST_MAX big enough?"
786    );
787    return undef;
788  }
789}
790
791sub upload_fieldnames {
792  my ( $self ) = @_;
793  return wantarray
794   ? ( keys %{ $self->{'.upload_fields'} } )
795   : [ keys %{ $self->{'.upload_fields'} } ];
796}
797
798# return the file size of an uploaded file
799sub upload_info {
800  my ( $self, $filename, $info ) = @_;
801  unless ( $ENV{'CONTENT_TYPE'} =~ m|^multipart/form-data|i ) {
802    $self->cgi_error(
803      'Oops! File uploads only work if you specify ENCTYPE="multipart/form-data" in your <FORM> tag'
804    );
805    return undef;
806  }
807  return keys %{ $self->{'.tmpfiles'} } unless $filename;
808  return $self->{'.tmpfiles'}->{$filename}->{'mime'}
809   if $info =~ /mime/i;
810  return $self->{'.tmpfiles'}->{$filename}->{'size'};
811}
812
813sub uploadInfo { &upload_info }    # alias for CGI.pm compatibility
814
815# return all params/values in object as a query string suitable for 'GET'
816sub query_string {
817  my $self = shift;
818  my @pairs;
819  for my $param ( $self->param ) {
820    for my $value ( $self->param( $param ) ) {
821      next unless defined $value;
822      push @pairs,
823       $self->url_encode( $param ) . '=' . $self->url_encode( $value );
824    }
825  }
826  return join $self->{'.globals'}->{'USE_PARAM_SEMICOLONS'} ? ';' : '&',
827   @pairs;
828}
829
830# new method that will add QUERY_STRING data to our CGI::Simple object
831# if the REQUEST_METHOD was 'POST'
832sub parse_query_string {
833  my $self = shift;
834  $self->_parse_params( $ENV{'QUERY_STRING'} )
835   if defined $ENV{'QUERY_STRING'}
836     and $ENV{'REQUEST_METHOD'} eq 'POST';
837}
838
839################   Save and Restore params from file    ###############
840
841sub _init_from_file {
842  my ( $self, $fh ) = @_;
843  local $/ = "\n";
844  while ( my $pair = <$fh> ) {
845    chomp $pair;
846    return if $pair eq '=';
847    $self->_parse_params( $pair );
848  }
849}
850
851sub save {
852  my ( $self, $fh ) = @_;
853  local ( $,, $\ ) = ( '', '' );
854  unless ( $fh and fileno $fh ) {
855    $self->cgi_error( 'Invalid filehandle' );
856    return undef;
857  }
858  for my $param ( $self->param ) {
859    for my $value ( $self->param( $param ) ) {
860      ;
861      print $fh $self->url_encode( $param ), '=',
862       $self->url_encode( $value ), "\n";
863    }
864  }
865  print $fh "=\n";
866}
867
868sub save_parameters { save( @_ ) }    # CGI.pm alias for save
869
870################ Miscellaneous Methods ################
871
872sub parse_keywordlist {
873  _parse_keywordlist( @_ );
874}                                     # CGI.pm compatibility
875
876sub escapeHTML {
877  my ( $self, $escape, $newlinestoo ) = @_;
878  require CGI::Simple::Util;
879  $escape = CGI::Simple::Util::escapeHTML( $escape );
880  $escape =~ s/([\012\015])/'&#'.(ord $1).';'/eg if $newlinestoo;
881  return $escape;
882}
883
884sub unescapeHTML {
885  require CGI::Simple::Util;
886  return CGI::Simple::Util::unescapeHTML( $_[1] );
887}
888
889sub put {
890  my $self = shift;
891  $self->print( @_ );
892}    # send output to browser
893
894sub print {
895  shift;
896  CORE::print( @_ );
897}    # print to standard output (for overriding in mod_perl)
898
899################# Cookie Methods ################
900
901sub cookie {
902  my ( $self, @params ) = @_;
903  require CGI::Simple::Cookie;
904  require CGI::Simple::Util;
905  my ( $name, $value, $path, $domain, $secure, $expires )
906   = CGI::Simple::Util::rearrange(
907    [
908      'NAME', [ 'VALUE', 'VALUES' ],
909      'PATH',   'DOMAIN',
910      'SECURE', 'EXPIRES'
911    ],
912    @params
913   );
914
915  # retrieve the value of the cookie, if no value is supplied
916  unless ( defined( $value ) ) {
917    $self->{'.cookies'} = CGI::Simple::Cookie->fetch
918     unless $self->{'.cookies'};
919    return () unless $self->{'.cookies'};
920
921   # if no name is supplied, then retrieve the names of all our cookies.
922    return keys %{ $self->{'.cookies'} } unless $name;
923
924    # return the value of the cookie
925    return
926     exists $self->{'.cookies'}->{$name}
927     ? $self->{'.cookies'}->{$name}->value
928     : ();
929  }
930
931  # If we get here, we're creating a new cookie
932  return undef unless $name;    # this is an error
933  @params = ();
934  push @params, '-name'    => $name;
935  push @params, '-value'   => $value;
936  push @params, '-domain'  => $domain if $domain;
937  push @params, '-path'    => $path if $path;
938  push @params, '-expires' => $expires if $expires;
939  push @params, '-secure'  => $secure if $secure;
940  return CGI::Simple::Cookie->new( @params );
941}
942
943sub raw_cookie {
944  my ( $self, $key ) = @_;
945  if ( defined $key ) {
946    unless ( $self->{'.raw_cookies'} ) {
947      require CGI::Simple::Cookie;
948      $self->{'.raw_cookies'} = CGI::Simple::Cookie->raw_fetch;
949    }
950    return $self->{'.raw_cookies'}->{$key} || ();
951  }
952  return $ENV{'HTTP_COOKIE'} || $ENV{'COOKIE'} || '';
953}
954
955################# Header Methods ################
956
957sub header {
958  my ( $self, @params ) = @_;
959  require CGI::Simple::Util;
960  my @header;
961  return undef
962   if $self->{'.header_printed'}++
963     and $self->{'.globals'}->{'HEADERS_ONCE'};
964  my (
965    $type, $status,  $cookie,     $target, $expires,
966    $nph,  $charset, $attachment, $p3p,    @other
967   )
968   = CGI::Simple::Util::rearrange(
969    [
970      [ 'TYPE',   'CONTENT_TYPE', 'CONTENT-TYPE' ], 'STATUS',
971      [ 'COOKIE', 'COOKIES',      'SET-COOKIE' ],   'TARGET',
972      'EXPIRES', 'NPH',
973      'CHARSET', 'ATTACHMENT',
974      'P3P'
975    ],
976    @params
977   );
978  $nph ||= $self->{'.globals'}->{'NPH'};
979  $charset = $self->charset( $charset )
980   ;    # get charset (and set new charset if supplied)
981   # rearrange() was designed for the HTML portion, so we need to fix it up a little.
982
983  for ( @other ) {
984
985    # Don't use \s because of perl bug 21951
986    next
987     unless my ( $header, $value ) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/;
988    ( $_ = $header )
989     =~ s/^(\w)(.*)/"\u$1\L$2" . ': '.$self->unescapeHTML($value)/e;
990  }
991  $type ||= 'text/html' unless defined $type;
992  $type .= "; charset=$charset"
993   if $type
994     and $type =~ m!^text/!
995     and $type !~ /\bcharset\b/;
996  my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
997  push @header, $protocol . ' ' . ( $status || '200 OK' ) if $nph;
998  push @header, "Server: " . server_software() if $nph;
999  push @header, "Status: $status"              if $status;
1000  push @header, "Window-Target: $target"       if $target;
1001
1002  if ( $p3p ) {
1003    $p3p = join ' ', @$p3p if ref( $p3p ) eq 'ARRAY';
1004    push( @header, qq(P3P: policyref="/w3c/p3p.xml", CP="$p3p") );
1005  }
1006
1007  # push all the cookies -- there may be several
1008  if ( $cookie ) {
1009    my @cookie = ref $cookie eq 'ARRAY' ? @{$cookie} : $cookie;
1010    for my $cookie ( @cookie ) {
1011      my $cs
1012       = ref $cookie eq 'CGI::Simple::Cookie'
1013       ? $cookie->as_string
1014       : $cookie;
1015      push @header, "Set-Cookie: $cs" if $cs;
1016    }
1017  }
1018
1019# if the user indicates an expiration time, then we need both an Expires
1020# and a Date header (so that the browser is using OUR clock)
1021  $expires = 'now'
1022   if $self->no_cache;    # encourage no caching via expires now
1023  push @header,
1024   "Expires: " . CGI::Simple::Util::expires( $expires, 'http' )
1025   if $expires;
1026  push @header, "Date: " . CGI::Simple::Util::expires( 0, 'http' )
1027   if defined $expires || $cookie || $nph;
1028  push @header, "Pragma: no-cache" if $self->cache or $self->no_cache;
1029  push @header,
1030   "Content-Disposition: attachment; filename=\"$attachment\""
1031   if $attachment;
1032  push @header, @other;
1033  push @header, "Content-Type: $type" if $type;
1034  my $CRLF = $self->crlf;
1035  my $header = join $CRLF, @header;
1036  $header .= $CRLF . $CRLF;    # add the statutory two CRLFs
1037
1038  if ( $self->{'.mod_perl'} and not $nph ) {
1039    my $r = $self->_mod_perl_request();
1040    $r->send_cgi_header( $header );
1041    return '';
1042  }
1043  return $header;
1044}
1045
1046# Control whether header() will produce the no-cache Pragma directive.
1047sub cache {
1048  my ( $self, $value ) = @_;
1049  $self->{'.cache'} = $value if defined $value;
1050  return $self->{'.cache'};
1051}
1052
1053# Control whether header() will produce expires now + the no-cache Pragma.
1054sub no_cache {
1055  my ( $self, $value ) = @_;
1056  $self->{'.no_cache'} = $value if defined $value;
1057  return $self->{'.no_cache'};
1058}
1059
1060sub redirect {
1061  my ( $self, @params ) = @_;
1062  require CGI::Simple::Util;
1063  my ( $url, $target, $cookie, $nph, @other )
1064   = CGI::Simple::Util::rearrange(
1065    [
1066      [ 'LOCATION', 'URI',       'URL' ], 'TARGET',
1067      [ 'COOKIE',   'COOKIES' ], 'NPH'
1068    ],
1069    @params
1070   );
1071  $url ||= $self->self_url;
1072  my @o;
1073  for ( @other ) { tr/\"//d; push @o, split "=", $_, 2; }
1074  unshift @o,
1075   '-Status'   => '302 Moved',
1076   '-Location' => $url,
1077   '-nph'      => $nph;
1078  unshift @o, '-Target' => $target if $target;
1079  unshift @o, '-Cookie' => $cookie if $cookie;
1080  unshift @o, '-Type'   => '';
1081  my @unescaped;
1082  unshift( @unescaped, '-Cookie' => $cookie ) if $cookie;
1083  return $self->header( ( map { $self->unescapeHTML( $_ ) } @o ),
1084    @unescaped );
1085}
1086
1087################# Server Push Methods #################
1088# Return a Content-Type: style header for server-push
1089# This has to be NPH, and it is advisable to set $| = 1
1090# Credit to Ed Jordan <ed@fidalgo.net> and
1091# Andrew Benham <adsb@bigfoot.com> for this section
1092
1093sub multipart_init {
1094  my ( $self, @p ) = @_;
1095  use CGI::Simple::Util qw(rearrange);
1096  my ( $boundary, @other ) = rearrange( ['BOUNDARY'], @p );
1097  $boundary = $boundary || '------- =_aaaaaaaaaa0';
1098  my $CRLF = $self->crlf;    # get CRLF sequence
1099  my $warning
1100   = "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY.";
1101  $self->{'.separator'}       = "$CRLF--$boundary$CRLF";
1102  $self->{'.final_separator'} = "$CRLF--$boundary--$CRLF$warning$CRLF";
1103  my $type = 'multipart/x-mixed-replace;boundary="' . $boundary . '"';
1104  return $self->header(
1105    -nph  => 1,
1106    -type => $type,
1107    map { split "=", $_, 2 } @other
1108   )
1109   . $warning
1110   . $self->multipart_end;
1111}
1112
1113sub multipart_start {
1114  my ( $self, @p ) = @_;
1115  use CGI::Simple::Util qw(rearrange);
1116  my ( $type, @other ) = rearrange( ['TYPE'], @p );
1117  foreach ( @other ) {    # fix return from rearange
1118    next unless my ( $header, $value ) = /([^\s=]+)=\"?(.+?)\"?$/;
1119    $_ = ucfirst( lc $header ) . ': ' . unescapeHTML( 1, $value );
1120  }
1121  $type = $type || 'text/html';
1122  my @header = ( "Content-Type: $type" );
1123  push @header, @other;
1124  my $CRLF = $self->crlf;    # get CRLF sequence
1125  return ( join $CRLF, @header ) . $CRLF . $CRLF;
1126}
1127
1128sub multipart_end { return $_[0]->{'.separator'} }
1129
1130sub multipart_final { return $_[0]->{'.final_separator'} }
1131
1132################# Debugging Methods ################
1133
1134sub read_from_cmdline {
1135  my @words;
1136  if ( $_[0]->{'.globals'}->{'DEBUG'} == 1 and @ARGV ) {
1137    @words = @ARGV;
1138  }
1139  elsif ( $_[0]->{'.globals'}->{'DEBUG'} == 2 ) {
1140    require "shellwords.pl";
1141    print "(offline mode: enter name=value pairs on standard input)\n";
1142    chomp( my @lines = <STDIN> );
1143    @words = &shellwords( join " ", @lines );
1144  }
1145  else {
1146    return '';
1147  }
1148  @words = map { s/\\=/%3D/g; s/\\&/%26/g; $_ } @words;
1149  return "@words" =~ m/=/ ? join '&', @words : join '+', @words;
1150}
1151
1152sub Dump {
1153  require Data::Dumper;    # short and sweet way of doing it
1154  ( my $dump = Data::Dumper::Dumper( @_ ) )
1155   =~ tr/\000/0/;          # remove null bytes cgi-lib.pl
1156  return '<pre>' . escapeHTML( 1, $dump ) . '</pre>';
1157}
1158
1159sub as_string { Dump( @_ ) }    # CGI.pm alias for Dump()
1160
1161sub cgi_error {
1162  my ( $self, $err ) = @_;
1163  if ( $err ) {
1164    $self->{'.cgi_error'} = $err;
1165       $self->{'.globals'}->{'FATAL'} == 1 ? croak $err
1166     : $self->{'.globals'}->{'FATAL'} == 0 ? carp $err
1167     :                                       return $err;
1168  }
1169  return $self->{'.cgi_error'};
1170}
1171
1172################# cgi-lib.pl Compatibility Methods #################
1173# Lightly GOLFED but the original functionality remains. You can call
1174# them using either: # $q->MethodName or CGI::Simple::MethodName
1175
1176sub _shift_if_ref { shift if ref $_[0] eq 'CGI::Simple' }
1177
1178sub ReadParse {
1179  my $q = &_shift_if_ref || new CGI::Simple;
1180  my $pkg = caller();
1181  no strict 'refs';
1182  *in
1183   = @_
1184   ? $_[0]
1185   : *{"${pkg}::in"};    # set *in to passed glob or export *in
1186  %in = $q->Vars;
1187  $in{'CGI'} = $q;
1188  return scalar %in;
1189}
1190
1191sub SplitParam {
1192  &_shift_if_ref;
1193  defined $_[0]
1194   && ( wantarray ? split "\0", $_[0] : ( split "\0", $_[0] )[0] );
1195}
1196
1197sub MethGet { request_method() eq 'GET' }
1198
1199sub MethPost { request_method() eq 'POST' }
1200
1201sub MyBaseUrl {
1202  local $^W = 0;
1203  'http://'
1204   . server_name()
1205   . ( server_port() != 80 ? ':' . server_port() : '' )
1206   . script_name();
1207}
1208
1209sub MyURL { MyBaseUrl() }
1210
1211sub MyFullUrl {
1212  local $^W = 0;
1213  MyBaseUrl()
1214   . $ENV{'PATH_INFO'}
1215   . ( $ENV{'QUERY_STRING'} ? "?$ENV{'QUERY_STRING'}" : '' );
1216}
1217
1218sub PrintHeader {
1219  ref $_[0] ? $_[0]->header() : "Content-Type: text/html\n\n";
1220}
1221
1222sub HtmlTop {
1223  &_shift_if_ref;
1224  "<html>\n<head>\n<title>$_[0]</title>\n</head>\n<body>\n<h1>$_[0]</h1>\n";
1225}
1226
1227sub HtmlBot { "</body>\n</html>\n" }
1228
1229sub PrintVariables { &_shift_if_ref; &Dump }
1230
1231sub PrintEnv { &Dump( \%ENV ) }
1232
1233sub CgiDie { CgiError( @_ ); die @_ }
1234
1235sub CgiError {
1236  &_shift_if_ref;
1237  @_
1238   = @_
1239   ? @_
1240   : ( "Error: script " . MyFullUrl() . " encountered fatal error\n" );
1241  print PrintHeader(), HtmlTop( shift ), ( map { "<p>$_</p>\n" } @_ ),
1242   HtmlBot();
1243}
1244
1245################ Accessor Methods ################
1246
1247sub version { $VERSION }
1248
1249sub nph {
1250  $_[0]->{'.globals'}->{'NPH'} = $_[1] if defined $_[1];
1251  return $_[0]->{'.globals'}->{'NPH'};
1252}
1253
1254sub all_parameters { $_[0]->param }
1255
1256sub charset {
1257  require CGI::Simple::Util;
1258  $CGI::Simple::Util::UTIL->charset( $_[1] );
1259}
1260
1261sub globals {
1262  my ( $self, $global, $value ) = @_;
1263  return keys %{ $self->{'.globals'} } unless $global;
1264  $self->{'.globals'}->{$global} = $value if defined $value;
1265  return $self->{'.globals'}->{$global};
1266}
1267
1268sub auth_type         { $ENV{'AUTH_TYPE'} }
1269sub content_length    { $ENV{'CONTENT_LENGTH'} }
1270sub content_type      { $ENV{'CONTENT_TYPE'} }
1271sub document_root     { $ENV{'DOCUMENT_ROOT'} }
1272sub gateway_interface { $ENV{'GATEWAY_INTERFACE'} }
1273sub path_translated   { $ENV{'PATH_TRANSLATED'} }
1274sub referer           { $ENV{'HTTP_REFERER'} }
1275sub remote_addr       { $ENV{'REMOTE_ADDR'} || '127.0.0.1' }
1276
1277sub remote_host {
1278  $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'} || 'localhost';
1279}
1280
1281sub remote_ident   { $ENV{'REMOTE_IDENT'} }
1282sub remote_user    { $ENV{'REMOTE_USER'} }
1283sub request_method { $ENV{'REQUEST_METHOD'} }
1284sub script_name    { $ENV{'SCRIPT_NAME'} || $0 || '' }
1285sub server_name     { $ENV{'SERVER_NAME'}     || 'localhost' }
1286sub server_port     { $ENV{'SERVER_PORT'}     || 80 }
1287sub server_protocol { $ENV{'SERVER_PROTOCOL'} || 'HTTP/1.0' }
1288sub server_software { $ENV{'SERVER_SOFTWARE'} || 'cmdline' }
1289
1290sub user_name {
1291  $ENV{'HTTP_FROM'} || $ENV{'REMOTE_IDENT'} || $ENV{'REMOTE_USER'};
1292}
1293
1294sub user_agent {
1295  my ( $self, $match ) = @_;
1296  return $match
1297   ? $ENV{'HTTP_USER_AGENT'} =~ /\Q$match\E/i
1298   : $ENV{'HTTP_USER_AGENT'};
1299}
1300
1301sub virtual_host {
1302  my $vh = $ENV{'HTTP_HOST'} || $ENV{'SERVER_NAME'};
1303  $vh =~ s/:\d+$//;    # get rid of port number
1304  return $vh;
1305}
1306
1307sub path_info {
1308  my ( $self, $info ) = @_;
1309  if ( defined $info ) {
1310    $info = "/$info" if $info !~ m|^/|;
1311    $self->{'.path_info'} = $info;
1312  }
1313  elsif ( !defined( $self->{'.path_info'} ) ) {
1314    $self->{'.path_info'}
1315     = defined( $ENV{'PATH_INFO'} ) ? $ENV{'PATH_INFO'} : '';
1316
1317    # hack to fix broken path info in IIS source CGI.pm
1318    $self->{'.path_info'} =~ s/^\Q$ENV{'SCRIPT_NAME'}\E//
1319     if defined( $ENV{'SERVER_SOFTWARE'} )
1320       && $ENV{'SERVER_SOFTWARE'} =~ /IIS/;
1321  }
1322  return $self->{'.path_info'};
1323}
1324
1325sub accept {
1326  my ( $self, $search ) = @_;
1327  my %prefs;
1328  for my $accept ( split ',', $ENV{'HTTP_ACCEPT'} ) {
1329    ( my $pref ) = $accept =~ m|q=([\d\.]+)|;
1330    ( my $type ) = $accept =~ m|(\S+/[^;]+)|;
1331    next unless $type;
1332    $prefs{$type} = $pref || 1;
1333  }
1334  return keys %prefs unless $search;
1335  return $prefs{$search} if $prefs{$search};
1336
1337  # Didn't get it, so try pattern matching.
1338  for my $pref ( keys %prefs ) {
1339    next unless $pref =~ m/\*/;    # not a pattern match
1340    ( my $pat = $pref ) =~ s/([^\w*])/\\$1/g;   # escape meta characters
1341    $pat =~ s/\*/.*/g;                          # turn it into a pattern
1342    return $prefs{$pref} if $search =~ /$pat/;
1343  }
1344}
1345
1346sub Accept { my $self = shift; $self->accept( @_ ) }
1347
1348sub http {
1349  my ( $self, $parameter ) = @_;
1350  if ( defined $parameter ) {
1351    ( $parameter = uc $parameter ) =~ tr/-/_/;
1352    return $ENV{$parameter} if $parameter =~ m/^HTTP/;
1353    return $ENV{"HTTP_$parameter"} if $parameter;
1354  }
1355  return grep { /^HTTP/ } keys %ENV;
1356}
1357
1358sub https {
1359  my ( $self, $parameter ) = @_;
1360  return $ENV{'HTTPS'} unless $parameter;
1361  ( $parameter = uc $parameter ) =~ tr/-/_/;
1362  return $ENV{$parameter} if $parameter =~ /^HTTPS/;
1363  return $ENV{"HTTPS_$parameter"};
1364}
1365
1366sub protocol {
1367  local ( $^W ) = 0;
1368  my $self = shift;
1369  return 'https' if uc $ENV{'HTTPS'} eq 'ON';
1370  return 'https' if $self->server_port == 443;
1371  my ( $protocol, $version ) = split '/', $self->server_protocol;
1372  return lc $protocol;
1373}
1374
1375sub url {
1376  my ( $self, @p ) = @_;
1377  use CGI::Simple::Util 'rearrange';
1378  my ( $relative, $absolute, $full, $path_info, $query, $base )
1379   = rearrange(
1380    [
1381      'RELATIVE', 'ABSOLUTE', 'FULL',
1382      [ 'PATH',  'PATH_INFO' ],
1383      [ 'QUERY', 'QUERY_STRING' ], 'BASE'
1384    ],
1385    @p
1386   );
1387  my $url;
1388  $full++ if $base || !( $relative || $absolute );
1389  my $path        = $self->path_info;
1390  my $script_name = $self->script_name;
1391  if ( $full ) {
1392    my $protocol = $self->protocol();
1393    $url = "$protocol://";
1394    my $vh = $self->http( 'host' );
1395    if ( $vh ) {
1396      $url .= $vh;
1397    }
1398    else {
1399      $url .= server_name();
1400      my $port = $self->server_port;
1401      $url .= ":" . $port
1402       unless ( lc( $protocol ) eq 'http' && $port == 80 )
1403       or ( lc( $protocol ) eq 'https' && $port == 443 );
1404    }
1405    return $url if $base;
1406    $url .= $script_name;
1407  }
1408  elsif ( $relative ) {
1409    ( $url ) = $script_name =~ m!([^/]+)$!;
1410  }
1411  elsif ( $absolute ) {
1412    $url = $script_name;
1413  }
1414  $url .= $path if $path_info and defined $path;
1415  $url .= "?" . $self->query_string if $query and $self->query_string;
1416  $url = '' unless defined $url;
1417  $url
1418   =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/uc sprintf("%%%02x",ord($1))/eg;
1419  return $url;
1420}
1421
1422sub self_url {
1423  my ( $self, @params ) = @_;
1424  return $self->url(
1425    '-path_info' => 1,
1426    '-query'     => 1,
1427    '-full'      => 1,
1428    @params
1429  );
1430}
1431
1432sub state { self_url( @_ ) }    # CGI.pm synonym routine
1433
14341;
1435
Note: See TracBrowser for help on using the browser.