File Coverage

lib/CGI/Lite.pm
Criterion Covered Total %
statement 335 352 95.1
branch 157 168 93.4
condition 44 48 91.6
subroutine 41 42 97.6
pod 31 31 100.0
total 608 641 94.8


line stmt bran cond sub pod time code
1             ##++
2             ## CGI Lite v3.02
3             ##
4             ## see separate CHANGES file for detailed history
5             ##
6             ## Changes in versions 2.03 and newer copyright
7             ## (c) 2014-2015, 2017-2018, 2021 Pete Houston
8             ##
9             ## Copyright (c) 1995, 1996, 1997 by Shishir Gundavaram
10             ## All Rights Reserved
11             ##
12             ## Permission to use, copy, and distribute is hereby granted,
13             ## providing that the above copyright notice and this permission
14             ## appear in all copies and in supporting documentation.
15             ##--
16              
17             ###############################################################################
18              
19             =head1 NAME
20              
21             CGI::Lite - Process and decode WWW forms and cookies
22              
23             =head1 SYNOPSIS
24              
25             use CGI::Lite ();
26              
27             my $cgi = CGI::Lite->new ();
28              
29             $cgi->set_directory ('/some/dir') or die "Directory cannot be set.\n";
30             $cgi->add_mime_type ('text/csv');
31              
32             my $cookies = $cgi->parse_cookies;
33             my $form = $cgi->parse_new_form_data;
34              
35             my $status = $cgi->is_error;
36             if ($status) {
37             my $message = $cgi->get_error_message;
38             die $message;
39             }
40              
41             =head1 DESCRIPTION
42              
43             This module can be used to decode form data, query strings, file uploads
44             and cookies in a very simple manner.
45              
46             It has only one dependency and is therefore relatively fast to
47             instantiate. This makes it well suited to a non-persistent CGI scenario.
48              
49             =head1 METHODS
50              
51             Here are the methods used to process the forms and cookies:
52              
53              
54              
55             =head2 new
56              
57             The constructor takes no arguments and returns a new CGI::Lite object.
58              
59             =head2 parse_form_data
60              
61             This handles the following types of requests: GET, HEAD and POST.
62             By default, CGI::Lite uses the environment variable REQUEST_METHOD to
63             determine the manner in which the query/form information should be
64             decoded. However, it may also be passed a valid request
65             method as a scalar string to force CGI::Lite to decode the information in
66             a specific manner.
67              
68             my $params = $cgi->parse_form_data ('GET');
69              
70             For multipart/form-data, uploaded files are stored in the user selected
71             directory (see L). If timestamp mode is on (see
72             L), the files are named in the following format:
73              
74             timestamp__filename
75              
76             where the filename is specified in the "Content-disposition" header.
77             I, the browser URL encodes the name of the file. This module
78             makes I effort to decode the information for security reasons.
79             However, this can be achieved by creating a subroutine and then using
80             the L method.
81              
82             Returns either a hash or a reference to the hash, which contains
83             all of the key/value pairs. For fields that contain file information,
84             the value contains either the path to the file, or the filehandle
85             (see the L method).
86              
87             =head2 parse_new_form_data
88              
89             As for parse_form_data, but clears the CGI object state before processing
90             the request. This is useful in persistent applications (e.g. FCGI), where
91             the CGI object is reused for multiple requests. e.g.
92              
93             my $CGI = CGI::Lite->new ();
94             while (FCGI::accept > 0)
95             {
96             my $query = $CGI->parse_new_form_data ();
97             # process query
98             }
99              
100             =head2 parse_cookies
101              
102             Decodes and parses cookies passed by the browser. This method works in
103             much the same manner as L. As these two data sources
104             are treated the same internally, users who wish to extract form and
105             cookie data separately might find it easiest to call
106             parse_cookies first and then parse_new_form_data in order to retrieve
107             two distinct hashes (or hashrefs).
108              
109             =head2 is_error
110              
111             This method is used to check for any potential errors after calling
112             either L or L.
113              
114             my $form = $cgi->parse_form_data ();
115             my $went_wrong = $cgi->is_error ();
116              
117             Returns 0 if there is no error, 1 otherwise.
118              
119             =head2 get_error_message
120              
121             If an error occurs when parsing form/query information or cookies, this
122             method may be used to retrieve the error message. Remember, the presence
123             of any errors can be checked by calling the L method.
124              
125             my $msg = $cgi->get_error_message ();
126              
127             Returns the error message as a plain text string.
128              
129             =head2 set_platform
130              
131             This method is used to set the platform on which the web server is
132             running. CGI::Lite uses this information to translate end-of-line
133             (EOL) characters for uploaded files (see the L and
134             L methods) so that they are accounted for properly on
135             that platform.
136              
137             $cgi->set_platform ($platform);
138              
139             $platform can be any of (case insensitive):
140              
141             Unix EOL: \012 = \n
142             Windows, Windows95, DOS, NT, PC EOL: \015\012 = \r\n
143             Mac or Macintosh EOL: \015 = \r
144              
145             "Unix" is the default.
146              
147             Returns undef.
148              
149             =head2 set_size_limit
150              
151             To set a specific limit on the total size of the request (in bytes) call
152             this method with that size as the sole argument. A size of zero
153             effectively disables POST requests. To specify an unlimited size (the
154             default) use an argument of -1.
155              
156             my $size_limit = $cgi->set_size_limit (10_000_000);
157              
158             Returns the new value if provided, otherwise the existing value.
159              
160             =head2 deny_uploads
161              
162             To prevent any file uploads simply call this method with an argument of
163             1. To enable them again, use an argument of zero.
164              
165             my $deny_uploads = $cgi->deny_uploads (1);
166              
167             Returns the new value if provided, otherwise the existing value.
168              
169             =head2 force_unique_cookies
170              
171             It is generally considered a mistake to send an HTTP request with
172             multiple cookies of the same name. However, the RFC is somewhat vague
173             regarding how servers are expected to handle such an eventuality.
174             CGI::Lite has always allowed such multiple values and returned them as
175             an arrayref to be entirely consistent with the same treatment of
176             form/query data.
177              
178             To override the default behaviour this method may be called with a
179             single integer argument before the call to L. An argument
180             of 1 means that the first cookie value will be used and the others
181             discarded. An argument of 2 means that the last cookie value will be
182             used and the others discarded. An argument of 3 means that an arrayref
183             will be returned as usual but an error raised to indicate the situation.
184             An argument of 0 (or any other value) sets it back to the default.
185              
186             $cgi->force_unique_cookies (1);
187             $cgi->parse_cookies;
188              
189             Note that if there is already an item of data in the CGI::Lite object
190             which matches the name of a cookie then the subsequent L
191             call will treat the new cookie value as another data item and the resulting
192             behaviour will be affected by this method. This is another reason to
193             call L before L.
194              
195             Returns the new value if provided, otherwise the existing value.
196              
197             =head2 set_directory
198              
199             Used to set the directory where the uploaded files will be stored
200             (only applies to the I encoding scheme).
201              
202             my $tmpdir = '/some/dir';
203             $cgi->set_directory ($tmpdir) or
204             die "Directory $tmpdir cannot be used.\n";
205              
206             This function should be called I L,
207             or else the directory defaults to "/tmp". If the application cannot
208             write to the directory for whatever reason, an error status is returned.
209              
210             Returns 0 on error, 1 otherwise.
211              
212             =head2 close_all_files
213              
214             $cgi->close_all_files;
215              
216             All uploaded files that are opened as a result of calling L
217             with the "handle" argument can be closed in one shot by calling this
218             method which takes no arguments and returns undef.
219              
220             =head2 add_mime_type
221              
222             By default, EOL characters are translated for all uploaded files
223             with specific MIME types (i.e. text/plain, text/html, etc.).
224             This method can be used to add to the list of MIME types. For example,
225             if you want CGI::Lite to translate EOL characters for uploaded
226             files of I, then you would do this:
227              
228             $cgi->add_mime_type ('application/mac-binhex40');
229              
230             Returns 1 if this MIME type is newly added, 0 otherwise.
231              
232             =head2 remove_mime_type
233              
234             This method is the converse of L. It allows for the
235             removal of a particular MIME type. For example, if you do not want
236             CGI::Lite to translate EOL characters for uploaded files of type I,
237             then you would do this:
238              
239             $cgi->remove_mime_type ('text/html');
240              
241             Returns 1 if this MIME type is newly deleted, 0 otherwise.
242              
243             =head2 get_mime_types
244              
245             Returns the list of the
246             MIME types for which EOL translation is performed.
247              
248             my @mimelist = $cgi->get_mime_types ();
249              
250             =head2 get_upload_type
251              
252             Returns the MIME type of uploaded data. Takes the field name as a scalar
253             argument. This previously undocumented function was named print_mime_type
254             prior to version 3.0.
255              
256             my $this_type = $cgi->get_upload_type ($field);
257              
258             Returns the MIME type as a scalar string if single valued, an arrayref
259             if multi-valued or undef if the argument does not exist or has no type.
260              
261             =head2 set_file_type
262              
263             The I of uploaded files are returned by default when
264             the L method is called . But if this method is passed the string "handle" as its argument beforehand then
265             the I to the files are returned instead. However, the name
266             of each handle still corresponds to the filename.
267              
268             # $fh has been set to one of 'handle' or 'file'
269             $cgi->set_file_type ($fh);
270              
271             This function should be called I any call to L, or
272             else it will have no effect.
273              
274             =head2 add_timestamp
275              
276             By default, a timestamp is added to the front of uploaded files.
277             However, there is the option of completely turning off timestamp mode
278             (value 0), or adding a timestamp only for existing files (value 2).
279              
280             $cgi->add_timestamp ($tsflag);
281             # where $tsflag takes one of these values
282             # 0 = no timestamp
283             # 1 = timestamp all files (default)
284             # 2 = timestamp only if file exists
285              
286             =head2 filter_filename
287              
288             This method is used to change the manner in which uploaded
289             files are named. For example, if you want uploaded filenames
290             to be all upper case, you can use the following code:
291              
292             $cgi->filter_filename (\&make_uppercase);
293             $cgi->parse_form_data;
294              
295             # ...
296              
297             sub make_uppercase
298             {
299             my $file = shift;
300              
301             $file =~ tr/a-z/A-Z/;
302             return $file;
303             }
304              
305             This method is perhaps best used to sanitise filenames for a specific
306             O/S or filesystem e.g. by removing spaces or leading hyphens, etc.
307              
308             =head2 set_buffer_size
309              
310             This method allows fine-grained control of the buffer size used internally
311             when dealing with multipart form data. However, the I buffer
312             size that the algorithm uses I be up to 3x the value specified
313             as the argument. This ensures that boundary strings are not "split"
314             between multiple reads. So, take this into consideration when setting
315             the buffer size.
316              
317             my $size = $cgi->set_buffer_size (4096);
318              
319             The buffer size may not be set below 256 bytes nor above the total amount
320             of multipart form data. The default value is 1024 bytes.
321              
322             Returns the buffer size.
323              
324             =head2 get_ordered_keys
325              
326             Returns either a reference to an array or an array itself consisting
327             of the form fields/cookies in the order they were parsed.
328              
329             my $keys = $cgi->get_ordered_keys;
330             my @keys = $cgi->get_ordered_keys;
331              
332             =head2 print_data
333              
334             Displays all the key/value pairs (either form data or cookie information)
335             in an ordered fashion to standard output. It is mainly useful for
336             debugging. There are no arguments and no return values.
337              
338             =head2 wrap_textarea
339              
340             This is a method to wrap a long string into one that is separated by EOL
341             characters (see L) at fixed lengths. The two arguments
342             to be passed to this method are the string and the length at which the
343             line separator is to be added.
344              
345             my $new_string = $cgi->wrap_textarea ($string, $length);
346              
347             Returns the modified string.
348              
349             =head2 get_multiple_values
350              
351             The values returned by the parsing methods in this module for multiple
352             fields with the same name are given as array references. This utility
353             method exists to convert either a scalar value or an array reference
354             into a list thus removing the need for the user to determine whether the
355             returned value for any field is a reference or a scalar.
356              
357             @all_values = $cgi->get_multiple_values ($reference);
358              
359             It is only provided as a convenience to the user and is not used
360             internally by the module itself.
361              
362             Returns a list consisting of the multiple values.
363              
364             =head2 browser_escape
365              
366             Certain characters have special significance within HTML. These
367             characters are: <, >, &, ", # and %. To display these "special"
368             characters, they can be escaped using the following notation "&#NNN;"
369             where NNN is their ASCII code. This utility method does just that.
370              
371             $escaped_string = $cgi->browser_escape ($string);
372              
373             Returns the escaped string.
374              
375             =head2 url_encode
376              
377             This method will URL-encode a string passed as its argument. It may be
378             used to encode any data to be passed as a query string to a CGI
379             application, for example.
380              
381             $encoded_string = $cgi->url_encode ($string);
382              
383             Returns the URL-encoded string.
384              
385             =head2 url_decode
386              
387             This method is used to URL-decode a string.
388              
389             $decoded_string = $cgi->url_decode ($string);
390              
391             Returns the URL-decoded string.
392              
393             =head2 is_dangerous
394              
395             This method checks for the existence of dangerous meta-characters.
396              
397             $status = $cgi->is_dangerous ($string);
398              
399             Returns 1 if such characters are found, 0 otherwise.
400              
401              
402              
403             =head1 DEPRECATED METHODS
404              
405             The following methods and subroutines are deprecated. Please do not use
406             them in new code and consider excising them from old code. They will be
407             removed in a future release.
408              
409             =over 4
410              
411             =item B
412              
413             $cgi->return_error ('error 1', 'error 2', 'error 3');
414              
415             You can use this method to print errors to standard output (ie. as part of
416             the HTTP response) and exit. B
417             The same functionality can be achieved with:
418              
419             print ('error 1', 'error 2', 'error 3');
420             exit 1;
421              
422             =item B
423              
424             B It runs contrary to the
425             principles of structured programming and has really nothing to do with
426             CGI form or cookie handling. It is retained here for backwards
427             compatibility but will be removed entirely in later versions.
428              
429             %form = ('name' => 'alan wells',
430             'sport' => 'track and field',
431             'events' => '100m');
432              
433             $cgi->create_variables (\%hash);
434              
435             This converts a hash ref into scalars named for its keys and this
436             example will create three scalar variables: $name, $sport and $events.
437              
438             =back
439              
440             =head1 OBSOLETE METHODS/SUBROUTINES
441              
442             The following methods and subroutines were deprecated in the 2.x branch
443             and have now been removed entirely from the module.
444              
445             =over 4
446              
447             =item B
448              
449             The use of this subroutine had been strongly discouraged for more than a
450             decade (See
451             L
452             and L for an
453             advisory by Ronald F. Guilmette.) It has been removed as of version 3.0.
454              
455             =item B
456              
457             Use L instead.
458              
459             =item B
460              
461             Use L instead.
462              
463             =back
464              
465             Compatibility note: in 2.x and older versions the following were to be used as
466             subroutines rather than methods:
467              
468             =over 4
469              
470             =item browser_escape
471              
472             =item url_encode
473              
474             =item url_decode
475              
476             =item is_dangerous
477              
478             =back
479              
480             They will still work as such and are still exported
481             by default. Users are encouraged to migrate to the new method calls
482             instead as both the export and subroutine interface will be retired in
483             future. Non-method use currently triggers a warning.
484              
485             =head1 VERSIONS
486              
487             This module maintained backwards compatibility with versions of
488             Perl back to 5.002 for a very long time. Such stability is a welcome
489             attribute but it restricts the code by disallowing access to features
490             introduced into the language since 1996.
491              
492             With this in mind, there are two maintained branches of this module going
493             forwards. The 2.x branch will retain the backwards compatibility but
494             will not have any new features introduced. Changes to this legacy branch
495             will be bug fixes only. The new 3.x branch will be the main release and
496             will require a more modern perl (5.6.0 is now the bare minimum). The
497             3.x branch has new features and has removed some of the legacy code
498             including some methods which had been deprecated for more than a decade.
499             The attention of users wishing to upgrade from 2.x to 3.x is drawn to
500             the L and L sections of this
501             document.
502              
503             Requests for new features in the 3.x branch should be made via
504             the request tracker at L
505              
506             =head1 SEE ALSO
507              
508             If you're looking for more comprehensive CGI modules, you can either use
509             the CGI::* modules or L.
510              
511             L uses some similar method names to CGI.pm thus allowing
512             easy transition between the two. It uses CGI::Lite as a dependency.
513              
514             L, L and L are alternative
515             lightweight CGI implementations.
516              
517             =head1 REPOSITORY
518              
519             L
520              
521             =head1 MAINTAINER
522              
523             Maintenance of this module as of May 2014 has been taken over by Pete Houston
524             .
525              
526             =head1 ACKNOWLEDGMENTS
527              
528             The author (Shishir) thanks the following for finding bugs
529             and offering suggestions:
530              
531             =over 4
532              
533             =item Eric D. Friedman
534              
535             =item Thomas Winzig
536              
537             =item Len Charest
538              
539             =item Achim Bohnet
540              
541             =item John E. Townsend
542              
543             =item Andrew McRae
544              
545             =item Dennis Grant
546              
547             =item Scott Neufeld
548              
549             =item Raul Almquist
550              
551             =item and many others!
552              
553             =back
554              
555             The present maintainer wishes to thank the previous maintainers:
556             Smylers, Andreas, Ben and Shishir.
557              
558             =head1 COPYRIGHT INFORMATION
559            
560             Copyright (c) 1995, 1996, 1997 by Shishir Gundavaram.
561             All Rights Reserved.
562              
563             Changes in versions 2.03 onwards are copyright 2014, 2015, 2017, 2018, 2021
564             by Pete Houston.
565              
566             Permission to use, copy, and distribute is hereby granted,
567             providing that the above copyright notice and this permission
568             appear in all copies and in supporting documentation.
569              
570             =head1 LICENCE
571              
572             This program is free software; you can redistribute it and/or modify it
573             under the same terms as Perl itself.
574              
575             =cut
576              
577             ###############################################################################
578              
579             package CGI::Lite;
580              
581 4     4   286497 use strict;
  4         35  
  4         119  
