File Coverage

blib/lib/CGI/Compile.pm

Criterion	Covered	Total	%
statement	110	111	99.1
branch	33	44	75.0
condition	14	25	56.0
subroutine	21	21	100.0
pod	2	2	100.0
total	180	203	88.6

package CGI::Compile;

use strict;
use 5.008_001;

our $VERSION = '0.27';

use Cwd;
use File::Basename;
use File::Spec::Functions;
use File::pushd;
use File::Temp;
use File::Spec;
use File::Path;
use Sub::Name 'subname';

our $RETURN_EXIT_VAL = undef;

sub new {
    my ($class, %opts) = @_;

    $opts{namespace_root} ||= 'CGI::Compile::ROOT';

    bless \%opts, $class;
}

our $USE_REAL_EXIT;
BEGIN {
    $USE_REAL_EXIT = 1;

    my $orig = *CORE::GLOBAL::exit{CODE};

    my $proto = $orig ? prototype $orig : prototype 'CORE::exit';

    $proto = $proto ? "($proto)" : '';

    $orig ||= sub {
        my $exit_code = shift;

        CORE::exit(defined $exit_code ? $exit_code : 0);
    };

    no warnings 'redefine';

    *CORE::GLOBAL::exit = eval qq{
        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) = @_;

    my ($volume, $dirs, $file) = File::Spec::Functions::splitpath($path);
    my @dirs = File::Spec::Functions::splitdir($dirs);

    my $name    = $file;
    my $package = join '_', grep { defined && length } $volume, @dirs, $name;

    # Escape everything into valid perl identifiers
    s/([^A-Za-z0-9_])/sprintf("_%2x", unpack("C", $1))/eg for $package, $name;

    # make sure the identifiers don't start with a digit
    s/^(\d)/_$1/ for $package, $name;

    $package = $self->{namespace_root} . ($package ? "::$package" : '');

    return ($package, $name);
}

# define tmp_dir value later on first usage, otherwise all children
# share the same directory when forked
my $tmp_dir;
sub _eval {
    my $code = \$_[1];

    # we use a tmpdir chmodded to 0700 so that the tempfiles are secure
    $tmp_dir ||= File::Spec->catfile(File::Spec->tmpdir, "cgi_compile_$$");

    if (! -d $tmp_dir) {
        mkdir $tmp_dir          or die "Could not mkdir $tmp_dir: $!";
        chmod 0700, $tmp_dir    or die "Could not chmod 0700 $tmp_dir: $!";
    }

    my ($fh, $fname) = File::Temp::tempfile('cgi_compile_XXXXX',
        UNLINK => 1, SUFFIX => '.pm', DIR => $tmp_dir);

    print $fh $$code;
    close $fh;

    my $sub = do $fname;

    unlink $fname or die "Could not delete $fname: $!";

    return $sub;
}

END {
    if ($tmp_dir and -d $tmp_dir) {
        File::Path::remove_tree($tmp_dir);
    }
}

1;

__END__