CGI-Compile
view release on metacpan or search on metacpan
lib/CGI/Compile.pm view on Meta::CPAN
sub $proto {
my \$exit_code = shift;
\$orig->(\$exit_code) if \$USE_REAL_EXIT;
die [ "EXIT\n", \$exit_code || 0 ]
};
};
die $@ if $@;
}
my %anon;
sub compile {
my($class, $script, $package) = @_;
my $self = ref $class ? $class : $class->new;
my($code, $path, $dir, $subname);
if (ref $script eq 'SCALAR') {
$code = $$script;
$package ||= (caller)[0];
$subname = '__CGI' . $anon{$package}++ . '__';
} else {
$code = $self->_read_source($script);
$path = Cwd::abs_path($script);
$dir = File::Basename::dirname($path);
my $genned_package;
($genned_package, $subname) = $self->_build_subname($path || $script);
$package ||= $genned_package;
}
my $warnings = $code =~ /^#!.*\s-w\b/ ? 1 : 0;
$code =~ s/^__END__\r?\n.*//ms;
$code =~ s/^__DATA__\r?\n(.*)//ms;
my $data = defined $1 ? $1 : '';
# TODO handle nph and command line switches?
my $eval = join '',
"package $package;",
'sub {',
'local $CGI::Compile::USE_REAL_EXIT = 0;',
"\nCGI::initialize_globals() if defined &CGI::initialize_globals;",
'local ($0, $CGI::Compile::_dir, *DATA);',
'{ my ($data, $path, $dir) = @_[1..3];',
($path ? '$0 = $path;' : ''),
($dir ? '$CGI::Compile::_dir = File::pushd::pushd $dir;' : ''),
q{open DATA, '<', \$data;},
'}',
# NOTE: this is a workaround to fix a problem in Perl 5.10
q(local @SIG{keys %SIG} = do { no warnings 'uninitialized'; @{[]} = values %SIG };),
"local \$^W = $warnings;",
'my $rv = eval {',
'local @ARGV = @{ $_[4] };', # args to @ARGV
'local @_ = @{ $_[4] };', # args to @_ as well
($path ? "\n#line 1 $path\n" : ''),
$code,
"\n};",
q{
{
no warnings qw(uninitialized numeric pack);
my $self = shift;
my $exit_val = unpack('C', pack('C', sprintf('%.0f', $rv)));
if ($@) {
die $@ unless (
ref($@) eq 'ARRAY' and
$@->[0] eq "EXIT\n"
);
my $exit_param = unpack('C', pack('C', sprintf('%.0f', $@->[1])));
if ($exit_param != 0 && !$CGI::Compile::RETURN_EXIT_VAL && !$self->{return_exit_val}) {
die "exited nonzero: $exit_param";
}
$exit_val = $exit_param;
}
return $exit_val;
}
},
'};';
my $sub = do {
no warnings 'uninitialized'; # for 5.8
# NOTE: this is a workaround to fix a problem in Perl 5.10
local @SIG{keys %SIG} = @{[]} = values %SIG;
local $USE_REAL_EXIT = 0;
my $code = $self->_eval($eval);
my $exception = $@;
die "Could not compile $script: $exception" if $exception;
subname "${package}::$subname", sub {
my @args = @_;
# this is necessary for MSWin32
my $orig_warn = $SIG{__WARN__} || sub { warn(@_) };
local $SIG{__WARN__} = sub { $orig_warn->(@_) unless $_[0] =~ /^No such signal/ };
$code->($self, $data, $path, $dir, \@args)
};
};
return $sub;
}
sub _read_source {
my($self, $file) = @_;
open my $fh, "<", $file or die "$file: $!";
return do { local $/; <$fh> };
}
sub _build_subname {
my($self, $path) = @_;
lib/CGI/Compile.pm view on Meta::CPAN
Otherwise you can just call L</compile> as a class method and the object will
be instantiated with a C<namespace_root> of C<CGI::Compile::ROOT>.
You can also set C<return_exit_val>, see L</RETURN CODE> for details.
Example:
my $compiler = CGI::Compile->new(namespace_root => 'My::CGIs');
my $cgi = $compiler->compile('/var/www/cgi-bin/my.cgi');
=head2 compile
Takes either a path to a perl CGI script or a source code and some
other optional parameters and wraps it into a coderef for execution.
Can be called as either a class or instance method, see L</new> above.
Parameters:
=over 4
=item * C<$cgi_script>
Path to perl CGI script file or a scalar reference that contains the
source code of CGI script, required.
=item * C<$package>
Optional, package to install the script into, defaults to the path parts of the
script joined with C<_>, and all special characters converted to C<_%2x>,
prepended with C<CGI::Compile::ROOT::>.
E.g.:
/var/www/cgi-bin/foo.cgi
becomes:
CGI::Compile::ROOT::var_www_cgi_2dbin_foo_2ecgi
=back
Returns:
=over 4
=item * C<$coderef>
C<$cgi_script> or C<$$code> compiled to coderef.
=back
=head1 SCRIPT ENVIRONMENT
=head2 ARGUMENTS
Things like the query string and form data should generally be in the
appropriate environment variables that things like L<CGI> expect.
You can also pass arguments to the generated coderef, they will be
locally aliased to C<@_> and C<@ARGV>.
=head2 C<BEGIN> and C<END> blocks
C<BEGIN> blocks are called once when the script is compiled.
C<END> blocks are called when the Perl interpreter is unloaded.
This may cause surprising effects. Suppose, for instance, a script that runs
in a forking web server and is loaded in the parent process. C<END>
blocks will be called once for each worker process and another time
for the parent process while C<BEGIN> blocks are called only by the
parent process.
=head2 C<%SIG>
The C<%SIG> hash is preserved meaning the script can change signal
handlers at will. The next invocation gets a pristine C<%SIG> again.
=head2 C<exit> and exceptions
Calls to C<exit> are intercepted and converted into exceptions. When
the script calls C<exit 19> and exception is thrown and C<$@> contains
a reference pointing to the array
["EXIT\n", 19]
Naturally, L<perlvar/$^S> (exceptions being caught) is always C<true>
during script runtime.
If you really want to exit the process call C<CORE::exit> or set
C<$CGI::Compile::USE_REAL_EXIT> to true before calling exit:
$CGI::Compile::USE_REAL_EXIT = 1;
exit 19;
Other exceptions are propagated out of the generated coderef. The coderef's
caller is responsible to catch them or the process will exit.
=head2 Return Code
The generated coderef's exit value is either the parameter that was
passed to C<exit> or the value of the last statement of the script. The
return code is converted into an integer.
On a C<0> exit, the coderef will return C<0>.
On an explicit non-zero exit, by default an exception will be thrown of
the form:
exited nonzero: <n>
where C<n> is the exit value.
This only happens for an actual call to L<perfunc/exit>, not if the last
statement value is non-zero, which will just be returned from the
coderef.
If you would prefer that explicit non-zero exit values are returned,
rather than thrown, pass:
return_exit_val => 1
( run in 0.400 second using v1.01-cache-2.11-cpan-eab888a1d7d )