view release on metacpan or  search on metacpan

lib/Acme/State.pm  view on Meta::CPAN

package Acme::State;

use 5.008000;
use strict;
use warnings;

our $VERSION = '0.03';

use B;
use Storable;
use Devel::Caller 'caller_cv';
use IO::Handle;

my @stop_modules = (
    '1' .. '9', ':',
    'SIG', 'stderr', '__ANON__', 'utf8::', 'CORE::', 'DynaLoader::', 'strict::',
    'stdout', 'attributes::', 'stdin', 'ARGV', 'INC', 'Scalar::', 'ENV',
    'Regexp::', 'XSLoader::', 'UNIVERSAL::', 'overload::', 'B::', 'Carp::', 
    'Data::', 'PerlIO::', '0', 'BEGIN', 'STDOUT', 'IO::', '_', 'Dumper',
    'Exporter::', 'bytes::', 'STDERR', 'Internals::', 'STDIN', 'Config::',
    'warnings::', 'DB::',
    'APR::', 'Apache2::', 'Apache::', 'autobox::', 'BSD::', 'CGITempFile::', 'Compress::',
    'Devel::', 'Dos::', 'EPOC::', 'Encode::', 'Fh::', 'File::', 'HTTP::', 'LWP::', 'List::', 'Log::',
    'MIME::', 'Mac::', 'MacPerl::', 'O::', 'POSIX::', 'Scope::', 'Sys::', 'Term::', 'Thread::', 'Time::', 'VMS::',
    'fields::', 'blackhole::', 'Autobox::', 'Module::', 'Win32::', 'MultipartBuffer::', 'q::', 'sort::',
);

sub import {

    my $save_fn = save_file_name();

    if(-f $save_fn) {
        local $Storable::Eval = 1;
        my $save = Storable::retrieve $save_fn;
        sub {
            my $package = shift;
            my $tree = shift;
            no strict 'refs';
            for my $k (keys %$tree) {
                if($k =~ m/::$/) {
                    caller_cv(0)->($package.$k, $tree->{$k});
                } elsif(ref($tree->{$k})) {
                    *{$package.$k} = $tree->{$k};
                } else {
                    die $package.$k . " doesn't contain a ref";
                }
            }
        }->('main::', $save);
    }

}

sub save_file_name {
    my $zero = $0 || 'untitledprogram';
    $zero =~ s{.*/}{};
    return +(getpwuid $<)[7].'/'.$zero.'.store';
}

sub save_state {

    our $wantcoderefs;

    my $tree = sub {
        my $package = shift;
        my $node = shift() || { };
        no strict 'refs';
        for my $k (keys %$package) {
            next if $k =~ m/main::$/;
            next if $k =~ m/[^\w:]/;
            next if grep $_ eq $k, @stop_modules;
            if($k =~ m/::$/) {
                # recurse into that namespace unless it corresponds to a .pm module that got used at some point
                my $modulepath = $package.$k; 
                for($modulepath) { s{^main::}{}; s{::$}{}; s{::}{/}g; $_ .= '.pm'; }
                next if exists $INC{$modulepath};
                $node->{$k} ||= { };