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