582 4     4   18 use warnings;
  4         7  
  4         130  
583              
584             require 5.6.0;
585              
586 4     4   1883 use Symbol; # For _create_handles and create_variables
  4         3228  
  4         363  
587              
588             ##++
589             ## Global Variables
590             ##--
591              
592             BEGIN {
593 4     4   65 our @ISA = 'Exporter';
594 4         17307 our @EXPORT = qw/browser_escape url_encode url_decode is_dangerous/;
595             }
596              
597             our $VERSION = '3.02_01';
598              
599             ##++
600             ## Start
601             ##--
602              
603             sub new
604             {
605 60     60 1 21856 my $class = shift;
606              
607 60         771 my $self = {
608             multipart_dir => '/tmp',
609             file_type => 'name',
610             platform => 'Unix',
611             buffer_size => 1024,
612             timestamp => 1,
613             filter => undef,
614             web_data => {},
615             ordered_keys => [],
616             all_handles => [],
617             error_status => 0,
618             error_message => undef,
619             file_size_limit => 2097152, # Unused as yet
620             size_limit => -1,
621             deny_uploads => 0,
622             unique_cookies => 0,
623             };
624              
625             $self->{convert} = {
626 60         306 'text/html' => 1,
627             'text/plain' => 1
628             };
629              
630 60         250 $self->{file} = {Unix => '/', Mac => ':', PC => '\\'};
631 60         170 $self->{eol} = {Unix => "\012", Mac => "\015", PC => "\015\012"};
632              
633 60         120 bless ($self, $class);
634 60         372 return $self;
635             }
636              
637             sub Version
638             {
639 1     1 1 767 return $VERSION;
640             }
641              
642             sub deny_uploads
643             {
644 3     3 1 7 my ($self, $newval) = @_;
645 3 100       11 if (defined $newval) {
646 2 100       8 $self->{deny_uploads} = $newval ? 1 : 0;
647             }
648 3         15 return $self->{deny_uploads};
649             }
650              
651             sub set_size_limit
652             {
653 7     7 1 20 my ($self, $limit) = @_;
654 7 100       20 return unless defined $limit;
655 6 100       48 if ($limit =~ /^[0-9]+$/) {
656 3         31 $self->{size_limit} = $limit;
657             } else {
658 3         5 $self->{size_limit} = -1;
659             }
660 6         39 return $self->{size_limit};
661             }
662              
663             sub set_directory
664             {
665 2254     2254 1 11753 my ($self, $directory) = @_;
666              
667 2254 100       5848 return 0 unless $directory;
668 2253         25084 stat ($directory);
669              
670 2253 100 66     33341 if ((-d _) && (-r _) && (-w _)) {
      66        
671 2251         7365 $self->{multipart_dir} = $directory;
672 2251         6947 return (1);
673              
674             } else {
675 2         14 return (0);
676             }
677             }
678              
679             sub add_mime_type
680             {
681 3     3 1 2018 my ($self, $mime_type) = @_;
682              
683 3 100 100     19 if ($mime_type and not exists $self->{convert}->{$mime_type}) {
684 1         5 return $self->{convert}->{$mime_type} = 1;
685             }
686 2         8 return 0;
687             }
688              
689             sub remove_mime_type
690             {
691 2     2 1 6 my ($self, $mime_type) = @_;
692              
693 2 100       9 if ($self->{convert}->{$mime_type}) {
694 1         3 delete $self->{convert}->{$mime_type};
695 1         6 return (1);
696              
697             } else {
698 1         5 return (0);
699             }
700             }
701              
702             sub get_mime_types
703             {
704 3     3 1 6 my $self = shift;
705              
706 3         5 return (sort keys %{$self->{convert}});
  3         28  
707             }
708              
709             sub set_platform
710             {
711 11     11 1 3323 my ($self, $platform) = @_;
712              
713 11 100       25 return unless defined $platform;
714 10 100       50 if ($platform =~ /^(?:PC|NT|Windows(?:95)?|DOS)/i) {
    100          
715 6         19 $self->{platform} = 'PC';
716             } elsif ($platform =~ /^Mac(?:intosh)?/i) {
717 3         6 $self->{platform} = 'Mac';
718             } else {
719 1         2 $self->{platform} = 'Unix';
720             }
721             }
722              
723             sub set_file_type
724             {
725 3     3 1 10 my ($self, $type) = @_;
726              
727 3 100       16 if ($type =~ /^handle$/i) {
728 1         3 $self->{file_type} = 'handle';
729             } else {
730 2         8 $self->{file_type} = 'name';
731             }
732             }
733              
734             sub add_timestamp
735             {
736 5     5 1 2269 my ($self, $value) = @_;
737              
738 5 100 66     43 unless ($value == 0 or $value == 1 or $value == 2) {
      100        
739 2         5 $self->{timestamp} = 1;
740             } else {
741 3         12 $self->{timestamp} = $value;
742             }
743             }
744              
745             sub force_unique_cookies
746             {
747 6     6 1 24 my ($self, $value) = @_;
748              
749 6 100       15 if (defined $value) {
750 5 100       26 if ($value =~ /^[1-3]$/) {
751 3         7 $self->{unique_cookies} = $value;
752             } else {
753 2         5 $self->{unique_cookies} = 0;
754             }
755             }
756 6         26 return $self->{unique_cookies};
757             }
758              
759             sub filter_filename
760             {
761 1     1 1 4 my ($self, $subroutine) = @_;
762              
763 1         3 $self->{filter} = $subroutine;
764             }
765              
766             sub set_buffer_size
767             {
768 2243     2243 1 6398 my ($self, $buffer_size) = @_;
769 2243         4004 my $content_length;
770              
771 2243   100     9092 $content_length = $ENV{CONTENT_LENGTH} || return (0);
772              
773 2242 100       11304 if ($buffer_size < 256) {
    100          
774 1         4 $self->{buffer_size} = 256;
775             } elsif ($buffer_size > $content_length) {
776 37         70 $self->{buffer_size} = $content_length;
777             } else {
778 2204         4980 $self->{buffer_size} = $buffer_size;
779             }
780              
781 2242         4712 return ($self->{buffer_size});
782             }
783              
784             sub parse_new_form_data
785              
786             # Reset state before parsing (for persistant CGI objects, e.g. under FastCGI)
787             # BDL
788             {
789 2257     2257 1 4778 my ($self, @param) = @_;
790              
791             # close files (should happen anyway when 'all_handles' is cleared...)
792 2257         7479 $self->close_all_files ();
793              
794 2257         7116 $self->{web_data} = {};
795 2257         7930 $self->{ordered_keys} = [];
796 2257         4149 $self->{all_handles} = [];
797 2257         3531 $self->{error_status} = 0;
798 2257         3278 $self->{error_message} = undef;
799              
800 2257         5957 $self->parse_form_data (@param);
801             }
802              
803             sub parse_form_data
804             {
805 2267     2267 1 4244 my ($self, $user_request) = @_;
806 2267         3498 my ($request_method, $content_length, $content_type, $query_string,
807             $boundary, $post_data, @query_input);
808              
809             # Force into object method
810 2267 100       5506 unless (ref ($self)) { $self = $self->new; }
  1         5  
811 2267   100     12188 $request_method = $user_request || $ENV{REQUEST_METHOD} || '';
812 2267   100     6507 $content_length = $ENV{CONTENT_LENGTH} || 0;
813 2267         3940 $content_type = $ENV{CONTENT_TYPE};
814              
815             # If we've set a size limit, check that it has not been exceeded
816 2267 100 100     8537 if ($self->{size_limit} > -1 and $content_length > $self->{size_limit}) {
817             $self->_error ("Content lenth $content_length exceeds limit of "
818 1         9 . $self->{size_limit});
819 1         3 return;
820             }
821              
822 2266 100       17815 if ($request_method =~ /^(get|head)$/i) {
    100          
823              
824 5         10 $query_string = $ENV{QUERY_STRING};
825 5         19 $self->_decode_url_encoded_data (\$query_string, 'form');
826              
827 5 100       34 return wantarray ? %{$self->{web_data}} : $self->{web_data};
  1         7  
828              
829             } elsif ($request_method =~ /^post$/i) {
830              
831 2259 100 100     13487 if (!$content_type
    100          
832             || ($content_type =~ /^application\/x-www-form-urlencoded/)) {
833              
834 6         116 read (STDIN, $post_data, $content_length);
835 6         34 $self->_decode_url_encoded_data (\$post_data, 'form');
836              
837 6 100       25 return wantarray ? %{$self->{web_data}} : $self->{web_data};
  1         8  
838              
839             } elsif ($content_type =~ /multipart\/form-data/) {
840              
841 2252 100       5844 if ($self->{deny_uploads}) {
842 1         7 $self->_error ("multipart/form-data unacceptable when "
843             . "deny_uploads is set");
844 1         4 return;
845             }
846 2251         11479 ($boundary) = $content_type =~ /boundary=(\S+)$/;
847 2251         7622 $self->_parse_multipart_data ($content_length, $boundary);
848              
849 2251 100       13694 return wantarray ? %{$self->{web_data}} : $self->{web_data};
  1         14  
850              
851             } else {
852 1         5 $self->_error ('Invalid content type!');
853             }
854              
855             } else {
856              
857             ##++
858             ## Got the idea of interactive debugging from CGI.pm, though it's
859             ## handled a bit differently here. Thanks Lincoln!
860             ##--
861              
862 2         25 print "[ Reading query from standard input. Press ^D to stop! ]\n";
863              
864 2         158 @query_input = <>;
865 2         9 chomp (@query_input);
866              
867 2         8 $query_string = join ('&', @query_input);
868 2         11 $query_string =~ s/\\(.)/sprintf ('%%%02X', ord ($1))/eg;
  6         24  
869              
870 2         7 $self->_decode_url_encoded_data (\$query_string, 'form');
871              
872 2 100       9 return wantarray ? %{$self->{web_data}} : $self->{web_data};
  1         7  
873             }
874             }
875              
876             sub parse_cookies
877             {
878 45     45 1 223 my $self = shift;
879 45         57 my $cookies;
880              
881 45   100     179 $cookies = $ENV{HTTP_COOKIE} || return;
882              
883 44         200 $self->_decode_url_encoded_data (\$cookies, 'cookies');
884              
885 44 100       194 return wantarray ? %{$self->{web_data}} : $self->{web_data};
  1         5  
886             }
887              
888             sub get_ordered_keys
889             {
890 4     4 1 1399 my $self = shift;
891              
892 4 100       14 return wantarray ? @{$self->{ordered_keys}} : $self->{ordered_keys};
  2         11  
893             }
894              
895             sub print_data
896             {
897 2     2 1 1268 my $self = shift;
898              
899 2         10 my $eol = $self->{eol}->{$self->{platform}};
900              
901 2         4 foreach my $key (@{$self->{ordered_keys}}) {
  2         7  
902 5         14 my $value = $self->{web_data}->{$key};
903              
904 5 100       13 if (ref $value) {
905 1         23 print "$key = @$value$eol";
906             } else {
907 4         31 print "$key = $value$eol";
908             }
909             }
910             }
911              
912             sub get_upload_type
913             {
914 2     2 1 9 my ($self, $field) = @_;
915              
916 2         10 return ($self->{'mime_types'}->{$field});
917             }
918              
919             sub wrap_textarea
920             {
921 4     4 1 6 my ($self, $string, $length) = @_;
922 4         5 my ($new_string, $platform, $eol);
923              
924 4 100       7 $length = 70 unless ($length);
925 4         5 $platform = $self->{platform};
926 4         8 $eol = $self->{eol}->{$platform};
927 4   100     10 $new_string = $string || return;
928              
929 3         6 $new_string =~ s/[\0\r]\n?/ /sg;
930 3         44 $new_string =~ s/(.{0,$length})\s/$1$eol/sg;
931              
932 3         15 return $new_string;
933             }
934              
935             sub get_multiple_values
936             {
937 4     4 1 8 my ($self, $array) = @_;
938              
939 4 100       17 return (ref $array) ? (@$array) : $array;
940             }
941              
942             sub create_variables
943             {
944 1     1 1 2 my ($self, $hash) = @_;
945 1         2 my ($package, $key, $value);
946              
947 1         3 $package = $self->_determine_package;
948              
949 1         5 while (($key, $value) = each %$hash) {
950 2         6 my $this = Symbol::qualify_to_ref ($key, $package);
951 2         42 $$$this = $value;
952             }
953             }
954              
955             sub is_error
956             {
957 2312     2312 1 48590 my $self = shift;
958              
959 2312 100       6533 if ($self->{error_status}) {
960 5         51 return (1);
961             } else {
962 2307         13736 return (0);
963             }
964             }
965              
966             sub get_error_message
967             {
968 2     2 1 5 my $self = shift;
969              
970 2 100       14 return $self->{error_message} if ($self->{error_message});
971             }
972              
973             sub return_error
974             {
975 0     0 1 0 my ($self, @messages) = @_;
976              
977 0         0 print "@messages\n";
978              
979 0         0 exit (1);
980             }
981              
982             ##++
983             ## Exported Subroutines and Methods
984             ##--
985              
986             sub browser_escape
987             {
988 1     1 1 412 my ($self, $string) = @_;
989              
990 1 50       2 unless (eval { $self->isa ('CGI::Lite'); }) {
  1         10  
991 0         0 my @rep = caller;
992 0         0 warn "Non-method use of browser_escape is deprecated "
993             . "in $rep[0] at line $rep[2] of $rep[1]\n";
994 0         0 $string = $self;
995             }
996 1         7 $string =~ s/([<&"#%>])/sprintf ('&#%d;', ord ($1))/ge;
  3         10  
997              
998 1         5 return $string;
999             }
1000              
1001             sub url_encode
1002             {
1003 14     14 1 5735 my ($self, $string) = @_;
1004              
1005 14 50       14 unless (eval { $self->isa ('CGI::Lite'); }) {
  14         45  
1006 0         0 my @rep = caller;
1007 0         0 warn "Non-method use of url_encode is deprecated "
1008             . "in $rep[0] at line $rep[2] of $rep[1]\n";
1009 0         0 $string = $self;
1010             }
1011              
1012 14         64 $string =~ s/([^-.\w ])/sprintf('%%%02X', ord $1)/ge;
  12         49  
1013 14         24 $string =~ tr/ /+/;
1014              
1015 14         46 return $string;
1016             }
1017              
1018             sub url_decode
1019             {
1020 274     274 1 387 my ($self, $string) = @_;
1021              
1022 274 50       319 unless (eval { $self->isa ('CGI::Lite'); }) {
  274         806  
1023 0         0 my @rep = caller;
1024 0         0 warn "Non-method use of url_decode is deprecated "
1025             . "in $rep[0] at line $rep[2] of $rep[1]\n";
1026 0         0 $string = $self;
1027             }
1028              
1029 274         433 $string =~ tr/+/ /;
1030 274         642 $string =~ s/%([\da-fA-F]{2})/chr (hex ($1))/eg;
  89         346  
1031              
1032 274         508 return $string;
1033             }
1034              
1035             sub is_dangerous
1036             {
1037 256     256 1 107050 my ($self, $string) = @_;
1038              
1039 256 50       290 unless (eval { $self->isa ('CGI::Lite'); }) {
  256         789  
1040 0         0 my @rep = caller;
1041 0         0 warn "Non-method use of is_dangerous is deprecated "
1042             . "in $rep[0] at line $rep[2] of $rep[1]\n";
1043 0         0 $string = $self;
1044             }
1045              
1046 256 100       690 if ($string =~ /[;<>\*\|`&\$!#\(\)\[\]\{\}:'"]/) {
1047 19         61 return (1);
1048             } else {
1049 237         660 return (0);
1050             }
1051             }
1052              
1053             ##++
1054             ## Internal Methods
1055             ##--
1056              
1057             sub _error
1058             {
1059 8     8   27 my ($self, $message) = @_;
1060              
1061 8         16 $self->{error_status} = 1;
1062 8         106 $self->{error_message} = $message;
1063             }
1064              
1065             sub _determine_package
1066             {
1067 2     2   5 my $self = shift;
1068 2         4 my ($frame, $this_package, $find_package);
1069              
1070 2         4 $frame = -1;
1071 2         11 ($this_package) = split (/=/, $self);
1072              
1073 2         6 do {
1074 7         59 $find_package = caller (++$frame);
1075             } until ($find_package !~ /^$this_package/);
1076              
1077 2         5 return ($find_package);
1078             }
1079              
1080             ##++
1081             ## Decode URL encoded data
1082             ##--
1083              
1084             sub _decode_url_encoded_data
1085             {
1086 57     57   180 my ($self, $reference_data, $type) = @_;
1087 57 100       139 return unless ($$reference_data);
1088              
1089 55         80 my (@key_value_pairs, $delimiter);
1090              
1091 55         84 @key_value_pairs = ();
1092              
1093 55 100       161 if ($type eq 'cookies') {
1094 44         251 $delimiter = qr/[;,]\s*/;
1095             } else {
1096              
1097             # Only other option is form data
1098 11         60 $delimiter = qr/[;&]/;
1099             }
1100              
1101 55         481 @key_value_pairs = split ($delimiter, $$reference_data);
1102              
1103 55         143 foreach my $key_value (@key_value_pairs) {
1104 132         351 my ($key, $value) = split (/=/, $key_value, 2);
1105              
1106             # avoid 'undef' warnings for "key=" BDL Jan/99
1107 132 100       311 $value = '' unless defined $value;
1108              
1109             # avoid 'undef' warnings for bogus URLs like 'foobar.cgi?&foo=bar'
1110 132 100       225 next unless defined $key;
1111              
1112 130 100       228 if ($type eq 'cookies') {
1113              
1114             # Strip leading/trailling whitespace as per RFC 2965
1115 93         251 $key =~ s/^\s+|\s+$//g;
1116 93         198 $value =~ s/^\s+|\s+$//g;
1117             }
1118              
1119 130         295 $key = $self->url_decode ($key);
1120 130         225 $value = $self->url_decode ($value);
1121              
1122 130 100       275 if (defined ($self->{web_data}->{$key})) {
1123 18 100 100     82 if ($type eq 'cookies' and $self->{unique_cookies} > 0) {
1124 6 100       21 if ($self->{unique_cookies} == 1) {
    100          
1125 2         5 next;
1126             } elsif ($self->{unique_cookies} == 2) {
1127 2         3 $self->{web_data}->{$key} = $value;
1128 2         4 next;
1129             } else {
1130 2         212 $self->_error ("Multiple instances of cookie $key");
1131             }
1132             }
1133             $self->{web_data}->{$key} = [$self->{web_data}->{$key}]
1134 14 100       57 unless (ref $self->{web_data}->{$key});
1135              
1136 14         20 push (@{$self->{web_data}->{$key}}, $value);
  14         44  
1137             } else {
1138 112         226 $self->{web_data}->{$key} = $value;
1139 112         125 push (@{$self->{ordered_keys}}, $key);
  112         307  
1140             }
1141             }
1142              
1143 55         194 return;
1144             }
1145              
1146             ##++
1147             ## Methods dealing with multipart data
1148             ##--
1149              
1150             sub _parse_multipart_data
1151             {
1152 2251     2251   5236 my ($self, $total_bytes, $boundary) = @_;
1153 2251         3580 my $files = {};
1154 2251         22533 my $boundary_re = qr/(.*?)((?:\015?\012)?-*
1155             \Q$boundary\E
1156             -*[\015\012]*)(?=(.*))/xs;
1157              
1158 2251         4811 eval {
1159              
1160 2251         4949 my ($seen, $buffer_size, $byte_count, $platform,
1161             $eol, $handle, $directory, $bytes_left,
1162             $new_data, $old_data, $this_boundary, $current_buffer,
1163             $changed, $store, $disposition, $headers,
1164             $mime_type, $convert, $field, $file,
1165             $new_name, $full_path
1166             );
1167              
1168 2251         3552 $seen = {};
1169 2251         4259 $buffer_size = $self->{buffer_size};
1170 2251         3201 $byte_count = 0;
1171 2251         4438 $platform = $self->{platform};
1172 2251         5005 $eol = $self->{eol}->{$platform};
1173 2251         3125 $directory = $self->{multipart_dir};
1174 2251         2942 $bytes_left = $total_bytes;
1175              
1176 2251         4691 while ($bytes_left) {
1177 12390 100       27113 if ($byte_count < $total_bytes) {
    100          
1178              
1179 6357         8463 $bytes_left = $total_bytes - $byte_count;
1180 6357 100       12777 $buffer_size = $bytes_left if ($bytes_left < $buffer_size);
1181              
1182 6357         47006 read (STDIN, $new_data, $buffer_size);
1183 6357 100       16807 $self->_error ("Oh, Oh! I'm upset! Can't read what I want.")
1184             if (length ($new_data) != $buffer_size);
1185              
1186 6357         7669 $byte_count += $buffer_size;
1187              
1188 6357 100       10440 if ($old_data) {
1189 4104         16309 $current_buffer = join ('', $old_data, $new_data);
1190             } else {
1191 2253         6373 $current_buffer = $new_data;
1192             }
1193              
1194             } elsif ($old_data) {
1195 3782         6030 $current_buffer = $old_data;
1196 3782         4742 $old_data = undef;
1197              
1198             } else {
1199 2251         3918 last;
1200             }
1201              
1202 10139         11842 $changed = 0;
1203              
1204             ##++
1205             ## When Netscape Navigator creates a random boundary string, you
1206             ## would expect it to pass that _same_ value in the environment
1207             ## variable CONTENT_TYPE, but it does not! Instead, it passes a
1208             ## value that has the first two characters ("--") missing.
1209             ##--
1210              
1211 10139 100       573123 if ($current_buffer =~ $boundary_re) {
    50          
1212              
1213 9596         47697 ($store, $this_boundary, $old_data) = ($1, $2, $3);
1214              
1215 9596 100       76261 if ($current_buffer =~
    100          
1216             /[Cc]ontent-[Dd]isposition: ([^\015\012]+)\015?\012 # Disposition
1217             (?:([A-Za-z].*?)(?:\015?\012))? # Headers
1218             (?:\015?\012) # End
1219             (?=(.*)) # Other Data
1220             /xs
1221             ) {
1222              
1223 7281         30531 ($disposition, $headers, $current_buffer) = ($1, $2, $3);
1224 7281         12388 $old_data = $current_buffer;
1225              
1226 7281   50     14289 $headers ||= '';
1227 7281         26975 ($mime_type) = $headers =~ /[Cc]ontent-[Tt]ype: (\S+)/;
1228              
1229 7281         26284 $self->_store ($platform, $file, $convert, $handle, $eol,
1230             $field, \$store, $seen);
1231              
1232 7281 100 100     172787 close ($handle) if (ref ($handle) and fileno ($handle));
1233              
1234 7281 100 100     38601 if ($mime_type && $self->{convert}->{$mime_type}) {
1235 3502         5011 $convert = 1;
1236             } else {
1237 3779         5362 $convert = 0;
1238             }
1239              
1240 7281         7708 $changed = 1;
1241              
1242 7281         41683 ($field) = $disposition =~ /name="([^"]+)"/;
1243 7281         22530 ++$seen->{$field};
1244              
1245 7281 100       25348 unless ($self->{'mime_types'}->{$field}) {
    100          
1246 1266         2680 $self->{'mime_types'}->{$field} = $mime_type;
1247 0         0 } elsif (ref $self->{'mime_types'}->{$field}) {
1248 5999         7012 push @{$self->{'mime_types'}->{$field}}, $mime_type;
  5999         18006  
1249             } else {
1250             $self->{'mime_types'}->{$field} =
1251 16         47 [$self->{'mime_types'}->{$field}, $mime_type];
1252             }
1253              
1254 7281 100       13977 if ($seen->{$field} > 1) {
1255             $self->{web_data}->{$field} =
1256             [$self->{web_data}->{$field}]
1257 23 100       78 unless (ref $self->{web_data}->{$field});
1258             } else {
1259 7258         7528 push (@{$self->{ordered_keys}}, $field);
  7258         13255  
1260             }
1261              
1262 7281 100       33458 if (($file) = $disposition =~ /filename="(.*)"/) {
1263 7257         20480 $file =~ s|.*[:/\\](.*)|$1|;
1264              
1265 7257         18534 $new_name =
1266             $self->_get_file_name ($platform, $directory, $file);
1267              
1268 7257 100       17012 if (ref $self->{web_data}->{$field}) {
1269 7         12 push @{$self->{web_data}->{$field}}, $new_name
  7         26  
1270             } else {
1271 7250         12858 $self->{web_data}->{$field} = $new_name;
1272             }
1273              
1274             $full_path =
1275 7257         21616 join ($self->{file}->{$platform}, $directory,
1276             $new_name);
1277              
1278 7257 50       475851 open ($handle, '>', $full_path)
1279             or $self->_error ("Can't create file: $full_path!");
1280              
1281 7257         44291 $files->{$new_name} = $full_path;
1282             }
1283             } elsif ($byte_count < $total_bytes) {
1284 64         172 $old_data = $this_boundary . $old_data;
1285             }
1286              
1287             } elsif ($old_data) {
1288 543         954 $store = $old_data;
1289 543         703 $old_data = $new_data;
1290             }
1291              
1292 10139 100       26684 unless ($changed) {
1293 2858         8851 $self->_store ($platform, $file, $convert, $handle, $eol,
1294             $field, \$store, $seen);
1295             }
1296             }
1297              
1298 2251 100 100     137736 close ($handle) if ($handle and fileno ($handle));
1299              
1300             }; # End of eval
1301              
1302 2251 50       9725 $self->_error ($@) if $@;
1303              
1304 2251 100       14012 $self->_create_handles ($files) if ($self->{file_type} eq 'handle');
1305             }
1306              
1307             sub _store
1308             {
1309 10139     10139   23442 my ($self, $platform, $file, $convert, $handle, $eol, $field, $info, $seen)
1310             = @_;
1311              
1312 10139 100       19580 if ($file) {
    100          
1313 7864 100       14008 if ($convert) {
1314 4066 50       7255 if ($platform eq 'PC') {
1315 0         0 $$info =~ s/\015(?!\012)|(?
1316             } else {
1317 4066         14379 $$info =~ s/\015\012/$eol/og;
1318 4066 50       10208 $$info =~ s/\015/$eol/og if ($platform ne 'Mac');
1319 4066 50       10991 $$info =~ s/\012/$eol/og if ($platform ne 'Unix');
1320             }
1321             }
1322              
1323 7864         30752 binmode $handle;
1324 7864         53926 print $handle $$info;
1325              
1326             } elsif ($field) {
1327 24 100       53 if ($seen->{$field} > 1) {
1328 16         59 $self->{web_data}->{$field}->[$seen->{$field} - 1] .= $$info;
1329             } else {
1330 8         31 $self->{web_data}->{$field} .= $$info;
1331             }
1332             }
1333             }
1334              
1335             sub _get_file_name
1336             {
1337 7258     7258   14507 my ($self, $platform, $directory, $file) = @_;
1338 7258         8527 my ($filtered_name, $filename, $timestamp, $path);
1339              
1340 6235         17654 $filtered_name = &{$self->{filter}}($file)
1341 7258 100       17340 if (ref ($self->{filter}) eq 'CODE');
1342              
1343 7258   100     43439 $filename = $filtered_name || $file;
1344 7258         17276 $timestamp = time . '__' . $filename;
1345              
1346 7258 100       14165 if (!$self->{timestamp}) {
    100          
1347 6230         13459 return $filename;
1348              
1349             } elsif ($self->{timestamp} == 1) {
1350 1013         2674 return $timestamp;
1351              
1352             } else { # $self->{timestamp} must be 2
1353 15         38 $path = join ($self->{file}->{$platform}, $directory, $filename);
1354              
1355 15 100       315 return (-e $path) ? $timestamp : $filename;
1356             }
1357             }
1358              
1359             sub _create_handles
1360             {
1361 1     1   5 my ($self, $files) = @_;
1362 1         3 my ($package, $handle, $name, $path);
1363              
1364 1         5 $package = $self->_determine_package;
1365              
1366 1         7 while (($name, $path) = each %$files) {
1367 5         19 $handle = Symbol::qualify_to_ref ($name, $package);
1368 5 50       305 open ($handle, '<', $path)
1369             or $self->_error ("Can't read file: $path! $!");
1370              
1371 5         12 push (@{$self->{all_handles}}, $handle);
  5         36  
1372             }
1373             }
1374              
1375             sub close_all_files
1376             {
1377 2258     2258 1 4526 my $self = shift;
1378              
1379 2258         3199 foreach my $handle (@{$self->{all_handles}}) {
  2258         6686  
1380 10         94 close $handle;
1381             }
1382             }
1383              
1384             1;
1385