init III
This commit is contained in:
18
Perl OTRS/Kernel/cpan-lib/CGI/Apache.pm
Normal file
18
Perl OTRS/Kernel/cpan-lib/CGI/Apache.pm
Normal file
@@ -0,0 +1,18 @@
|
||||
package CGI::Apache;
|
||||
use CGI;
|
||||
use if $] >= 5.019, 'deprecate';
|
||||
|
||||
$VERSION = '1.02';
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
CGI::Apache - Backward compatibility module for CGI.pm
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Do not use this module. It is deprecated.
|
||||
|
||||
=cut
|
||||
620
Perl OTRS/Kernel/cpan-lib/CGI/Carp.pm
Normal file
620
Perl OTRS/Kernel/cpan-lib/CGI/Carp.pm
Normal file
@@ -0,0 +1,620 @@
|
||||
package CGI::Carp;
|
||||
use if $] >= 5.019, 'deprecate';
|
||||
|
||||
my $appease_cpants_kwalitee = q/
|
||||
use strict;
|
||||
use warnings;
|
||||
#/;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
B<CGI::Carp> - CGI routines for writing to the HTTPD (or other) error log
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use CGI::Carp;
|
||||
|
||||
croak "We're outta here!";
|
||||
confess "It was my fault: $!";
|
||||
carp "It was your fault!";
|
||||
warn "I'm confused";
|
||||
die "I'm dying.\n";
|
||||
|
||||
use CGI::Carp qw(cluck);
|
||||
cluck "I wouldn't do that if I were you";
|
||||
|
||||
use CGI::Carp qw(fatalsToBrowser);
|
||||
die "Fatal error messages are now sent to browser";
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
CGI scripts have a nasty habit of leaving warning messages in the error
|
||||
logs that are neither time stamped nor fully identified. Tracking down
|
||||
the script that caused the error is a pain. This fixes that. Replace
|
||||
the usual
|
||||
|
||||
use Carp;
|
||||
|
||||
with
|
||||
|
||||
use CGI::Carp
|
||||
|
||||
The standard warn(), die (), croak(), confess() and carp() calls will
|
||||
be replaced with functions that write time-stamped messages to the
|
||||
HTTP server error log.
|
||||
|
||||
For example:
|
||||
|
||||
[Fri Nov 17 21:40:43 1995] test.pl: I'm confused at test.pl line 3.
|
||||
[Fri Nov 17 21:40:43 1995] test.pl: Got an error message: Permission denied.
|
||||
[Fri Nov 17 21:40:43 1995] test.pl: I'm dying.
|
||||
|
||||
=head1 REDIRECTING ERROR MESSAGES
|
||||
|
||||
By default, error messages are sent to STDERR. Most HTTPD servers
|
||||
direct STDERR to the server's error log. Some applications may wish
|
||||
to keep private error logs, distinct from the server's error log, or
|
||||
they may wish to direct error messages to STDOUT so that the browser
|
||||
will receive them.
|
||||
|
||||
The C<carpout()> function is provided for this purpose. Since
|
||||
carpout() is not exported by default, you must import it explicitly by
|
||||
saying
|
||||
|
||||
use CGI::Carp qw(carpout);
|
||||
|
||||
The carpout() function requires one argument, a reference to an open
|
||||
filehandle for writing errors. It should be called in a C<BEGIN>
|
||||
block at the top of the CGI application so that compiler errors will
|
||||
be caught. Example:
|
||||
|
||||
BEGIN {
|
||||
use CGI::Carp qw(carpout);
|
||||
open(LOG, ">>/usr/local/cgi-logs/mycgi-log") or
|
||||
die("Unable to open mycgi-log: $!\n");
|
||||
carpout(LOG);
|
||||
}
|
||||
|
||||
carpout() does not handle file locking on the log for you at this
|
||||
point. Also, note that carpout() does not work with in-memory file
|
||||
handles, although a patch would be welcome to address that.
|
||||
|
||||
The real STDERR is not closed -- it is moved to CGI::Carp::SAVEERR.
|
||||
Some servers, when dealing with CGI scripts, close their connection to
|
||||
the browser when the script closes STDOUT and STDERR.
|
||||
CGI::Carp::SAVEERR is there to prevent this from happening
|
||||
prematurely.
|
||||
|
||||
You can pass filehandles to carpout() in a variety of ways. The "correct"
|
||||
way according to Tom Christiansen is to pass a reference to a filehandle
|
||||
GLOB:
|
||||
|
||||
carpout(\*LOG);
|
||||
|
||||
This looks weird to mere mortals however, so the following syntaxes are
|
||||
accepted as well:
|
||||
|
||||
carpout(LOG);
|
||||
carpout(main::LOG);
|
||||
carpout(main'LOG);
|
||||
carpout(\LOG);
|
||||
carpout(\'main::LOG');
|
||||
|
||||
... and so on
|
||||
|
||||
FileHandle and other objects work as well.
|
||||
|
||||
Use of carpout() is not great for performance, so it is recommended
|
||||
for debugging purposes or for moderate-use applications. A future
|
||||
version of this module may delay redirecting STDERR until one of the
|
||||
CGI::Carp methods is called to prevent the performance hit.
|
||||
|
||||
=head1 MAKING PERL ERRORS APPEAR IN THE BROWSER WINDOW
|
||||
|
||||
If you want to send fatal (die, confess) errors to the browser, import
|
||||
the special "fatalsToBrowser" subroutine:
|
||||
|
||||
use CGI::Carp qw(fatalsToBrowser);
|
||||
die "Bad error here";
|
||||
|
||||
Fatal errors will now be echoed to the browser as well as to the log.
|
||||
CGI::Carp arranges to send a minimal HTTP header to the browser so
|
||||
that even errors that occur in the early compile phase will be seen.
|
||||
Nonfatal errors will still be directed to the log file only (unless
|
||||
redirected with carpout).
|
||||
|
||||
Note that fatalsToBrowser may B<not> work well with mod_perl version 2.0
|
||||
and higher.
|
||||
|
||||
=head2 Changing the default message
|
||||
|
||||
By default, the software error message is followed by a note to
|
||||
contact the Webmaster by e-mail with the time and date of the error.
|
||||
If this message is not to your liking, you can change it using the
|
||||
set_message() routine. This is not imported by default; you should
|
||||
import it on the use() line:
|
||||
|
||||
use CGI::Carp qw(fatalsToBrowser set_message);
|
||||
set_message("It's not a bug, it's a feature!");
|
||||
|
||||
You may also pass in a code reference in order to create a custom
|
||||
error message. At run time, your code will be called with the text
|
||||
of the error message that caused the script to die. Example:
|
||||
|
||||
use CGI::Carp qw(fatalsToBrowser set_message);
|
||||
BEGIN {
|
||||
sub handle_errors {
|
||||
my $msg = shift;
|
||||
print "<h1>Oh gosh</h1>";
|
||||
print "<p>Got an error: $msg</p>";
|
||||
}
|
||||
set_message(\&handle_errors);
|
||||
}
|
||||
|
||||
In order to correctly intercept compile-time errors, you should call
|
||||
set_message() from within a BEGIN{} block.
|
||||
|
||||
=head1 DOING MORE THAN PRINTING A MESSAGE IN THE EVENT OF PERL ERRORS
|
||||
|
||||
If fatalsToBrowser in conjunction with set_message does not provide
|
||||
you with all of the functionality you need, you can go one step
|
||||
further by specifying a function to be executed any time a script
|
||||
calls "die", has a syntax error, or dies unexpectedly at runtime
|
||||
with a line like "undef->explode();".
|
||||
|
||||
use CGI::Carp qw(set_die_handler);
|
||||
BEGIN {
|
||||
sub handle_errors {
|
||||
my $msg = shift;
|
||||
print "content-type: text/html\n\n";
|
||||
print "<h1>Oh gosh</h1>";
|
||||
print "<p>Got an error: $msg</p>";
|
||||
|
||||
#proceed to send an email to a system administrator,
|
||||
#write a detailed message to the browser and/or a log,
|
||||
#etc....
|
||||
}
|
||||
set_die_handler(\&handle_errors);
|
||||
}
|
||||
|
||||
Notice that if you use set_die_handler(), you must handle sending
|
||||
HTML headers to the browser yourself if you are printing a message.
|
||||
|
||||
If you use set_die_handler(), you will most likely interfere with
|
||||
the behavior of fatalsToBrowser, so you must use this or that, not
|
||||
both.
|
||||
|
||||
Using set_die_handler() sets SIG{__DIE__} (as does fatalsToBrowser),
|
||||
and there is only one SIG{__DIE__}. This means that if you are
|
||||
attempting to set SIG{__DIE__} yourself, you may interfere with
|
||||
this module's functionality, or this module may interfere with
|
||||
your module's functionality.
|
||||
|
||||
=head1 SUPPRESSING PERL ERRORS APPEARING IN THE BROWSER WINDOW
|
||||
|
||||
A problem sometimes encountered when using fatalsToBrowser is
|
||||
when a C<die()> is done inside an C<eval> body or expression.
|
||||
Even though the
|
||||
fatalsToBrower support takes precautions to avoid this,
|
||||
you still may get the error message printed to STDOUT.
|
||||
This may have some undesirable effects when the purpose of doing the
|
||||
eval is to determine which of several algorithms is to be used.
|
||||
|
||||
By setting C<$CGI::Carp::TO_BROWSER> to 0 you can suppress printing
|
||||
the C<die> messages but without all of the complexity of using
|
||||
C<set_die_handler>. You can localize this effect to inside C<eval>
|
||||
bodies if this is desirable: For example:
|
||||
|
||||
eval {
|
||||
local $CGI::Carp::TO_BROWSER = 0;
|
||||
die "Fatal error messages not sent browser"
|
||||
}
|
||||
# $@ will contain error message
|
||||
|
||||
|
||||
=head1 MAKING WARNINGS APPEAR AS HTML COMMENTS
|
||||
|
||||
It is also possible to make non-fatal errors appear as HTML comments
|
||||
embedded in the output of your program. To enable this feature,
|
||||
export the new "warningsToBrowser" subroutine. Since sending warnings
|
||||
to the browser before the HTTP headers have been sent would cause an
|
||||
error, any warnings are stored in an internal buffer until you call
|
||||
the warningsToBrowser() subroutine with a true argument:
|
||||
|
||||
use CGI::Carp qw(fatalsToBrowser warningsToBrowser);
|
||||
use CGI qw(:standard);
|
||||
print header();
|
||||
warningsToBrowser(1);
|
||||
|
||||
You may also give a false argument to warningsToBrowser() to prevent
|
||||
warnings from being sent to the browser while you are printing some
|
||||
content where HTML comments are not allowed:
|
||||
|
||||
warningsToBrowser(0); # disable warnings
|
||||
print "<script type=\"text/javascript\"><!--\n";
|
||||
print_some_javascript_code();
|
||||
print "//--></script>\n";
|
||||
warningsToBrowser(1); # re-enable warnings
|
||||
|
||||
Note: In this respect warningsToBrowser() differs fundamentally from
|
||||
fatalsToBrowser(), which you should never call yourself!
|
||||
|
||||
=head1 OVERRIDING THE NAME OF THE PROGRAM
|
||||
|
||||
CGI::Carp includes the name of the program that generated the error or
|
||||
warning in the messages written to the log and the browser window.
|
||||
Sometimes, Perl can get confused about what the actual name of the
|
||||
executed program was. In these cases, you can override the program
|
||||
name that CGI::Carp will use for all messages.
|
||||
|
||||
The quick way to do that is to tell CGI::Carp the name of the program
|
||||
in its use statement. You can do that by adding
|
||||
"name=cgi_carp_log_name" to your "use" statement. For example:
|
||||
|
||||
use CGI::Carp qw(name=cgi_carp_log_name);
|
||||
|
||||
. If you want to change the program name partway through the program,
|
||||
you can use the C<set_progname()> function instead. It is not
|
||||
exported by default, you must import it explicitly by saying
|
||||
|
||||
use CGI::Carp qw(set_progname);
|
||||
|
||||
Once you've done that, you can change the logged name of the program
|
||||
at any time by calling
|
||||
|
||||
set_progname(new_program_name);
|
||||
|
||||
You can set the program back to the default by calling
|
||||
|
||||
set_progname(undef);
|
||||
|
||||
Note that this override doesn't happen until after the program has
|
||||
compiled, so any compile-time errors will still show up with the
|
||||
non-overridden program name
|
||||
|
||||
=head1 TURNING OFF TIMESTAMPS IN MESSAGES
|
||||
|
||||
If your web server automatically adds a timestamp to each log line,
|
||||
you may not need CGI::Carp to add its own. You can disable timestamping
|
||||
by importing "noTimestamp":
|
||||
|
||||
use CGI::Carp qw(noTimestamp);
|
||||
|
||||
Alternatively you can set C<$CGI::Carp::NO_TIMESTAMP> to 1.
|
||||
|
||||
Note that the name of the program is still automatically included in
|
||||
the message.
|
||||
|
||||
=head1 GETTING THE FULL PATH OF THE SCRIPT IN MESSAGES
|
||||
|
||||
Set C<$CGI::Carp::FULL_PATH> to 1.
|
||||
|
||||
=head1 AUTHOR INFORMATION
|
||||
|
||||
The CGI.pm distribution is copyright 1995-2007, Lincoln D. Stein. It is
|
||||
distributed under GPL and the Artistic License 2.0. It is currently
|
||||
maintained by Lee Johnson with help from many contributors.
|
||||
|
||||
Address bug reports and comments to: https://github.com/leejo/CGI.pm/issues
|
||||
|
||||
The original bug tracker can be found at: https://rt.cpan.org/Public/Dist/Display.html?Queue=CGI.pm
|
||||
|
||||
When sending bug reports, please provide the version of CGI.pm, the version of
|
||||
Perl, the name and version of your Web server, and the name and version of the
|
||||
operating system you are using. If the problem is even remotely browser
|
||||
dependent, please provide information about the affected browsers as well.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Carp>, L<CGI::Base>, L<CGI::BasePlus>, L<CGI::Request>,
|
||||
L<CGI::MiniSvr>, L<CGI::Form>, L<CGI::Response>.
|
||||
|
||||
=cut
|
||||
|
||||
require 5.000;
|
||||
use Exporter;
|
||||
#use Carp;
|
||||
BEGIN {
|
||||
require Carp;
|
||||
*CORE::GLOBAL::die = \&CGI::Carp::die;
|
||||
}
|
||||
|
||||
use File::Spec;
|
||||
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(confess croak carp);
|
||||
@EXPORT_OK = qw(carpout fatalsToBrowser warningsToBrowser wrap noTimestamp set_message set_die_handler set_progname cluck ^name= die);
|
||||
|
||||
$main::SIG{__WARN__}=\&CGI::Carp::warn;
|
||||
|
||||
$CGI::Carp::VERSION = '4.36';
|
||||
$CGI::Carp::CUSTOM_MSG = undef;
|
||||
$CGI::Carp::DIE_HANDLER = undef;
|
||||
$CGI::Carp::TO_BROWSER = 1;
|
||||
$CGI::Carp::NO_TIMESTAMP= 0;
|
||||
$CGI::Carp::FULL_PATH = 0;
|
||||
|
||||
# fancy import routine detects and handles 'errorWrap' specially.
|
||||
sub import {
|
||||
my $pkg = shift;
|
||||
my(%routines);
|
||||
my(@name);
|
||||
if (@name=grep(/^name=/,@_))
|
||||
{
|
||||
my($n) = (split(/=/,$name[0]))[1];
|
||||
set_progname($n);
|
||||
@_=grep(!/^name=/,@_);
|
||||
}
|
||||
|
||||
grep($routines{$_}++,@_,@EXPORT);
|
||||
$WRAP++ if $routines{'fatalsToBrowser'} || $routines{'wrap'};
|
||||
$WARN++ if $routines{'warningsToBrowser'};
|
||||
my($oldlevel) = $Exporter::ExportLevel;
|
||||
$Exporter::ExportLevel = 1;
|
||||
Exporter::import($pkg,keys %routines);
|
||||
$Exporter::ExportLevel = $oldlevel;
|
||||
$main::SIG{__DIE__} =\&CGI::Carp::die if $routines{'fatalsToBrowser'};
|
||||
$CGI::Carp::NO_TIMESTAMP = 1 if $routines{'noTimestamp'};
|
||||
}
|
||||
|
||||
# These are the originals
|
||||
sub realwarn { CORE::warn(@_); }
|
||||
sub realdie { CORE::die(@_); }
|
||||
|
||||
sub id {
|
||||
my $level = shift;
|
||||
my($pack,$file,$line,$sub) = caller($level);
|
||||
my($dev,$dirs,$id) = File::Spec->splitpath($file);
|
||||
return ($file,$line,$id);
|
||||
}
|
||||
|
||||
sub stamp {
|
||||
my $frame = 0;
|
||||
my ($id,$pack,$file,$dev,$dirs);
|
||||
if (defined($CGI::Carp::PROGNAME)) {
|
||||
$id = $CGI::Carp::PROGNAME;
|
||||
} else {
|
||||
do {
|
||||
$id = $file;
|
||||
($pack,$file) = caller($frame++);
|
||||
} until !$file;
|
||||
}
|
||||
if (! $CGI::Carp::FULL_PATH) {
|
||||
($dev,$dirs,$id) = File::Spec->splitpath($id);
|
||||
}
|
||||
return "$id: " if $CGI::Carp::NO_TIMESTAMP;
|
||||
my $time = scalar(localtime);
|
||||
return "[$time] $id: ";
|
||||
}
|
||||
|
||||
sub set_progname {
|
||||
$CGI::Carp::PROGNAME = shift;
|
||||
return $CGI::Carp::PROGNAME;
|
||||
}
|
||||
|
||||
|
||||
sub warn {
|
||||
my $message = shift;
|
||||
my($file,$line,$id) = id(1);
|
||||
$message .= " at $file line $line.\n" unless $message=~/\n$/;
|
||||
_warn($message) if $WARN;
|
||||
my $stamp = stamp;
|
||||
$message=~s/^/$stamp/gm;
|
||||
realwarn $message;
|
||||
}
|
||||
|
||||
sub _warn {
|
||||
my $msg = shift;
|
||||
if ($EMIT_WARNINGS) {
|
||||
# We need to mangle the message a bit to make it a valid HTML
|
||||
# comment. This is done by substituting similar-looking ISO
|
||||
# 8859-1 characters for <, > and -. This is a hack.
|
||||
$msg =~ tr/<>-/\253\273\255/;
|
||||
chomp $msg;
|
||||
print STDOUT "<!-- warning: $msg -->\n";
|
||||
} else {
|
||||
push @WARNINGS, $msg;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
# The mod_perl package Apache::Registry loads CGI programs by calling
|
||||
# eval. These evals don't count when looking at the stack backtrace.
|
||||
sub _longmess {
|
||||
my $message = Carp::longmess();
|
||||
$message =~ s,eval[^\n]+(ModPerl|Apache)/(?:Registry|Dispatch)\w*\.pm.*,,s
|
||||
if exists $ENV{MOD_PERL};
|
||||
return $message;
|
||||
}
|
||||
|
||||
sub ineval {
|
||||
(exists $ENV{MOD_PERL} ? 0 : $^S) || _longmess() =~ /eval [\{\']/m
|
||||
}
|
||||
|
||||
sub die {
|
||||
# if no argument is passed, propagate $@ like
|
||||
# the real die
|
||||
my ($arg,@rest) = @_ ? @_
|
||||
: $@ ? "$@\t...propagated"
|
||||
: "Died"
|
||||
;
|
||||
|
||||
&$DIE_HANDLER($arg,@rest) if $DIE_HANDLER;
|
||||
|
||||
# the "$arg" is done on purpose!
|
||||
# if called as die( $object, 'string' ),
|
||||
# all is stringified, just like with
|
||||
# the real 'die'
|
||||
$arg = join '' => "$arg", @rest if @rest;
|
||||
|
||||
my($file,$line,$id) = id(1);
|
||||
|
||||
$arg .= " at $file line $line.\n" unless ref $arg or $arg=~/\n$/;
|
||||
|
||||
realdie $arg if ineval();
|
||||
&fatalsToBrowser($arg) if ($WRAP and $CGI::Carp::TO_BROWSER);
|
||||
|
||||
$arg=~s/^/ stamp() /gme if $arg =~ /\n$/ or not exists $ENV{MOD_PERL};
|
||||
|
||||
$arg .= "\n" unless $arg =~ /\n$/;
|
||||
|
||||
realdie $arg;
|
||||
}
|
||||
|
||||
sub set_message {
|
||||
$CGI::Carp::CUSTOM_MSG = shift;
|
||||
return $CGI::Carp::CUSTOM_MSG;
|
||||
}
|
||||
|
||||
sub set_die_handler {
|
||||
|
||||
my ($handler) = shift;
|
||||
|
||||
#setting SIG{__DIE__} here is necessary to catch runtime
|
||||
#errors which are not called by literally saying "die",
|
||||
#such as the line "undef->explode();". however, doing this
|
||||
#will interfere with fatalsToBrowser, which also sets
|
||||
#SIG{__DIE__} in the import() function above (or the
|
||||
#import() function above may interfere with this). for
|
||||
#this reason, you should choose to either set the die
|
||||
#handler here, or use fatalsToBrowser, not both.
|
||||
$main::SIG{__DIE__} = $handler;
|
||||
|
||||
$CGI::Carp::DIE_HANDLER = $handler;
|
||||
|
||||
return $CGI::Carp::DIE_HANDLER;
|
||||
}
|
||||
|
||||
sub confess { CGI::Carp::die Carp::longmess @_; }
|
||||
sub croak { CGI::Carp::die Carp::shortmess @_; }
|
||||
sub carp { CGI::Carp::warn Carp::shortmess @_; }
|
||||
sub cluck { CGI::Carp::warn Carp::longmess @_; }
|
||||
|
||||
# We have to be ready to accept a filehandle as a reference
|
||||
# or a string.
|
||||
sub carpout {
|
||||
my($in) = @_;
|
||||
my($no) = fileno(to_filehandle($in));
|
||||
realdie("Invalid filehandle $in\n") unless defined $no;
|
||||
|
||||
open(SAVEERR, ">&STDERR");
|
||||
open(STDERR, ">&$no") or
|
||||
( print SAVEERR "Unable to redirect >&$no: $!\n" and exit(1) );
|
||||
}
|
||||
|
||||
sub warningsToBrowser {
|
||||
$EMIT_WARNINGS = @_ ? shift : 1;
|
||||
_warn(shift @WARNINGS) while $EMIT_WARNINGS and @WARNINGS;
|
||||
}
|
||||
|
||||
# headers
|
||||
sub fatalsToBrowser {
|
||||
my $msg = shift;
|
||||
|
||||
$msg = "$msg" if ref $msg;
|
||||
|
||||
$msg=~s/&/&/g;
|
||||
$msg=~s/>/>/g;
|
||||
$msg=~s/</</g;
|
||||
$msg=~s/"/"/g;
|
||||
|
||||
my($wm) = $ENV{SERVER_ADMIN} ?
|
||||
qq[the webmaster (<a href="mailto:$ENV{SERVER_ADMIN}">$ENV{SERVER_ADMIN}</a>)] :
|
||||
"this site's webmaster";
|
||||
my ($outer_message) = <<END;
|
||||
For help, please send mail to $wm, giving this error message
|
||||
and the time and date of the error.
|
||||
END
|
||||
;
|
||||
my $mod_perl = exists $ENV{MOD_PERL};
|
||||
|
||||
if ($CUSTOM_MSG) {
|
||||
if (ref($CUSTOM_MSG) eq 'CODE') {
|
||||
print STDOUT "Content-type: text/html\n\n"
|
||||
unless $mod_perl;
|
||||
eval {
|
||||
&$CUSTOM_MSG($msg); # nicer to perl 5.003 users
|
||||
};
|
||||
if ($@) { print STDERR qq(error while executing the error handler: $@); }
|
||||
|
||||
return;
|
||||
} else {
|
||||
$outer_message = $CUSTOM_MSG;
|
||||
}
|
||||
}
|
||||
|
||||
my $mess = <<END;
|
||||
<h1>Software error:</h1>
|
||||
<pre>$msg</pre>
|
||||
<p>
|
||||
$outer_message
|
||||
</p>
|
||||
END
|
||||
;
|
||||
|
||||
if ($mod_perl) {
|
||||
my $r;
|
||||
if ($ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) {
|
||||
$mod_perl = 2;
|
||||
require Apache2::RequestRec;
|
||||
require Apache2::RequestIO;
|
||||
require Apache2::RequestUtil;
|
||||
require APR::Pool;
|
||||
require ModPerl::Util;
|
||||
require Apache2::Response;
|
||||
$r = Apache2::RequestUtil->request;
|
||||
}
|
||||
else {
|
||||
$r = Apache->request;
|
||||
}
|
||||
# If bytes have already been sent, then
|
||||
# we print the message out directly.
|
||||
# Otherwise we make a custom error
|
||||
# handler to produce the doc for us.
|
||||
if ($r->bytes_sent) {
|
||||
$r->print($mess);
|
||||
$mod_perl == 2 ? ModPerl::Util::exit(0) : $r->exit;
|
||||
} else {
|
||||
# MSIE won't display a custom 500 response unless it is >512 bytes!
|
||||
if (defined($ENV{HTTP_USER_AGENT}) && $ENV{HTTP_USER_AGENT} =~ /MSIE/) {
|
||||
$mess = "<!-- " . (' ' x 513) . " -->\n$mess";
|
||||
}
|
||||
$r->custom_response(500,$mess);
|
||||
}
|
||||
} else {
|
||||
my $bytes_written = eval{tell STDOUT};
|
||||
if (defined $bytes_written && $bytes_written > 0) {
|
||||
print STDOUT $mess;
|
||||
}
|
||||
else {
|
||||
print STDOUT "Status: 500\n";
|
||||
print STDOUT "Content-type: text/html\n\n";
|
||||
# MSIE won't display a custom 500 response unless it is >512 bytes!
|
||||
if (defined($ENV{HTTP_USER_AGENT}) && $ENV{HTTP_USER_AGENT} =~ /MSIE/) {
|
||||
$mess = "<!-- " . (' ' x 513) . " -->\n$mess";
|
||||
}
|
||||
print STDOUT $mess;
|
||||
}
|
||||
}
|
||||
|
||||
warningsToBrowser(1); # emit warnings before dying
|
||||
}
|
||||
|
||||
# Cut and paste from CGI.pm so that we don't have the overhead of
|
||||
# always loading the entire CGI module.
|
||||
sub to_filehandle {
|
||||
my $thingy = shift;
|
||||
return undef unless $thingy;
|
||||
return $thingy if UNIVERSAL::isa($thingy,'GLOB');
|
||||
return $thingy if UNIVERSAL::isa($thingy,'FileHandle');
|
||||
if (!ref($thingy)) {
|
||||
my $caller = 1;
|
||||
while (my $package = caller($caller++)) {
|
||||
my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy";
|
||||
return $tmp if defined(fileno($tmp));
|
||||
}
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
1;
|
||||
558
Perl OTRS/Kernel/cpan-lib/CGI/Cookie.pm
Normal file
558
Perl OTRS/Kernel/cpan-lib/CGI/Cookie.pm
Normal file
@@ -0,0 +1,558 @@
|
||||
package CGI::Cookie;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use if $] >= 5.019, 'deprecate';
|
||||
|
||||
our $VERSION='4.36';
|
||||
|
||||
use CGI::Util qw(rearrange unescape escape);
|
||||
use overload '""' => \&as_string, 'cmp' => \&compare, 'fallback' => 1;
|
||||
|
||||
my $PERLEX = 0;
|
||||
# Turn on special checking for ActiveState's PerlEx
|
||||
$PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/;
|
||||
|
||||
# Turn on special checking for mod_perl
|
||||
# PerlEx::DBI tries to fool DBI by setting MOD_PERL
|
||||
my $MOD_PERL = 0;
|
||||
if (exists $ENV{MOD_PERL} && ! $PERLEX) {
|
||||
if (exists $ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) {
|
||||
$MOD_PERL = 2;
|
||||
require Apache2::RequestUtil;
|
||||
require APR::Table;
|
||||
} else {
|
||||
$MOD_PERL = 1;
|
||||
require Apache;
|
||||
}
|
||||
}
|
||||
|
||||
# fetch a list of cookies from the environment and
|
||||
# return as a hash. the cookies are parsed as normal
|
||||
# escaped URL data.
|
||||
sub fetch {
|
||||
my $class = shift;
|
||||
my $raw_cookie = get_raw_cookie(@_) or return;
|
||||
return $class->parse($raw_cookie);
|
||||
}
|
||||
|
||||
# Fetch a list of cookies from the environment or the incoming headers and
|
||||
# return as a hash. The cookie values are not unescaped or altered in any way.
|
||||
sub raw_fetch {
|
||||
my $class = shift;
|
||||
my $raw_cookie = get_raw_cookie(@_) or return;
|
||||
my %results;
|
||||
my($key,$value);
|
||||
|
||||
my @pairs = split("[;,] ?",$raw_cookie);
|
||||
for my $pair ( @pairs ) {
|
||||
$pair =~ s/^\s+|\s+$//g; # trim leading trailing whitespace
|
||||
my ( $key, $value ) = split "=", $pair;
|
||||
|
||||
$value = defined $value ? $value : '';
|
||||
$results{$key} = $value;
|
||||
}
|
||||
return wantarray ? %results : \%results;
|
||||
}
|
||||
|
||||
sub get_raw_cookie {
|
||||
my $r = shift;
|
||||
$r ||= eval { $MOD_PERL == 2 ?
|
||||
Apache2::RequestUtil->request() :
|
||||
Apache->request } if $MOD_PERL;
|
||||
|
||||
return $r->headers_in->{'Cookie'} if $r;
|
||||
|
||||
die "Run $r->subprocess_env; before calling fetch()"
|
||||
if $MOD_PERL and !exists $ENV{REQUEST_METHOD};
|
||||
|
||||
return $ENV{HTTP_COOKIE} || $ENV{COOKIE};
|
||||
}
|
||||
|
||||
|
||||
sub parse {
|
||||
my ($self,$raw_cookie) = @_;
|
||||
return wantarray ? () : {} unless $raw_cookie;
|
||||
|
||||
my %results;
|
||||
|
||||
my @pairs = split("[;,] ?",$raw_cookie);
|
||||
for (@pairs) {
|
||||
s/^\s+//;
|
||||
s/\s+$//;
|
||||
|
||||
my($key,$value) = split("=",$_,2);
|
||||
|
||||
# Some foreign cookies are not in name=value format, so ignore
|
||||
# them.
|
||||
next if !defined($value);
|
||||
my @values = ();
|
||||
if ($value ne '') {
|
||||
@values = map unescape($_),split(/[&;]/,$value.'&dmy');
|
||||
pop @values;
|
||||
}
|
||||
$key = unescape($key);
|
||||
# A bug in Netscape can cause several cookies with same name to
|
||||
# appear. The FIRST one in HTTP_COOKIE is the most recent version.
|
||||
$results{$key} ||= $self->new(-name=>$key,-value=>\@values);
|
||||
}
|
||||
return wantarray ? %results : \%results;
|
||||
}
|
||||
|
||||
sub new {
|
||||
my ( $class, @params ) = @_;
|
||||
$class = ref( $class ) || $class;
|
||||
# Ignore mod_perl request object--compatibility with Apache::Cookie.
|
||||
shift if ref $params[0]
|
||||
&& eval { $params[0]->isa('Apache::Request::Req') || $params[0]->isa('Apache') };
|
||||
my ( $name, $value, $path, $domain, $secure, $expires, $max_age, $httponly, $samesite )
|
||||
= rearrange(
|
||||
[
|
||||
'NAME', [ 'VALUE', 'VALUES' ],
|
||||
'PATH', 'DOMAIN',
|
||||
'SECURE', 'EXPIRES',
|
||||
'MAX-AGE','HTTPONLY','SAMESITE'
|
||||
],
|
||||
@params
|
||||
);
|
||||
return undef unless defined $name and defined $value;
|
||||
my $self = {};
|
||||
bless $self, $class;
|
||||
$self->name( $name );
|
||||
$self->value( $value );
|
||||
$path ||= "/";
|
||||
$self->path( $path ) if defined $path;
|
||||
$self->domain( $domain ) if defined $domain;
|
||||
$self->secure( $secure ) if defined $secure;
|
||||
$self->expires( $expires ) if defined $expires;
|
||||
$self->max_age( $max_age ) if defined $max_age;
|
||||
$self->httponly( $httponly ) if defined $httponly;
|
||||
$self->samesite( $samesite ) if defined $samesite;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub as_string {
|
||||
my $self = shift;
|
||||
return "" unless $self->name;
|
||||
|
||||
no warnings; # some things may be undefined, that's OK.
|
||||
|
||||
my $name = escape( $self->name );
|
||||
my $value = join "&", map { escape($_) } $self->value;
|
||||
my @cookie = ( "$name=$value" );
|
||||
|
||||
push @cookie,"domain=".$self->domain if $self->domain;
|
||||
push @cookie,"path=".$self->path if $self->path;
|
||||
push @cookie,"expires=".$self->expires if $self->expires;
|
||||
push @cookie,"max-age=".$self->max_age if $self->max_age;
|
||||
push @cookie,"secure" if $self->secure;
|
||||
push @cookie,"HttpOnly" if $self->httponly;
|
||||
push @cookie,"SameSite=".$self->samesite if $self->samesite;
|
||||
|
||||
return join "; ", @cookie;
|
||||
}
|
||||
|
||||
sub compare {
|
||||
my ( $self, $value ) = @_;
|
||||
return "$self" cmp $value;
|
||||
}
|
||||
|
||||
sub bake {
|
||||
my ($self, $r) = @_;
|
||||
|
||||
$r ||= eval {
|
||||
$MOD_PERL == 2
|
||||
? Apache2::RequestUtil->request()
|
||||
: Apache->request
|
||||
} if $MOD_PERL;
|
||||
if ($r) {
|
||||
$r->headers_out->add('Set-Cookie' => $self->as_string);
|
||||
} else {
|
||||
require CGI;
|
||||
print CGI::header(-cookie => $self);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
# accessors
|
||||
sub name {
|
||||
my ( $self, $name ) = @_;
|
||||
$self->{'name'} = $name if defined $name;
|
||||
return $self->{'name'};
|
||||
}
|
||||
|
||||
sub value {
|
||||
my ( $self, $value ) = @_;
|
||||
if ( defined $value ) {
|
||||
my @values
|
||||
= ref $value eq 'ARRAY' ? @$value
|
||||
: ref $value eq 'HASH' ? %$value
|
||||
: ( $value );
|
||||
$self->{'value'} = [@values];
|
||||
}
|
||||
return wantarray ? @{ $self->{'value'} } : $self->{'value'}->[0];
|
||||
}
|
||||
|
||||
sub domain {
|
||||
my ( $self, $domain ) = @_;
|
||||
$self->{'domain'} = lc $domain if defined $domain;
|
||||
return $self->{'domain'};
|
||||
}
|
||||
|
||||
sub secure {
|
||||
my ( $self, $secure ) = @_;
|
||||
$self->{'secure'} = $secure if defined $secure;
|
||||
return $self->{'secure'};
|
||||
}
|
||||
|
||||
sub expires {
|
||||
my ( $self, $expires ) = @_;
|
||||
$self->{'expires'} = CGI::Util::expires($expires,'cookie') if defined $expires;
|
||||
return $self->{'expires'};
|
||||
}
|
||||
|
||||
sub max_age {
|
||||
my ( $self, $max_age ) = @_;
|
||||
$self->{'max-age'} = CGI::Util::expire_calc($max_age)-time() if defined $max_age;
|
||||
return $self->{'max-age'};
|
||||
}
|
||||
|
||||
sub path {
|
||||
my ( $self, $path ) = @_;
|
||||
$self->{'path'} = $path if defined $path;
|
||||
return $self->{'path'};
|
||||
}
|
||||
|
||||
sub httponly { # HttpOnly
|
||||
my ( $self, $httponly ) = @_;
|
||||
$self->{'httponly'} = $httponly if defined $httponly;
|
||||
return $self->{'httponly'};
|
||||
}
|
||||
|
||||
my %_legal_samesite = ( Strict => 1, Lax => 1 );
|
||||
sub samesite { # SameSite
|
||||
my $self = shift;
|
||||
my $samesite = ucfirst lc +shift if @_; # Normalize casing.
|
||||
$self->{'samesite'} = $samesite if $samesite and $_legal_samesite{$samesite};
|
||||
return $self->{'samesite'};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
CGI::Cookie - Interface to HTTP Cookies
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use CGI qw/:standard/;
|
||||
use CGI::Cookie;
|
||||
|
||||
# Create new cookies and send them
|
||||
$cookie1 = CGI::Cookie->new(-name=>'ID',-value=>123456);
|
||||
$cookie2 = CGI::Cookie->new(-name=>'preferences',
|
||||
-value=>{ font => Helvetica,
|
||||
size => 12 }
|
||||
);
|
||||
print header(-cookie=>[$cookie1,$cookie2]);
|
||||
|
||||
# fetch existing cookies
|
||||
%cookies = CGI::Cookie->fetch;
|
||||
$id = $cookies{'ID'}->value;
|
||||
|
||||
# create cookies returned from an external source
|
||||
%cookies = CGI::Cookie->parse($ENV{COOKIE});
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
CGI::Cookie is an interface to HTTP/1.1 cookies, a mechanism
|
||||
that allows Web servers to store persistent information on
|
||||
the browser's side of the connection. Although CGI::Cookie is
|
||||
intended to be used in conjunction with CGI.pm (and is in fact used by
|
||||
it internally), you can use this module independently.
|
||||
|
||||
For full information on cookies see
|
||||
|
||||
https://tools.ietf.org/html/rfc6265
|
||||
|
||||
=head1 USING CGI::Cookie
|
||||
|
||||
CGI::Cookie is object oriented. Each cookie object has a name and a
|
||||
value. The name is any scalar value. The value is any scalar or
|
||||
array value (associative arrays are also allowed). Cookies also have
|
||||
several optional attributes, including:
|
||||
|
||||
=over 4
|
||||
|
||||
=item B<1. expiration date>
|
||||
|
||||
The expiration date tells the browser how long to hang on to the
|
||||
cookie. If the cookie specifies an expiration date in the future, the
|
||||
browser will store the cookie information in a disk file and return it
|
||||
to the server every time the user reconnects (until the expiration
|
||||
date is reached). If the cookie species an expiration date in the
|
||||
past, the browser will remove the cookie from the disk file. If the
|
||||
expiration date is not specified, the cookie will persist only until
|
||||
the user quits the browser.
|
||||
|
||||
=item B<2. domain>
|
||||
|
||||
This is a partial or complete domain name for which the cookie is
|
||||
valid. The browser will return the cookie to any host that matches
|
||||
the partial domain name. For example, if you specify a domain name
|
||||
of ".capricorn.com", then the browser will return the cookie to
|
||||
Web servers running on any of the machines "www.capricorn.com",
|
||||
"ftp.capricorn.com", "feckless.capricorn.com", etc. Domain names
|
||||
must contain at least two periods to prevent attempts to match
|
||||
on top level domains like ".edu". If no domain is specified, then
|
||||
the browser will only return the cookie to servers on the host the
|
||||
cookie originated from.
|
||||
|
||||
=item B<3. path>
|
||||
|
||||
If you provide a cookie path attribute, the browser will check it
|
||||
against your script's URL before returning the cookie. For example,
|
||||
if you specify the path "/cgi-bin", then the cookie will be returned
|
||||
to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl", and
|
||||
"/cgi-bin/customer_service/complain.pl", but not to the script
|
||||
"/cgi-private/site_admin.pl". By default, the path is set to "/", so
|
||||
that all scripts at your site will receive the cookie.
|
||||
|
||||
=item B<4. secure flag>
|
||||
|
||||
If the "secure" attribute is set, the cookie will only be sent to your
|
||||
script if the CGI request is occurring on a secure channel, such as SSL.
|
||||
|
||||
=item B<5. httponly flag>
|
||||
|
||||
If the "httponly" attribute is set, the cookie will only be accessible
|
||||
through HTTP Requests. This cookie will be inaccessible via JavaScript
|
||||
(to prevent XSS attacks).
|
||||
|
||||
This feature is supported by nearly all modern browsers.
|
||||
|
||||
See these URLs for more information:
|
||||
|
||||
http://msdn.microsoft.com/en-us/library/ms533046.aspx
|
||||
http://www.browserscope.org/?category=security&v=top
|
||||
|
||||
=item B<6. samesite flag>
|
||||
|
||||
Allowed settings are C<Strict> and C<Lax>.
|
||||
|
||||
As of June 2016, support is limited to recent releases of Chrome and Opera.
|
||||
|
||||
L<https://tools.ietf.org/html/draft-west-first-party-cookies-07>
|
||||
|
||||
=back
|
||||
|
||||
=head2 Creating New Cookies
|
||||
|
||||
my $c = CGI::Cookie->new(-name => 'foo',
|
||||
-value => 'bar',
|
||||
-expires => '+3M',
|
||||
'-max-age' => '+3M',
|
||||
-domain => '.capricorn.com',
|
||||
-path => '/cgi-bin/database',
|
||||
-secure => 1,
|
||||
-samesite=> "Lax"
|
||||
);
|
||||
|
||||
Create cookies from scratch with the B<new> method. The B<-name> and
|
||||
B<-value> parameters are required. The name must be a scalar value.
|
||||
The value can be a scalar, an array reference, or a hash reference.
|
||||
(At some point in the future cookies will support one of the Perl
|
||||
object serialization protocols for full generality).
|
||||
|
||||
B<-expires> accepts any of the relative or absolute date formats
|
||||
recognized by CGI.pm, for example "+3M" for three months in the
|
||||
future. See CGI.pm's documentation for details.
|
||||
|
||||
B<-max-age> accepts the same data formats as B<< -expires >>, but sets a
|
||||
relative value instead of an absolute like B<< -expires >>. This is intended to be
|
||||
more secure since a clock could be changed to fake an absolute time. In
|
||||
practice, as of 2011, C<< -max-age >> still does not enjoy the widespread support
|
||||
that C<< -expires >> has. You can set both, and browsers that support
|
||||
C<< -max-age >> should ignore the C<< Expires >> header. The drawback
|
||||
to this approach is the bit of bandwidth for sending an extra header on each cookie.
|
||||
|
||||
B<-domain> points to a domain name or to a fully qualified host name.
|
||||
If not specified, the cookie will be returned only to the Web server
|
||||
that created it.
|
||||
|
||||
B<-path> points to a partial URL on the current server. The cookie
|
||||
will be returned to all URLs beginning with the specified path. If
|
||||
not specified, it defaults to '/', which returns the cookie to all
|
||||
pages at your site.
|
||||
|
||||
B<-secure> if set to a true value instructs the browser to return the
|
||||
cookie only when a cryptographic protocol is in use.
|
||||
|
||||
B<-httponly> if set to a true value, the cookie will not be accessible
|
||||
via JavaScript.
|
||||
|
||||
B<-samesite> may be C<Lax> or C<Strict> and is an evolving part of the
|
||||
standards for cookies. Please refer to current documentation regarding it.
|
||||
|
||||
For compatibility with Apache::Cookie, you may optionally pass in
|
||||
a mod_perl request object as the first argument to C<new()>. It will
|
||||
simply be ignored:
|
||||
|
||||
my $c = CGI::Cookie->new($r,
|
||||
-name => 'foo',
|
||||
-value => ['bar','baz']);
|
||||
|
||||
=head2 Sending the Cookie to the Browser
|
||||
|
||||
The simplest way to send a cookie to the browser is by calling the bake()
|
||||
method:
|
||||
|
||||
$c->bake;
|
||||
|
||||
This will print the Set-Cookie HTTP header to STDOUT using CGI.pm. CGI.pm
|
||||
will be loaded for this purpose if it is not already. Otherwise CGI.pm is not
|
||||
required or used by this module.
|
||||
|
||||
Under mod_perl, pass in an Apache request object:
|
||||
|
||||
$c->bake($r);
|
||||
|
||||
If you want to set the cookie yourself, Within a CGI script you can send
|
||||
a cookie to the browser by creating one or more Set-Cookie: fields in the
|
||||
HTTP header. Here is a typical sequence:
|
||||
|
||||
my $c = CGI::Cookie->new(-name => 'foo',
|
||||
-value => ['bar','baz'],
|
||||
-expires => '+3M');
|
||||
|
||||
print "Set-Cookie: $c\n";
|
||||
print "Content-Type: text/html\n\n";
|
||||
|
||||
To send more than one cookie, create several Set-Cookie: fields.
|
||||
|
||||
If you are using CGI.pm, you send cookies by providing a -cookie
|
||||
argument to the header() method:
|
||||
|
||||
print header(-cookie=>$c);
|
||||
|
||||
Mod_perl users can set cookies using the request object's header_out()
|
||||
method:
|
||||
|
||||
$r->headers_out->set('Set-Cookie' => $c);
|
||||
|
||||
Internally, Cookie overloads the "" operator to call its as_string()
|
||||
method when incorporated into the HTTP header. as_string() turns the
|
||||
Cookie's internal representation into an RFC-compliant text
|
||||
representation. You may call as_string() yourself if you prefer:
|
||||
|
||||
print "Set-Cookie: ",$c->as_string,"\n";
|
||||
|
||||
=head2 Recovering Previous Cookies
|
||||
|
||||
%cookies = CGI::Cookie->fetch;
|
||||
|
||||
B<fetch> returns an associative array consisting of all cookies
|
||||
returned by the browser. The keys of the array are the cookie names. You
|
||||
can iterate through the cookies this way:
|
||||
|
||||
%cookies = CGI::Cookie->fetch;
|
||||
for (keys %cookies) {
|
||||
do_something($cookies{$_});
|
||||
}
|
||||
|
||||
In a scalar context, fetch() returns a hash reference, which may be more
|
||||
efficient if you are manipulating multiple cookies.
|
||||
|
||||
CGI.pm uses the URL escaping methods to save and restore reserved characters
|
||||
in its cookies. If you are trying to retrieve a cookie set by a foreign server,
|
||||
this escaping method may trip you up. Use raw_fetch() instead, which has the
|
||||
same semantics as fetch(), but performs no unescaping.
|
||||
|
||||
You may also retrieve cookies that were stored in some external
|
||||
form using the parse() class method:
|
||||
|
||||
$COOKIES = `cat /usr/tmp/Cookie_stash`;
|
||||
%cookies = CGI::Cookie->parse($COOKIES);
|
||||
|
||||
If you are in a mod_perl environment, you can save some overhead by
|
||||
passing the request object to fetch() like this:
|
||||
|
||||
CGI::Cookie->fetch($r);
|
||||
|
||||
If the value passed to parse() is undefined, an empty array will returned in list
|
||||
context, and an empty hashref will be returned in scalar context.
|
||||
|
||||
=head2 Manipulating Cookies
|
||||
|
||||
Cookie objects have a series of accessor methods to get and set cookie
|
||||
attributes. Each accessor has a similar syntax. Called without
|
||||
arguments, the accessor returns the current value of the attribute.
|
||||
Called with an argument, the accessor changes the attribute and
|
||||
returns its new value.
|
||||
|
||||
=over 4
|
||||
|
||||
=item B<name()>
|
||||
|
||||
Get or set the cookie's name. Example:
|
||||
|
||||
$name = $c->name;
|
||||
$new_name = $c->name('fred');
|
||||
|
||||
=item B<value()>
|
||||
|
||||
Get or set the cookie's value. Example:
|
||||
|
||||
$value = $c->value;
|
||||
@new_value = $c->value(['a','b','c','d']);
|
||||
|
||||
B<value()> is context sensitive. In a list context it will return
|
||||
the current value of the cookie as an array. In a scalar context it
|
||||
will return the B<first> value of a multivalued cookie.
|
||||
|
||||
=item B<domain()>
|
||||
|
||||
Get or set the cookie's domain.
|
||||
|
||||
=item B<path()>
|
||||
|
||||
Get or set the cookie's path.
|
||||
|
||||
=item B<expires()>
|
||||
|
||||
Get or set the cookie's expiration time.
|
||||
|
||||
=item B<max_age()>
|
||||
|
||||
Get or set the cookie's max_age value.
|
||||
|
||||
=back
|
||||
|
||||
|
||||
=head1 AUTHOR INFORMATION
|
||||
|
||||
The CGI.pm distribution is copyright 1995-2007, Lincoln D. Stein. It is
|
||||
distributed under GPL and the Artistic License 2.0. It is currently
|
||||
maintained by Lee Johnson with help from many contributors.
|
||||
|
||||
Address bug reports and comments to: https://github.com/leejo/CGI.pm/issues
|
||||
|
||||
The original bug tracker can be found at: https://rt.cpan.org/Public/Dist/Display.html?Queue=CGI.pm
|
||||
|
||||
When sending bug reports, please provide the version of CGI.pm, the version of
|
||||
Perl, the name and version of your Web server, and the name and version of the
|
||||
operating system you are using. If the problem is even remotely browser
|
||||
dependent, please provide information about the affected browsers as well.
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
This section intentionally left blank.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<CGI::Carp>, L<CGI>
|
||||
|
||||
L<RFC 2109|http://www.ietf.org/rfc/rfc2109.txt>, L<RFC 2695|http://www.ietf.org/rfc/rfc2965.txt>
|
||||
|
||||
=cut
|
||||
176
Perl OTRS/Kernel/cpan-lib/CGI/Emulate/PSGI.pm
Normal file
176
Perl OTRS/Kernel/cpan-lib/CGI/Emulate/PSGI.pm
Normal file
@@ -0,0 +1,176 @@
|
||||
package CGI::Emulate::PSGI;
|
||||
use strict;
|
||||
use warnings;
|
||||
use CGI::Parse::PSGI;
|
||||
use POSIX 'SEEK_SET';
|
||||
use IO::File ();
|
||||
use SelectSaver;
|
||||
use Carp qw(croak);
|
||||
use 5.008001;
|
||||
|
||||
our $VERSION = '0.23';
|
||||
|
||||
sub handler {
|
||||
my ($class, $code, ) = @_;
|
||||
|
||||
return sub {
|
||||
my $env = shift;
|
||||
|
||||
my $stdout = IO::File->new_tmpfile;
|
||||
|
||||
{
|
||||
my $saver = SelectSaver->new("::STDOUT");
|
||||
{
|
||||
local %ENV = (%ENV, $class->emulate_environment($env));
|
||||
|
||||
local *STDIN = $env->{'psgi.input'};
|
||||
local *STDOUT = $stdout;
|
||||
local *STDERR = $env->{'psgi.errors'};
|
||||
|
||||
$code->();
|
||||
}
|
||||
}
|
||||
|
||||
seek( $stdout, 0, SEEK_SET )
|
||||
or croak("Can't seek stdout handle: $!");
|
||||
|
||||
return CGI::Parse::PSGI::parse_cgi_output($stdout);
|
||||
};
|
||||
}
|
||||
|
||||
sub emulate_environment {
|
||||
my($class, $env) = @_;
|
||||
|
||||
no warnings;
|
||||
my $environment = {
|
||||
GATEWAY_INTERFACE => 'CGI/1.1',
|
||||
HTTPS => ( ( $env->{'psgi.url_scheme'} eq 'https' ) ? 'ON' : 'OFF' ),
|
||||
SERVER_SOFTWARE => "CGI-Emulate-PSGI",
|
||||
REMOTE_ADDR => '127.0.0.1',
|
||||
REMOTE_HOST => 'localhost',
|
||||
REMOTE_PORT => int( rand(64000) + 1000 ), # not in RFC 3875
|
||||
# REQUEST_URI => $uri->path_query, # not in RFC 3875
|
||||
( map { $_ => $env->{$_} } grep { !/^psgix?\./ && $_ ne "HTTP_PROXY" } keys %$env )
|
||||
};
|
||||
|
||||
return wantarray ? %$environment : $environment;
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
CGI::Emulate::PSGI - PSGI adapter for CGI
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $app = CGI::Emulate::PSGI->handler(sub {
|
||||
# Existing CGI code
|
||||
});
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module allows an application designed for the CGI environment to
|
||||
run in a PSGI environment, and thus on any of the backends that PSGI
|
||||
supports.
|
||||
|
||||
It works by translating the environment provided by the PSGI
|
||||
specification to one expected by the CGI specification. Likewise, it
|
||||
captures output as it would be prepared for the CGI standard, and
|
||||
translates it to the format expected for the PSGI standard using
|
||||
L<CGI::Parse::PSGI> module.
|
||||
|
||||
=head1 CGI.pm
|
||||
|
||||
If your application uses L<CGI>, be sure to cleanup the global
|
||||
variables in the handler loop yourself, so:
|
||||
|
||||
my $app = CGI::Emulate::PSGI->handler(sub {
|
||||
use CGI;
|
||||
CGI::initialize_globals();
|
||||
my $q = CGI->new;
|
||||
# ...
|
||||
});
|
||||
|
||||
Otherwise previous request variables will be reused in the new
|
||||
requests.
|
||||
|
||||
Alternatively, you can install and use L<CGI::Compile> from CPAN and
|
||||
compiles your existing CGI scripts into a sub that is perfectly ready
|
||||
to be converted to PSGI application using this module.
|
||||
|
||||
my $sub = CGI::Compile->compile("/path/to/script.cgi");
|
||||
my $app = CGI::Emulate::PSGI->handler($sub);
|
||||
|
||||
This will take care of assigning a unique namespace for each script
|
||||
etc. See L<CGI::Compile> for details.
|
||||
|
||||
You can also consider using L<CGI::PSGI> but that would require you to
|
||||
slightly change your code from:
|
||||
|
||||
my $q = CGI->new;
|
||||
# ...
|
||||
print $q->header, $output;
|
||||
|
||||
into:
|
||||
|
||||
use CGI::PSGI;
|
||||
|
||||
my $app = sub {
|
||||
my $env = shift;
|
||||
my $q = CGI::PSGI->new($env);
|
||||
# ...
|
||||
return [ $q->psgi_header, [ $output ] ];
|
||||
};
|
||||
|
||||
See L<CGI::PSGI> for details.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over 4
|
||||
|
||||
=item handler
|
||||
|
||||
my $app = CGI::Emulate::PSGI->handler($code);
|
||||
|
||||
Creates a PSGI application code reference out of CGI code reference.
|
||||
|
||||
=item emulate_environment
|
||||
|
||||
my %env = CGI::Emulate::PSGI->emulate_environment($env);
|
||||
|
||||
Creates an environment hash out of PSGI environment hash. If your code
|
||||
or framework just needs an environment variable emulation, use this
|
||||
method like:
|
||||
|
||||
local %ENV = (%ENV, CGI::Emulate::PSGI->emulate_environment($env));
|
||||
# run your application
|
||||
|
||||
If you use C<handler> method to create a PSGI environment hash, this
|
||||
is automatically called in the created application.
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Tokuhiro Matsuno <tokuhirom@cpan.org>
|
||||
|
||||
Tatsuhiko Miyagawa
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright (c) 2009-2010 by tokuhirom.
|
||||
|
||||
This program is free software; you can redistribute
|
||||
it and/or modify it under the same terms as Perl itself.
|
||||
|
||||
The full text of the license can be found in the
|
||||
LICENSE file included with this module.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<PSGI> L<CGI::Compile> L<CGI::PSGI> L<Plack> L<CGI::Parse::PSGI>
|
||||
|
||||
=cut
|
||||
|
||||
308
Perl OTRS/Kernel/cpan-lib/CGI/Fast.pm
Normal file
308
Perl OTRS/Kernel/cpan-lib/CGI/Fast.pm
Normal file
@@ -0,0 +1,308 @@
|
||||
package CGI::Fast;
|
||||
use strict;
|
||||
use if $] >= 5.019, 'deprecate';
|
||||
|
||||
# A way to say "use warnings" that's compatible with even older perls.
|
||||
# making it local will not affect the code that loads this module
|
||||
# and since we're not in a BLOCK, warnings are enabled until the EOF
|
||||
local $^W = 1;
|
||||
|
||||
# Copyright 1995,1996, Lincoln D. Stein. All rights reserved.
|
||||
# It may be used and modified freely, but I do request that this copyright
|
||||
# notice remain attached to the file. You may modify this module as you
|
||||
# wish, but if you redistribute a modified version, please attach a note
|
||||
# listing the modifications you have made.
|
||||
|
||||
$CGI::Fast::VERSION='2.02';
|
||||
|
||||
use CGI;
|
||||
use FCGI;
|
||||
# use vars works like "our", but is compatible with older Perls.
|
||||
use vars qw(
|
||||
@ISA
|
||||
$ignore
|
||||
);
|
||||
@ISA = ('CGI');
|
||||
|
||||
# workaround for known bug in libfcgi
|
||||
while (($ignore) = each %ENV) { }
|
||||
|
||||
# override the initialization behavior so that
|
||||
# state is NOT maintained between invocations
|
||||
sub save_request {
|
||||
# no-op
|
||||
}
|
||||
|
||||
# If ENV{FCGI_SOCKET_PATH} is specified, we maintain a FCGI Request handle
|
||||
# in this package variable.
|
||||
use vars qw($Ext_Request $socket $queue);
|
||||
|
||||
sub import {
|
||||
my ($package,@import) = @_;
|
||||
# check imports for this class then pass on
|
||||
# imports to SUPER class
|
||||
for (my $i = 0; $i < scalar( @import ); $i++) {
|
||||
if ( $import[$i] eq 'socket_path' ) {
|
||||
$socket = $import[$i+1];
|
||||
} elsif ( $import[$i] eq 'listen_queue' ) {
|
||||
$queue = $import[$i+1];
|
||||
}
|
||||
}
|
||||
$package->SUPER::import(@import);
|
||||
}
|
||||
|
||||
sub _create_fcgi_request {
|
||||
my ( $in_fh,$out_fh,$err_fh ) = @_;
|
||||
# If we have a socket set, explicitly open it
|
||||
if ($ENV{FCGI_SOCKET_PATH} or $socket) {
|
||||
my $path = $ENV{FCGI_SOCKET_PATH} || $socket;
|
||||
my $backlog = $ENV{FCGI_LISTEN_QUEUE} || $queue || 100;
|
||||
my $socket = FCGI::OpenSocket( $path, $backlog );
|
||||
return FCGI::Request(
|
||||
( $in_fh || \*STDIN ),
|
||||
( $out_fh || \*STDOUT ),
|
||||
( $err_fh || \*STDERR ),
|
||||
\%ENV,
|
||||
$socket,
|
||||
1
|
||||
);
|
||||
}
|
||||
else {
|
||||
return FCGI::Request(
|
||||
( $in_fh || \*STDIN ),
|
||||
( $out_fh || \*STDOUT ),
|
||||
( $err_fh || \*STDERR ),
|
||||
);
|
||||
}
|
||||
}
|
||||
|
||||
{
|
||||
my ( $in_fh,$out_fh,$err_fh );
|
||||
|
||||
sub file_handles {
|
||||
my ($self, $handles) = @_;
|
||||
|
||||
if ( ref( $handles ) eq 'HASH' ) {
|
||||
$in_fh = delete( $handles->{fcgi_input_file_handle} );
|
||||
$out_fh = delete( $handles->{fcgi_output_file_handle} );
|
||||
$err_fh = delete( $handles->{fcgi_error_file_handle} );
|
||||
}
|
||||
}
|
||||
|
||||
sub new {
|
||||
my ($self, $initializer, @param) = @_;
|
||||
|
||||
if ( ! defined $initializer ) {
|
||||
$Ext_Request ||= _create_fcgi_request( $in_fh,$out_fh,$err_fh );
|
||||
return undef unless $Ext_Request->Accept >= 0;
|
||||
}
|
||||
CGI->_reset_globals;
|
||||
$self->_setup_symbols(@CGI::SAVED_SYMBOLS) if @CGI::SAVED_SYMBOLS;
|
||||
return $CGI::Q = $self->SUPER::new($initializer, @param);
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
CGI::Fast - CGI Interface for Fast CGI
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use CGI::Fast
|
||||
socket_path => '9000',
|
||||
listen_queue => 50;
|
||||
|
||||
$COUNTER = 0;
|
||||
|
||||
# optional, will default to STDOUT, STDIN, STDERR
|
||||
CGI::Fast->file_handles({
|
||||
fcgi_input_file_handle => IO::Handle->new,
|
||||
fcgi_output_file_handle => IO::Handle->new,
|
||||
fcgi_error_file_handle => IO::Handle->new,
|
||||
});
|
||||
|
||||
while (new CGI::Fast) {
|
||||
print header;
|
||||
print start_html("Fast CGI Rocks");
|
||||
print
|
||||
h1("Fast CGI Rocks"),
|
||||
"Invocation number ",b($COUNTER++),
|
||||
" PID ",b($$),".",
|
||||
hr;
|
||||
print end_html;
|
||||
}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
CGI::Fast is a subclass of the CGI object created by CGI.pm. It is
|
||||
specialized to work with the FCGI module, which greatly speeds up CGI
|
||||
scripts by turning them into persistently running server processes.
|
||||
Scripts that perform time-consuming initialization processes, such as
|
||||
loading large modules or opening persistent database connections, will
|
||||
see large performance improvements.
|
||||
|
||||
=head1 OTHER PIECES OF THE PUZZLE
|
||||
|
||||
In order to use CGI::Fast you'll need the FCGI module. See
|
||||
http://www.cpan.org/ for details.
|
||||
|
||||
=head1 WRITING FASTCGI PERL SCRIPTS
|
||||
|
||||
FastCGI scripts are persistent: one or more copies of the script
|
||||
are started up when the server initializes, and stay around until
|
||||
the server exits or they die a natural death. After performing
|
||||
whatever one-time initialization it needs, the script enters a
|
||||
loop waiting for incoming connections, processing the request, and
|
||||
waiting some more.
|
||||
|
||||
A typical FastCGI script will look like this:
|
||||
|
||||
#!perl
|
||||
use CGI::Fast;
|
||||
do_some_initialization();
|
||||
while ($q = new CGI::Fast) {
|
||||
process_request($q);
|
||||
}
|
||||
|
||||
Each time there's a new request, CGI::Fast returns a
|
||||
CGI object to your loop. The rest of the time your script
|
||||
waits in the call to new(). When the server requests that
|
||||
your script be terminated, new() will return undef. You can
|
||||
of course exit earlier if you choose. A new version of the
|
||||
script will be respawned to take its place (this may be
|
||||
necessary in order to avoid Perl memory leaks in long-running
|
||||
scripts).
|
||||
|
||||
CGI.pm's default CGI object mode also works. Just modify the loop
|
||||
this way:
|
||||
|
||||
while (new CGI::Fast) {
|
||||
process_request();
|
||||
}
|
||||
|
||||
Calls to header(), start_form(), etc. will all operate on the
|
||||
current request.
|
||||
|
||||
=head1 INSTALLING FASTCGI SCRIPTS
|
||||
|
||||
See the FastCGI developer's kit documentation for full details. On
|
||||
the Apache server, the following line must be added to srm.conf:
|
||||
|
||||
AddType application/x-httpd-fcgi .fcgi
|
||||
|
||||
FastCGI scripts must end in the extension .fcgi. For each script you
|
||||
install, you must add something like the following to srm.conf:
|
||||
|
||||
FastCgiServer /usr/etc/httpd/fcgi-bin/file_upload.fcgi -processes 2
|
||||
|
||||
This instructs Apache to launch two copies of file_upload.fcgi at
|
||||
startup time.
|
||||
|
||||
=head1 USING FASTCGI SCRIPTS AS CGI SCRIPTS
|
||||
|
||||
Any script that works correctly as a FastCGI script will also work
|
||||
correctly when installed as a vanilla CGI script. However it will
|
||||
not see any performance benefit.
|
||||
|
||||
=head1 EXTERNAL FASTCGI SERVER INVOCATION
|
||||
|
||||
FastCGI supports a TCP/IP transport mechanism which allows FastCGI scripts to run
|
||||
external to the webserver, perhaps on a remote machine. To configure the
|
||||
webserver to connect to an external FastCGI server, you would add the following
|
||||
to your srm.conf:
|
||||
|
||||
FastCgiExternalServer /usr/etc/httpd/fcgi-bin/file_upload.fcgi -host sputnik:8888
|
||||
|
||||
Two environment variables affect how the C<CGI::Fast> object is created,
|
||||
allowing C<CGI::Fast> to be used as an external FastCGI server. (See C<FCGI>
|
||||
documentation for C<FCGI::OpenSocket> for more information.)
|
||||
|
||||
You can set these as ENV variables or imports in the use CGI::Fast statement.
|
||||
If the ENV variables are set then these will be favoured so you can override
|
||||
the import statements on the command line, etc.
|
||||
|
||||
=over
|
||||
|
||||
=item FCGI_SOCKET_PATH / socket_path
|
||||
|
||||
The address (TCP/IP) or path (UNIX Domain) of the socket the external FastCGI
|
||||
script to which bind an listen for incoming connections from the web server.
|
||||
|
||||
=item FCGI_LISTEN_QUEUE / listen_queue
|
||||
|
||||
Maximum length of the queue of pending connections, defaults to 100.
|
||||
|
||||
=back
|
||||
|
||||
For example:
|
||||
|
||||
use CGI::Fast
|
||||
socket_path => "sputnik:8888",
|
||||
listen_queue => "50"
|
||||
;
|
||||
|
||||
do_some_initialization();
|
||||
|
||||
while ($q = new CGI::Fast) {
|
||||
process_request($q);
|
||||
}
|
||||
|
||||
|
||||
Or:
|
||||
|
||||
use CGI::Fast;
|
||||
|
||||
do_some_initialization();
|
||||
|
||||
$ENV{FCGI_SOCKET_PATH} = "sputnik:8888";
|
||||
$ENV{FCGI_LISTEN_QUEUE} = 50;
|
||||
|
||||
while ($q = new CGI::Fast) {
|
||||
process_request($q);
|
||||
}
|
||||
|
||||
=head1 FILE HANDLES
|
||||
|
||||
FCGI defaults to using STDIN, STDOUT, and STDERR as its filehandles - this
|
||||
may lead to unexpected redirect of output if you migrate scripts from CGI.pm
|
||||
to CGI::Fast. To get around this you can use the file_handles method, which
|
||||
you must do B<before> the first call to CGI::Fast->new. For example using
|
||||
IO::Handle:
|
||||
|
||||
CGI::Fast->file_handles({
|
||||
fcgi_input_file_handle => IO::Handle->new,
|
||||
fcgi_output_file_handle => IO::Handle->new,
|
||||
fcgi_error_file_handle => IO::Handle->new,
|
||||
});
|
||||
|
||||
while (new CGI::Fast) {
|
||||
..
|
||||
}
|
||||
|
||||
=head1 CAVEATS
|
||||
|
||||
I haven't tested this very much.
|
||||
|
||||
=head1 AUTHOR INFORMATION
|
||||
|
||||
Copyright 1996-1998, Lincoln D. Stein. All rights reserved. Currently
|
||||
maintained by Lee Johnson
|
||||
|
||||
This library is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself.
|
||||
|
||||
Address bug reports and comments to:
|
||||
|
||||
https://github.com/leejo/cgi-fast
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
This section intentionally left blank.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<CGI::Carp>, L<CGI>
|
||||
|
||||
=cut
|
||||
44
Perl OTRS/Kernel/cpan-lib/CGI/File/Temp.pm
Normal file
44
Perl OTRS/Kernel/cpan-lib/CGI/File/Temp.pm
Normal file
@@ -0,0 +1,44 @@
|
||||
# this is a back compatibility wrapper around File::Temp. DO NOT
|
||||
# use this package outside of CGI, i won't provide any help if
|
||||
# you use it directly and your code breaks horribly.
|
||||
package CGI::File::Temp;
|
||||
|
||||
$CGI::File::Temp::VERSION = '4.36';
|
||||
|
||||
use parent File::Temp;
|
||||
use parent Fh;
|
||||
|
||||
my $appease_cpants_kwalitee = q/
|
||||
use strict;
|
||||
use warnings;
|
||||
#/;
|
||||
|
||||
use overload
|
||||
'""' => \&asString,
|
||||
'cmp' => \&compare,
|
||||
'fallback'=>1;
|
||||
|
||||
# back compatibility method since we now return a File::Temp object
|
||||
# as the filehandle (which isa IO::Handle) so calling ->handle on
|
||||
# it will fail. FIXME: deprecate this method in v5+
|
||||
sub handle { return shift; };
|
||||
|
||||
sub compare {
|
||||
my ( $self,$value ) = @_;
|
||||
return "$self" cmp $value;
|
||||
}
|
||||
|
||||
sub _mp_filename {
|
||||
my ( $self,$filename ) = @_;
|
||||
${*$self}->{ _mp_filename } = $filename
|
||||
if $filename;
|
||||
return ${*$self}->{_mp_filename};
|
||||
}
|
||||
|
||||
sub asString {
|
||||
my ( $self ) = @_;
|
||||
return $self->_mp_filename;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
8
Perl OTRS/Kernel/cpan-lib/CGI/HTML/Functions.pm
Normal file
8
Perl OTRS/Kernel/cpan-lib/CGI/HTML/Functions.pm
Normal file
@@ -0,0 +1,8 @@
|
||||
package CGI::HTML::Functions;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
# nothing here yet... may move functions here in the long term
|
||||
|
||||
1;
|
||||
178
Perl OTRS/Kernel/cpan-lib/CGI/Parse/PSGI.pm
Normal file
178
Perl OTRS/Kernel/cpan-lib/CGI/Parse/PSGI.pm
Normal file
@@ -0,0 +1,178 @@
|
||||
package CGI::Parse::PSGI;
|
||||
use strict;
|
||||
use base qw(Exporter);
|
||||
our @EXPORT_OK = qw( parse_cgi_output );
|
||||
|
||||
use IO::File; # perl bug: should be loaded to call ->getline etc. on filehandle/PerlIO
|
||||
use HTTP::Response;
|
||||
|
||||
our %DEFAULT_OPTS = (
|
||||
ignore_status_line => 0,
|
||||
);
|
||||
|
||||
sub parse_cgi_output {
|
||||
my $output = shift;
|
||||
my $options = \%DEFAULT_OPTS;
|
||||
if (ref $_[0] eq 'HASH') {
|
||||
$options = { %DEFAULT_OPTS, %{ +shift } }; # Use default opts where none supplied
|
||||
}
|
||||
|
||||
my $length;
|
||||
if (ref $output eq 'SCALAR') {
|
||||
$length = length $$output;
|
||||
open my $io, "<", $output;
|
||||
$output = $io;
|
||||
} else {
|
||||
open my $tmp, '<&=:perlio:raw', fileno($output) or die $!;
|
||||
$output = $tmp;
|
||||
$length = -s $output;
|
||||
}
|
||||
|
||||
my $headers;
|
||||
while ( my $line = $output->getline ) {
|
||||
$headers .= $line;
|
||||
last if $headers =~ /\x0d?\x0a\x0d?\x0a$/;
|
||||
}
|
||||
unless ( defined $headers ) {
|
||||
$headers = "HTTP/1.1 500 Internal Server Error\x0d\x0a";
|
||||
}
|
||||
|
||||
unless ( $headers =~ /^HTTP/ ) {
|
||||
$headers = "HTTP/1.1 200 OK\x0d\x0a" . $headers;
|
||||
}
|
||||
|
||||
my $response = HTTP::Response->parse($headers);
|
||||
|
||||
# RFC 3875 6.2.3
|
||||
if ($response->header('Location') && !$response->header('Status')) {
|
||||
$response->header('Status', 302);
|
||||
}
|
||||
|
||||
my $status = $options->{ignore_status_line}?
|
||||
200 : ($response->code || 200);
|
||||
|
||||
my $status_header = $response->header('Status');
|
||||
if ($status_header) {
|
||||
# Use the header status preferentially, if present and well formed
|
||||
|
||||
# Extract the code from the header (should be 3 digits, non zero)
|
||||
my ($code) = ($status_header =~ /^ \s* (\d+) /x);
|
||||
|
||||
$status = $code || $status;
|
||||
}
|
||||
|
||||
$response->remove_header('Status'); # PSGI doesn't allow having Status header in the response
|
||||
|
||||
my $remaining = $length - tell( $output );
|
||||
if ( $response->code == 500 && !$remaining ) {
|
||||
return [
|
||||
500,
|
||||
[ 'Content-Type' => 'text/html' ],
|
||||
[ $response->error_as_HTML ]
|
||||
];
|
||||
}
|
||||
|
||||
# TODO we can pass $output to the response body without buffering all?
|
||||
|
||||
{
|
||||
my $length = 0;
|
||||
while ( $output->read( my $buffer, 4096 ) ) {
|
||||
$length += length($buffer);
|
||||
$response->add_content($buffer);
|
||||
}
|
||||
|
||||
if ( $length && !$response->content_length ) {
|
||||
$response->content_length($length);
|
||||
}
|
||||
}
|
||||
|
||||
return [
|
||||
$status,
|
||||
+[
|
||||
map {
|
||||
my $k = $_;
|
||||
map { ( $k => _cleanup_newline($_) ) } $response->headers->header($_);
|
||||
} $response->headers->header_field_names
|
||||
],
|
||||
[$response->content],
|
||||
];
|
||||
}
|
||||
|
||||
sub _cleanup_newline {
|
||||
local $_ = shift;
|
||||
s/\r?\n//g;
|
||||
return $_;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
CGI::Parse::PSGI - Parses CGI output and creates PSGI response out of it
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
use CGI::Parse::PSGI qw(parse_cgi_output);
|
||||
|
||||
my $output = YourApp->run;
|
||||
my $psgi_res = parse_cgi_output(\$output);
|
||||
|
||||
An option hash can also be passed:
|
||||
|
||||
my $psgi_res = parse_cgi_output(\$output, \%options);
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
CGI::Parse::PSGI exports one function C<parse_cgi_output> that takes a
|
||||
filehandle or a reference to a string to read a CGI script output, and
|
||||
creates a PSGI response (an array reference containing status code,
|
||||
headers and a body) by reading the output.
|
||||
|
||||
Use L<CGI::Emulate::PSGI> if you have a CGI I<code> not the I<output>,
|
||||
which takes care of automatically parsing the output, using this
|
||||
module, from your callback code.
|
||||
|
||||
=head1 OPTIONS
|
||||
|
||||
As mentioned above, C<parse_cgi_output> can accept an options hash as
|
||||
the second argument.
|
||||
|
||||
Currently the options available are:
|
||||
|
||||
=over 4
|
||||
|
||||
=item C<ignore_status_line>
|
||||
|
||||
A boolean value, defaulting to 0 (false). If true, the status in the
|
||||
HTTP protocol line is not used to set the default status in absence of
|
||||
a status header.
|
||||
|
||||
=back
|
||||
|
||||
The options can be supplied to earlier versions, and will be ignored
|
||||
without error. Hence you can preserve legacy behaviour like this:
|
||||
|
||||
parse_cgi_output(\$output, {ignore_status_line => 1});
|
||||
|
||||
This will ensure that if the script output includes an edge case
|
||||
like this:
|
||||
|
||||
HTTP/1.1 666 SNAFU
|
||||
Content-Type: text/plain
|
||||
|
||||
This should be OK!
|
||||
|
||||
then the old behaviour of ignoring the status line and returning 200
|
||||
is preserved.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Tatsuhiko Miyagawa
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<CGI::Emulate::PSGI>
|
||||
|
||||
=cut
|
||||
83
Perl OTRS/Kernel/cpan-lib/CGI/Pretty.pm
Normal file
83
Perl OTRS/Kernel/cpan-lib/CGI/Pretty.pm
Normal file
@@ -0,0 +1,83 @@
|
||||
package CGI::Pretty;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use if $] >= 5.019, 'deprecate';
|
||||
use CGI ();
|
||||
|
||||
$CGI::Pretty::VERSION = '4.36';
|
||||
$CGI::DefaultClass = __PACKAGE__;
|
||||
@CGI::Pretty::ISA = qw( CGI );
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $this = $class->SUPER::new( @_ );
|
||||
return bless $this, $class;
|
||||
}
|
||||
|
||||
sub import {
|
||||
|
||||
warn "CGI::Pretty is DEPRECATED and will be removed in a future release. Please see https://github.com/leejo/CGI.pm/issues/162 for more information";
|
||||
|
||||
my $self = shift;
|
||||
no strict 'refs';
|
||||
|
||||
# This causes modules to clash.
|
||||
undef %CGI::EXPORT;
|
||||
undef %CGI::EXPORT;
|
||||
|
||||
$self->_setup_symbols(@_);
|
||||
my ($callpack, $callfile, $callline) = caller;
|
||||
|
||||
# To allow overriding, search through the packages
|
||||
# Till we find one in which the correct subroutine is defined.
|
||||
my @packages = ($self,@{"$self\:\:ISA"});
|
||||
foreach my $sym (keys %CGI::EXPORT) {
|
||||
my $pck;
|
||||
my $def = $CGI::DefaultClass;
|
||||
foreach $pck (@packages) {
|
||||
if (defined(&{"$pck\:\:$sym"})) {
|
||||
$def = $pck;
|
||||
last;
|
||||
}
|
||||
}
|
||||
*{"${callpack}::$sym"} = \&{"$def\:\:$sym"};
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
CGI::Pretty - module to produce nicely formatted HTML code
|
||||
|
||||
=head1 CGI::Pretty IS DEPRECATED
|
||||
|
||||
It will be removed from the CGI distribution in a future release, so you
|
||||
should no longer use it and remove it from any code that currently uses it.
|
||||
|
||||
For now it has been reduced to a shell to prevent your code breaking, but
|
||||
the "pretty" functions will no longer output "pretty" HTML.
|
||||
|
||||
=head1 Alternatives
|
||||
|
||||
L<HTML::HTML5::Parser> + L<HTML::HTML5::Writer> + L<XML::LibXML::PrettyPrint>:
|
||||
|
||||
print HTML::HTML5::Writer->new(
|
||||
start_tags => 'force',
|
||||
end_tags => 'force',
|
||||
)->document(
|
||||
XML::LibXML::PrettyPrint->new_for_html( indent_string => "\t" )
|
||||
->pretty_print(
|
||||
HTML::HTML5::Parser->new->parse_string( $html_string )
|
||||
)
|
||||
);
|
||||
|
||||
L<Marpa::R2::HTML> (see the html_fmt script for examples)
|
||||
|
||||
L<HTML::Tidy>
|
||||
|
||||
L<HTML::Parser>
|
||||
|
||||
=cut
|
||||
311
Perl OTRS/Kernel/cpan-lib/CGI/Push.pm
Normal file
311
Perl OTRS/Kernel/cpan-lib/CGI/Push.pm
Normal file
@@ -0,0 +1,311 @@
|
||||
package CGI::Push;
|
||||
use if $] >= 5.019, 'deprecate';
|
||||
|
||||
my $appease_cpants_kwalitee = q/
|
||||
use strict;
|
||||
use warnings;
|
||||
#/;
|
||||
|
||||
$CGI::Push::VERSION='4.36';
|
||||
use CGI;
|
||||
use CGI::Util 'rearrange';
|
||||
@ISA = ('CGI');
|
||||
|
||||
$CGI::DefaultClass = 'CGI::Push';
|
||||
|
||||
# add do_push() and push_delay() to exported tags
|
||||
push(@{$CGI::EXPORT_TAGS{':standard'}},'do_push','push_delay');
|
||||
|
||||
sub do_push {
|
||||
my ($self,@p) = CGI::self_or_default(@_);
|
||||
|
||||
# unbuffer output
|
||||
$| = 1;
|
||||
srand;
|
||||
my ($random) = sprintf("%08.0f",rand()*1E8);
|
||||
my ($boundary) = "----=_NeXtPaRt$random";
|
||||
|
||||
my (@header);
|
||||
my ($type,$callback,$delay,$last_page,$cookie,$target,$expires,$nph,@other) = rearrange([TYPE,NEXT_PAGE,DELAY,LAST_PAGE,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p);
|
||||
$type = 'text/html' unless $type;
|
||||
$callback = \&simple_counter unless $callback && ref($callback) eq 'CODE';
|
||||
$delay = 1 unless defined($delay);
|
||||
$self->push_delay($delay);
|
||||
$nph = 1 unless defined($nph);
|
||||
|
||||
my(@o);
|
||||
foreach (@other) { push(@o,split("=")); }
|
||||
push(@o,'-Target'=>$target) if defined($target);
|
||||
push(@o,'-Cookie'=>$cookie) if defined($cookie);
|
||||
push(@o,'-Type'=>"multipart/x-mixed-replace;boundary=\"$boundary\"");
|
||||
push(@o,'-Server'=>"CGI.pm Push Module") if $nph;
|
||||
push(@o,'-Status'=>'200 OK');
|
||||
push(@o,'-nph'=>1) if $nph;
|
||||
print $self->header(@o);
|
||||
|
||||
$boundary = "$CGI::CRLF--$boundary";
|
||||
|
||||
print "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY.${boundary}$CGI::CRLF";
|
||||
|
||||
my (@contents) = &$callback($self,++$COUNTER);
|
||||
|
||||
# now we enter a little loop
|
||||
while (1) {
|
||||
print "Content-type: ${type}$CGI::CRLF$CGI::CRLF" unless $type =~ /^dynamic|heterogeneous$/i;
|
||||
print @contents;
|
||||
@contents = &$callback($self,++$COUNTER);
|
||||
if ((@contents) && defined($contents[0])) {
|
||||
print "${boundary}$CGI::CRLF";
|
||||
do_sleep($self->push_delay()) if $self->push_delay();
|
||||
} else {
|
||||
if ($last_page && ref($last_page) eq 'CODE') {
|
||||
print "${boundary}$CGI::CRLF";
|
||||
do_sleep($self->push_delay()) if $self->push_delay();
|
||||
print "Content-type: ${type}$CGI::CRLF$CGI::CRLF" unless $type =~ /^dynamic|heterogeneous$/i;
|
||||
print &$last_page($self,$COUNTER);
|
||||
}
|
||||
print "${boundary}--$CGI::CRLF";
|
||||
last;
|
||||
}
|
||||
}
|
||||
print "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY.$CGI::CRLF";
|
||||
}
|
||||
|
||||
sub simple_counter {
|
||||
my ($self,$count) = @_;
|
||||
return $self->start_html("CGI::Push Default Counter"),
|
||||
$self->h1("CGI::Push Default Counter"),
|
||||
"This page has been updated ",$self->strong($count)," times.",
|
||||
$self->hr(),
|
||||
$self->a({'-href'=>'http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html'},'CGI.pm home page'),
|
||||
$self->end_html;
|
||||
}
|
||||
|
||||
sub do_sleep {
|
||||
my $delay = shift;
|
||||
if ( ($delay >= 1) && ($delay!~/\./) ){
|
||||
sleep($delay);
|
||||
} else {
|
||||
select(undef,undef,undef,$delay);
|
||||
return $delay;
|
||||
}
|
||||
}
|
||||
|
||||
sub push_delay {
|
||||
my ($self,$delay) = CGI::self_or_default(@_);
|
||||
return defined($delay) ? $self->{'.delay'} =
|
||||
$delay : $self->{'.delay'};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
CGI::Push - Simple Interface to Server Push
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use CGI::Push qw(:standard);
|
||||
|
||||
do_push(
|
||||
-next_page => \&next_page,
|
||||
-last_page => \&last_page,
|
||||
-delay => 0.5
|
||||
);
|
||||
|
||||
sub next_page {
|
||||
my($q,$counter) = @_;
|
||||
return undef if $counter >= 10;
|
||||
....
|
||||
}
|
||||
|
||||
sub last_page {
|
||||
my($q,$counter) = @_;
|
||||
return ...
|
||||
}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
CGI::Push is a subclass of the CGI object created by CGI.pm. It is
|
||||
specialized for server push operations, which allow you to create
|
||||
animated pages whose content changes at regular intervals.
|
||||
|
||||
You provide CGI::Push with a pointer to a subroutine that will draw
|
||||
one page. Every time your subroutine is called, it generates a new
|
||||
page. The contents of the page will be transmitted to the browser
|
||||
in such a way that it will replace what was there beforehand. The
|
||||
technique will work with HTML pages as well as with graphics files,
|
||||
allowing you to create animated GIFs.
|
||||
|
||||
Only Netscape Navigator supports server push. Internet Explorer
|
||||
browsers do not.
|
||||
|
||||
=head1 USING CGI::Push
|
||||
|
||||
CGI::Push adds one new method to the standard CGI suite, do_push().
|
||||
When you call this method, you pass it a reference to a subroutine
|
||||
that is responsible for drawing each new page, an interval delay, and
|
||||
an optional subroutine for drawing the last page. Other optional
|
||||
parameters include most of those recognized by the CGI header()
|
||||
method.
|
||||
|
||||
You may call do_push() in the object oriented manner or not, as you
|
||||
prefer:
|
||||
|
||||
use CGI::Push;
|
||||
$q = CGI::Push->new;
|
||||
$q->do_push(-next_page=>\&draw_a_page);
|
||||
|
||||
-or-
|
||||
|
||||
use CGI::Push qw(:standard);
|
||||
do_push(-next_page=>\&draw_a_page);
|
||||
|
||||
Parameters are as follows:
|
||||
|
||||
=over 4
|
||||
|
||||
=item -next_page
|
||||
|
||||
do_push(-next_page=>\&my_draw_routine);
|
||||
|
||||
This required parameter points to a reference to a subroutine responsible for
|
||||
drawing each new page. The subroutine should expect two parameters
|
||||
consisting of the CGI object and a counter indicating the number
|
||||
of times the subroutine has been called. It should return the
|
||||
contents of the page as an B<array> of one or more items to print.
|
||||
It can return a false value (or an empty array) in order to abort the
|
||||
redrawing loop and print out the final page (if any)
|
||||
|
||||
sub my_draw_routine {
|
||||
my($q,$counter) = @_;
|
||||
return undef if $counter > 100;
|
||||
...
|
||||
}
|
||||
|
||||
You are of course free to refer to create and use global variables
|
||||
within your draw routine in order to achieve special effects.
|
||||
|
||||
=item -last_page
|
||||
|
||||
This optional parameter points to a reference to the subroutine
|
||||
responsible for drawing the last page of the series. It is called
|
||||
after the -next_page routine returns a false value. The subroutine
|
||||
itself should have exactly the same calling conventions as the
|
||||
-next_page routine.
|
||||
|
||||
=item -type
|
||||
|
||||
This optional parameter indicates the content type of each page. It
|
||||
defaults to "text/html". Normally the module assumes that each page
|
||||
is of a homogeneous MIME type. However if you provide either of the
|
||||
magic values "heterogeneous" or "dynamic" (the latter provided for the
|
||||
convenience of those who hate long parameter names), you can specify
|
||||
the MIME type -- and other header fields -- on a per-page basis. See
|
||||
"heterogeneous pages" for more details.
|
||||
|
||||
=item -delay
|
||||
|
||||
This indicates the delay, in seconds, between frames. Smaller delays
|
||||
refresh the page faster. Fractional values are allowed.
|
||||
|
||||
B<If not specified, -delay will default to 1 second>
|
||||
|
||||
=item -cookie, -target, -expires, -nph
|
||||
|
||||
These have the same meaning as the like-named parameters in
|
||||
CGI::header().
|
||||
|
||||
If not specified, -nph will default to 1 (as needed for many servers, see below).
|
||||
|
||||
=back
|
||||
|
||||
=head2 Heterogeneous Pages
|
||||
|
||||
Ordinarily all pages displayed by CGI::Push share a common MIME type.
|
||||
However by providing a value of "heterogeneous" or "dynamic" in the
|
||||
do_push() -type parameter, you can specify the MIME type of each page
|
||||
on a case-by-case basis.
|
||||
|
||||
If you use this option, you will be responsible for producing the
|
||||
HTTP header for each page. Simply modify your draw routine to
|
||||
look like this:
|
||||
|
||||
sub my_draw_routine {
|
||||
my($q,$counter) = @_;
|
||||
return header('text/html'), # note we're producing the header here
|
||||
....
|
||||
}
|
||||
|
||||
You can add any header fields that you like, but some (cookies and
|
||||
status fields included) may not be interpreted by the browser. One
|
||||
interesting effect is to display a series of pages, then, after the
|
||||
last page, to redirect the browser to a new URL. Because redirect()
|
||||
does b<not> work, the easiest way is with a -refresh header field,
|
||||
as shown below:
|
||||
|
||||
sub my_draw_routine {
|
||||
my($q,$counter) = @_;
|
||||
return undef if $counter > 10;
|
||||
return header('text/html'), # note we're producing the header here
|
||||
...
|
||||
}
|
||||
|
||||
sub my_last_page {
|
||||
return header(-refresh=>'5; URL=http://somewhere.else/finished.html',
|
||||
-type=>'text/html'),
|
||||
...
|
||||
}
|
||||
|
||||
=head2 Changing the Page Delay on the Fly
|
||||
|
||||
If you would like to control the delay between pages on a page-by-page
|
||||
basis, call push_delay() from within your draw routine. push_delay()
|
||||
takes a single numeric argument representing the number of seconds you
|
||||
wish to delay after the current page is displayed and before
|
||||
displaying the next one. The delay may be fractional. Without
|
||||
parameters, push_delay() just returns the current delay.
|
||||
|
||||
=head1 INSTALLING CGI::Push SCRIPTS
|
||||
|
||||
Server push scripts must be installed as no-parsed-header (NPH)
|
||||
scripts in order to work correctly on many servers. On Unix systems,
|
||||
this is most often accomplished by prefixing the script's name with "nph-".
|
||||
Recognition of NPH scripts happens automatically with WebSTAR and
|
||||
Microsoft IIS. Users of other servers should see their documentation
|
||||
for help.
|
||||
|
||||
Apache web server from version 1.3b2 on does not need server
|
||||
push scripts installed as NPH scripts: the -nph parameter to do_push()
|
||||
may be set to a false value to disable the extra headers needed by an
|
||||
NPH script.
|
||||
|
||||
=head1 AUTHOR INFORMATION
|
||||
|
||||
The CGI.pm distribution is copyright 1995-2007, Lincoln D. Stein. It is
|
||||
distributed under GPL and the Artistic License 2.0. It is currently
|
||||
maintained by Lee Johnson with help from many contributors.
|
||||
|
||||
Address bug reports and comments to: https://github.com/leejo/CGI.pm/issues
|
||||
|
||||
The original bug tracker can be found at: https://rt.cpan.org/Public/Dist/Display.html?Queue=CGI.pm
|
||||
|
||||
When sending bug reports, please provide the version of CGI.pm, the version of
|
||||
Perl, the name and version of your Web server, and the name and version of the
|
||||
operating system you are using. If the problem is even remotely browser
|
||||
dependent, please provide information about the affected browsers as well.
|
||||
Copyright 1995-1998, Lincoln D. Stein. All rights reserved.
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
This section intentionally left blank.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<CGI::Carp>, L<CGI>
|
||||
|
||||
=cut
|
||||
|
||||
19
Perl OTRS/Kernel/cpan-lib/CGI/Switch.pm
Normal file
19
Perl OTRS/Kernel/cpan-lib/CGI/Switch.pm
Normal file
@@ -0,0 +1,19 @@
|
||||
package CGI::Switch;
|
||||
use if $] >= 5.019, 'deprecate';
|
||||
use CGI;
|
||||
|
||||
$VERSION = '1.02';
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
CGI::Switch - Backward compatibility module for defunct CGI::Switch
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Do not use this module. It is deprecated.
|
||||
|
||||
=cut
|
||||
351
Perl OTRS/Kernel/cpan-lib/CGI/Util.pm
Normal file
351
Perl OTRS/Kernel/cpan-lib/CGI/Util.pm
Normal file
@@ -0,0 +1,351 @@
|
||||
package CGI::Util;
|
||||
use base 'Exporter';
|
||||
require 5.008001;
|
||||
use strict;
|
||||
use if $] >= 5.019, 'deprecate';
|
||||
our @EXPORT_OK = qw(rearrange rearrange_header make_attributes unescape escape
|
||||
expires ebcdic2ascii ascii2ebcdic);
|
||||
|
||||
our $VERSION = '4.36';
|
||||
|
||||
our $_EBCDIC = "\t" ne "\011";
|
||||
|
||||
my $appease_cpants_kwalitee = q/
|
||||
use strict;
|
||||
use warnings;
|
||||
#/;
|
||||
|
||||
# (ord('^') == 95) for codepage 1047 as on os390, vmesa
|
||||
our @A2E = (
|
||||
0, 1, 2, 3, 55, 45, 46, 47, 22, 5, 21, 11, 12, 13, 14, 15,
|
||||
16, 17, 18, 19, 60, 61, 50, 38, 24, 25, 63, 39, 28, 29, 30, 31,
|
||||
64, 90,127,123, 91,108, 80,125, 77, 93, 92, 78,107, 96, 75, 97,
|
||||
240,241,242,243,244,245,246,247,248,249,122, 94, 76,126,110,111,
|
||||
124,193,194,195,196,197,198,199,200,201,209,210,211,212,213,214,
|
||||
215,216,217,226,227,228,229,230,231,232,233,173,224,189, 95,109,
|
||||
121,129,130,131,132,133,134,135,136,137,145,146,147,148,149,150,
|
||||
151,152,153,162,163,164,165,166,167,168,169,192, 79,208,161, 7,
|
||||
32, 33, 34, 35, 36, 37, 6, 23, 40, 41, 42, 43, 44, 9, 10, 27,
|
||||
48, 49, 26, 51, 52, 53, 54, 8, 56, 57, 58, 59, 4, 20, 62,255,
|
||||
65,170, 74,177,159,178,106,181,187,180,154,138,176,202,175,188,
|
||||
144,143,234,250,190,160,182,179,157,218,155,139,183,184,185,171,
|
||||
100,101, 98,102, 99,103,158,104,116,113,114,115,120,117,118,119,
|
||||
172,105,237,238,235,239,236,191,128,253,254,251,252,186,174, 89,
|
||||
68, 69, 66, 70, 67, 71,156, 72, 84, 81, 82, 83, 88, 85, 86, 87,
|
||||
140, 73,205,206,203,207,204,225,112,221,222,219,220,141,142,223
|
||||
);
|
||||
our @E2A = (
|
||||
0, 1, 2, 3,156, 9,134,127,151,141,142, 11, 12, 13, 14, 15,
|
||||
16, 17, 18, 19,157, 10, 8,135, 24, 25,146,143, 28, 29, 30, 31,
|
||||
128,129,130,131,132,133, 23, 27,136,137,138,139,140, 5, 6, 7,
|
||||
144,145, 22,147,148,149,150, 4,152,153,154,155, 20, 21,158, 26,
|
||||
32,160,226,228,224,225,227,229,231,241,162, 46, 60, 40, 43,124,
|
||||
38,233,234,235,232,237,238,239,236,223, 33, 36, 42, 41, 59, 94,
|
||||
45, 47,194,196,192,193,195,197,199,209,166, 44, 37, 95, 62, 63,
|
||||
248,201,202,203,200,205,206,207,204, 96, 58, 35, 64, 39, 61, 34,
|
||||
216, 97, 98, 99,100,101,102,103,104,105,171,187,240,253,254,177,
|
||||
176,106,107,108,109,110,111,112,113,114,170,186,230,184,198,164,
|
||||
181,126,115,116,117,118,119,120,121,122,161,191,208, 91,222,174,
|
||||
172,163,165,183,169,167,182,188,189,190,221,168,175, 93,180,215,
|
||||
123, 65, 66, 67, 68, 69, 70, 71, 72, 73,173,244,246,242,243,245,
|
||||
125, 74, 75, 76, 77, 78, 79, 80, 81, 82,185,251,252,249,250,255,
|
||||
92,247, 83, 84, 85, 86, 87, 88, 89, 90,178,212,214,210,211,213,
|
||||
48, 49, 50, 51, 52, 53, 54, 55, 56, 57,179,219,220,217,218,159
|
||||
);
|
||||
|
||||
if ($_EBCDIC && ord('^') == 106) { # as in the BS2000 posix-bc coded character set
|
||||
$A2E[91] = 187; $A2E[92] = 188; $A2E[94] = 106; $A2E[96] = 74;
|
||||
$A2E[123] = 251; $A2E[125] = 253; $A2E[126] = 255; $A2E[159] = 95;
|
||||
$A2E[162] = 176; $A2E[166] = 208; $A2E[168] = 121; $A2E[172] = 186;
|
||||
$A2E[175] = 161; $A2E[217] = 224; $A2E[219] = 221; $A2E[221] = 173;
|
||||
$A2E[249] = 192;
|
||||
|
||||
$E2A[74] = 96; $E2A[95] = 159; $E2A[106] = 94; $E2A[121] = 168;
|
||||
$E2A[161] = 175; $E2A[173] = 221; $E2A[176] = 162; $E2A[186] = 172;
|
||||
$E2A[187] = 91; $E2A[188] = 92; $E2A[192] = 249; $E2A[208] = 166;
|
||||
$E2A[221] = 219; $E2A[224] = 217; $E2A[251] = 123; $E2A[253] = 125;
|
||||
$E2A[255] = 126;
|
||||
}
|
||||
elsif ($_EBCDIC && ord('^') == 176) { # as in codepage 037 on os400
|
||||
$A2E[10] = 37; $A2E[91] = 186; $A2E[93] = 187; $A2E[94] = 176;
|
||||
$A2E[133] = 21; $A2E[168] = 189; $A2E[172] = 95; $A2E[221] = 173;
|
||||
|
||||
$E2A[21] = 133; $E2A[37] = 10; $E2A[95] = 172; $E2A[173] = 221;
|
||||
$E2A[176] = 94; $E2A[186] = 91; $E2A[187] = 93; $E2A[189] = 168;
|
||||
}
|
||||
|
||||
# Smart rearrangement of parameters to allow named parameter
|
||||
# calling. We do the rearrangement if:
|
||||
# the first parameter begins with a -
|
||||
|
||||
sub rearrange {
|
||||
my ($order,@param) = @_;
|
||||
my ($result, $leftover) = _rearrange_params( $order, @param );
|
||||
push @$result, make_attributes( $leftover, defined $CGI::Q ? $CGI::Q->{escape} : 1 )
|
||||
if keys %$leftover;
|
||||
@$result;
|
||||
}
|
||||
|
||||
sub rearrange_header {
|
||||
my ($order,@param) = @_;
|
||||
|
||||
my ($result,$leftover) = _rearrange_params( $order, @param );
|
||||
push @$result, make_attributes( $leftover, 0, 1 ) if keys %$leftover;
|
||||
|
||||
@$result;
|
||||
}
|
||||
|
||||
sub _rearrange_params {
|
||||
my($order,@param) = @_;
|
||||
return [] unless @param;
|
||||
|
||||
if (ref($param[0]) eq 'HASH') {
|
||||
@param = %{$param[0]};
|
||||
} else {
|
||||
return \@param
|
||||
unless (defined($param[0]) && substr($param[0],0,1) eq '-');
|
||||
}
|
||||
|
||||
# map parameters into positional indices
|
||||
my ($i,%pos);
|
||||
$i = 0;
|
||||
foreach (@$order) {
|
||||
foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{lc($_)} = $i; }
|
||||
$i++;
|
||||
}
|
||||
|
||||
my %params_as_hash = ( @param );
|
||||
|
||||
my (@result,%leftover);
|
||||
$#result = $#$order; # preextend
|
||||
|
||||
foreach my $k (
|
||||
# sort keys alphabetically but favour certain keys before others
|
||||
# specifically for the case where there could be several options
|
||||
# for a param key, but one should be preferred (see GH #155)
|
||||
sort {
|
||||
if ( $a =~ /content/i ) { return 1 }
|
||||
elsif ( $b =~ /content/i ) { return -1 }
|
||||
else { $a cmp $b }
|
||||
}
|
||||
keys( %params_as_hash )
|
||||
) {
|
||||
my $key = lc($k);
|
||||
$key =~ s/^\-//;
|
||||
if (exists $pos{$key}) {
|
||||
$result[$pos{$key}] = $params_as_hash{$k};
|
||||
} else {
|
||||
$leftover{$key} = $params_as_hash{$k};
|
||||
}
|
||||
}
|
||||
|
||||
return \@result, \%leftover;
|
||||
}
|
||||
|
||||
sub make_attributes {
|
||||
my $attr = shift;
|
||||
return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
|
||||
my $escape = shift || 0;
|
||||
my $do_not_quote = shift;
|
||||
|
||||
my $quote = $do_not_quote ? '' : '"';
|
||||
|
||||
my @attr_keys= sort keys %$attr;
|
||||
my(@att);
|
||||
foreach (@attr_keys) {
|
||||
my($key) = $_;
|
||||
$key=~s/^\-//; # get rid of initial - if present
|
||||
|
||||
# old way: breaks EBCDIC!
|
||||
# $key=~tr/A-Z_/a-z-/; # parameters are lower case, use dashes
|
||||
|
||||
($key="\L$key") =~ tr/_/-/; # parameters are lower case, use dashes
|
||||
|
||||
my $value = $escape ? simple_escape($attr->{$_}) : $attr->{$_};
|
||||
push(@att,defined($attr->{$_}) ? qq/$key=$quote$value$quote/ : qq/$key/);
|
||||
}
|
||||
return sort @att;
|
||||
}
|
||||
|
||||
sub simple_escape {
|
||||
return unless defined(my $toencode = shift);
|
||||
$toencode =~ s{&}{&}gso;
|
||||
$toencode =~ s{<}{<}gso;
|
||||
$toencode =~ s{>}{>}gso;
|
||||
$toencode =~ s{\"}{"}gso;
|
||||
# Doesn't work. Can't work. forget it.
|
||||
# $toencode =~ s{\x8b}{‹}gso;
|
||||
# $toencode =~ s{\x9b}{›}gso;
|
||||
$toencode;
|
||||
}
|
||||
|
||||
sub utf8_chr {
|
||||
my $c = shift(@_);
|
||||
my $u = chr($c);
|
||||
utf8::encode($u); # drop utf8 flag
|
||||
return $u;
|
||||
}
|
||||
|
||||
# unescape URL-encoded data
|
||||
sub unescape {
|
||||
shift() if @_ > 0 and (ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
|
||||
my $todecode = shift;
|
||||
return undef unless defined($todecode);
|
||||
$todecode =~ tr/+/ /; # pluses become spaces
|
||||
if ($_EBCDIC) {
|
||||
$todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
|
||||
} else {
|
||||
# handle surrogate pairs first -- dankogai. Ref: http://unicode.org/faq/utf_bom.html#utf16-2
|
||||
$todecode =~ s{
|
||||
%u([Dd][89a-bA-B][0-9a-fA-F]{2}) # hi
|
||||
%u([Dd][c-fC-F][0-9a-fA-F]{2}) # lo
|
||||
}{
|
||||
utf8_chr(
|
||||
0x10000
|
||||
+ (hex($1) - 0xD800) * 0x400
|
||||
+ (hex($2) - 0xDC00)
|
||||
)
|
||||
}gex;
|
||||
$todecode =~ s/%(?:([0-9a-fA-F]{2})|u([0-9a-fA-F]{4}))/
|
||||
defined($1)? chr hex($1) : utf8_chr(hex($2))/ge;
|
||||
}
|
||||
return $todecode;
|
||||
}
|
||||
|
||||
# URL-encode data
|
||||
#
|
||||
# We cannot use the %u escapes, they were rejected by W3C, so the official
|
||||
# way is %XX-escaped utf-8 encoding.
|
||||
# Naturally, Unicode strings have to be converted to their utf-8 byte
|
||||
# representation.
|
||||
# Byte strings were traditionally used directly as a sequence of octets.
|
||||
# This worked if they actually represented binary data (i.e. in CGI::Compress).
|
||||
# This also worked if these byte strings were actually utf-8 encoded; e.g.,
|
||||
# when the source file used utf-8 without the appropriate "use utf8;".
|
||||
# This fails if the byte string is actually a Latin 1 encoded string, but it
|
||||
# was always so and cannot be fixed without breaking the binary data case.
|
||||
# -- Stepan Kasal <skasal@redhat.com>
|
||||
#
|
||||
|
||||
sub escape {
|
||||
# If we being called in an OO-context, discard the first argument.
|
||||
shift() if @_ > 1 and ( ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
|
||||
my $toencode = shift;
|
||||
return undef unless defined($toencode);
|
||||
utf8::encode($toencode) if utf8::is_utf8($toencode);
|
||||
if ($_EBCDIC) {
|
||||
$toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg;
|
||||
} else {
|
||||
$toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",ord($1))/eg;
|
||||
}
|
||||
return $toencode;
|
||||
}
|
||||
|
||||
# This internal routine creates date strings suitable for use in
|
||||
# cookies and HTTP headers. (They differ, unfortunately.)
|
||||
# Thanks to Mark Fisher for this.
|
||||
sub expires {
|
||||
my($time,$format) = @_;
|
||||
$format ||= 'http';
|
||||
|
||||
my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
|
||||
my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
|
||||
|
||||
# pass through preformatted dates for the sake of expire_calc()
|
||||
$time = expire_calc($time);
|
||||
return $time unless $time =~ /^\d+$/;
|
||||
|
||||
# make HTTP/cookie date string from GMT'ed time
|
||||
# (cookies use '-' as date separator, HTTP uses ' ')
|
||||
my($sc) = ' ';
|
||||
$sc = '-' if $format eq "cookie";
|
||||
my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
|
||||
$year += 1900;
|
||||
return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
|
||||
$WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
|
||||
}
|
||||
|
||||
# This internal routine creates an expires time exactly some number of
|
||||
# hours from the current time. It incorporates modifications from
|
||||
# Mark Fisher.
|
||||
sub expire_calc {
|
||||
my($time) = @_;
|
||||
my(%mult) = ('s'=>1,
|
||||
'm'=>60,
|
||||
'h'=>60*60,
|
||||
'd'=>60*60*24,
|
||||
'M'=>60*60*24*30,
|
||||
'y'=>60*60*24*365);
|
||||
# format for time can be in any of the forms...
|
||||
# "now" -- expire immediately
|
||||
# "+180s" -- in 180 seconds
|
||||
# "+2m" -- in 2 minutes
|
||||
# "+12h" -- in 12 hours
|
||||
# "+1d" -- in 1 day
|
||||
# "+3M" -- in 3 months
|
||||
# "+2y" -- in 2 years
|
||||
# "-3m" -- 3 minutes ago(!)
|
||||
# If you don't supply one of these forms, we assume you are
|
||||
# specifying the date yourself
|
||||
my($offset);
|
||||
if (!$time || (lc($time) eq 'now')) {
|
||||
$offset = 0;
|
||||
} elsif ($time=~/^\d+/) {
|
||||
return $time;
|
||||
} elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([smhdMy])/) {
|
||||
$offset = ($mult{$2} || 1)*$1;
|
||||
} else {
|
||||
return $time;
|
||||
}
|
||||
my $cur_time = time;
|
||||
return ($cur_time+$offset);
|
||||
}
|
||||
|
||||
sub ebcdic2ascii {
|
||||
my $data = shift;
|
||||
$data =~ s/(.)/chr $E2A[ord($1)]/ge;
|
||||
$data;
|
||||
}
|
||||
|
||||
sub ascii2ebcdic {
|
||||
my $data = shift;
|
||||
$data =~ s/(.)/chr $A2E[ord($1)]/ge;
|
||||
$data;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
CGI::Util - Internal utilities used by CGI module
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
none
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
no public subroutines
|
||||
|
||||
=head1 AUTHOR INFORMATION
|
||||
|
||||
The CGI.pm distribution is copyright 1995-2007, Lincoln D. Stein. It is
|
||||
distributed under GPL and the Artistic License 2.0. It is currently
|
||||
maintained by Lee Johnson with help from many contributors.
|
||||
|
||||
Address bug reports and comments to: https://github.com/leejo/CGI.pm/issues
|
||||
|
||||
The original bug tracker can be found at: https://rt.cpan.org/Public/Dist/Display.html?Queue=CGI.pm
|
||||
|
||||
When sending bug reports, please provide the version of CGI.pm, the version of
|
||||
Perl, the name and version of your Web server, and the name and version of the
|
||||
operating system you are using. If the problem is even remotely browser
|
||||
dependent, please provide information about the affected browsers as well.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<CGI>
|
||||
|
||||
=cut
|
||||
Reference in New Issue
Block a user