forked from github/Quit.mwForum
141 lines
3.3 KiB
Perl
141 lines
3.3 KiB
Perl
#
|
|
# Copied from: https://metacpan.org/release/DOUGM/ExtUtils-Embed-1.14/source/lib/Embed/Persistent.pm
|
|
# No notice found so maybe Perl license.
|
|
#
|
|
|
|
#package Embed::Persistent;
|
|
package Persistent;
|
|
|
|
use strict;
|
|
use FileHandle ();
|
|
use Carp 'croak';
|
|
use vars qw($VERSION);
|
|
$VERSION = (qw$Revision: 1.10 $)[1];
|
|
|
|
sub valid_package_name {
|
|
my ( $self, $string ) = @_;
|
|
|
|
# Escape everything into valid perl identifiers
|
|
$string =~ s/([^A-Za-z0-9\/])/sprintf("_%2x",unpack("C",$1))/eg;
|
|
|
|
# second pass cares for slashes and words starting with a digit
|
|
$string =~ s{
|
|
(/) # directory
|
|
(\d?) # package's first character
|
|
}[
|
|
"::" . ($2 ? sprintf("_%2x",unpack("C",$2)) : "")
|
|
]egx;
|
|
|
|
return "Embed" . $string;
|
|
}
|
|
|
|
sub cached {
|
|
my ( $self, $filename, $package, $mtime ) = @_;
|
|
$$mtime = -M $filename;
|
|
if ( defined $self->{FileCache}{$package}{mtime}
|
|
&& $self->{FileCache}{$package}{mtime} <= $$mtime )
|
|
{
|
|
return 1;
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
sub cache {
|
|
my ( $self, $package, $mtime ) = @_;
|
|
$self->{FileCache}{$package}{mtime} = $mtime;
|
|
}
|
|
|
|
sub uncache {
|
|
my ( $self, $package ) = @_;
|
|
delete $self->{FileCache}{$package};
|
|
}
|
|
|
|
sub new {
|
|
my $class = shift;
|
|
return bless {
|
|
FileCache => {},
|
|
@_,
|
|
} => $class;
|
|
}
|
|
|
|
sub prepare {
|
|
my ( $self, $filename, $package ) = @_;
|
|
my $fh = FileHandle->new($filename) or die "open '$filename' $!";
|
|
local ($/) = undef;
|
|
my $sub = <$fh>;
|
|
$fh->close;
|
|
|
|
#new object, same class
|
|
return bless {
|
|
CODE => $sub,
|
|
FILENAME => $filename,
|
|
PACKAGE => $package,
|
|
},
|
|
ref($self) || $self;
|
|
}
|
|
|
|
sub compile {
|
|
my ($self) = @_;
|
|
my $code = $self->{CODE};
|
|
my $package = $self->{PACKAGE};
|
|
my $eval = qq{package $package; sub handler { $code; }};
|
|
{
|
|
# hide our variables within this block
|
|
my ( $package, $code );
|
|
eval $eval;
|
|
}
|
|
croak $@ if $@;
|
|
}
|
|
|
|
sub run {
|
|
my ($self) = @_;
|
|
eval { $self->{PACKAGE}->handler; };
|
|
croak $@ if $@;
|
|
}
|
|
|
|
#borrowed from Safe.pm
|
|
sub delete {
|
|
my ($self) = @_;
|
|
my $pkg = $self->{PACKAGE};
|
|
$self->uncache($pkg);
|
|
my ( $stem, $leaf );
|
|
|
|
no strict 'refs';
|
|
$pkg = "main::$pkg\::"; # expand to full symbol table name
|
|
( $stem, $leaf ) = $pkg =~ m/(.*::)(\w+::)$/;
|
|
|
|
my $stem_symtab = *{$stem}{HASH};
|
|
|
|
delete $stem_symtab->{$leaf};
|
|
}
|
|
|
|
sub eval_file {
|
|
my ( $self, $filename, $delete ) = @_;
|
|
my $package = $self->valid_package_name($filename);
|
|
my $mtime;
|
|
if ( $self->cached( $filename, $package, \$mtime ) ) {
|
|
|
|
# we have compiled this subroutine already,
|
|
# it has not been updated on disk, nothing left to do
|
|
print STDERR "already compiled $package->handler\n" if $self->{DEBUG};
|
|
}
|
|
else {
|
|
my $code = $self->prepare( $filename, $package );
|
|
|
|
#wrap the code into a subroutine inside our unique package
|
|
$code->compile;
|
|
|
|
#cache it unless we're cleaning out each time
|
|
$self->cache( $package, $mtime ) unless $delete;
|
|
$code->run;
|
|
$code->delete if $delete;
|
|
}
|
|
|
|
#take a look if you want
|
|
#print Devel::Symdump->rnew($package)->as_string, $/;
|
|
}
|
|
|
|
1;
|
|
|
|
__END__
|