package Embed::Persistent;

use strict;
use Carp 'croak';
use warnings;

use FileHandle ();
use vars qw ($VERSION);
$VERSION = (qw$Revision: 1.10X $)[1];

my $__OverrideExit__ = 0;

sub valid_package_name
{
    my ($self, $string) = @_;

    $string = "" if !defined $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, $ref_mtime) = @_;
    my $xtime;

    if (defined ($filename) &&
        defined ($xtime = (stat $filename)[9]))
    {
        $$ref_mtime = $xtime;
    }
    else
    {
        $$ref_mtime = 0;
        return 0;
    }

    my $entry = $self->{FileCache}{$package}{mtime};
    (defined ($entry) && ($entry <= $$ref_mtime)) ? 1 : 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;

    if ($__OverrideExit__)
    {
        $sub = << "END";
use subs qw (exit);
sub exit { die \$\@; }
$sub
END
    }

    # 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
    }
    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;
    }
}

1;

__END__