view release on metacpan or  search on metacpan

lib/CGI/Compile.pm  view on Meta::CPAN

        }
        },
        '};';

    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__

=encoding utf-8

=for stopwords

=head1 NAME

CGI::Compile - Compile .cgi scripts to a code reference like ModPerl::Registry

=head1 SYNOPSIS

  use CGI::Compile;
  my $sub = CGI::Compile->compile("/path/to/script.cgi");

=head1 DESCRIPTION

CGI::Compile is a utility to compile CGI scripts into a code
reference that can run many times on its own namespace, as long as the
script is ready to run on a persistent environment.

B<NOTE:> for best results, load L<CGI::Compile> before any modules used by your
CGIs.

=head1 RUN ON PSGI

Combined with L<CGI::Emulate::PSGI>, your CGI script can be turned
into a persistent PSGI application like:

  use CGI::Emulate::PSGI;
  use CGI::Compile;

  my $cgi_script = "/path/to/foo.cgi";
  my $sub = CGI::Compile->compile($cgi_script);
  my $app = CGI::Emulate::PSGI->handler($sub);

  # $app is a PSGI application