CGI-Compile
view release on metacpan - search on metacpan
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) = @_;
view all matches for this distributionview release on metacpan - search on metacpan
( run in 1.595 second using v1.00-cache-2.02-grep-82fe00e-cpan-72ae3ad1e6da )