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} ||= { };
                caller_cv(0)->($package.$k, $node->{$k});
            } elsif( *{$package.$k}{HASH} ) {
                $node->{$k} = *{$package.$k}{HASH};
            } elsif( *{$package.$k}{ARRAY} ) {
                $node->{$k} = *{$package.$k}{ARRAY};
            } elsif( *{$package.$k}{CODE} ) {
                next unless $wantcoderefs;
                # save coderefs but only if they aren't XS (can't serialize those) and weren't exported from elsewhere.
                my $ob = B::svref_2object(*{$package . $k}{CODE});
                my $rootop = $ob->ROOT;
                my $stashname = $$rootop ? $ob->STASH->NAME . '::' : '(none)'; 
                if($$rootop and ($stashname eq $package or 'main::'.$stashname eq $package or $stashname eq 'main::' )) {
                    # when we eval something in code in main::, it comes up as being exported from main::.  *sigh*
                    $node->{$k} = *{$package . $k}{CODE};
                }
            } else {
                $node->{$k} = *{$package.$k}{SCALAR} unless ref(*{$package.$k}{SCALAR}) eq 'GLOB';
            }
        }
        return $node;
    }->('main::');

    # use Data::Dumper; print "debug: ", Data::Dumper::Dumper($tree), "\n";

    local $Storable::Deparse = $wantcoderefs;

    my $save_fn = save_file_name();

    # $save_fn =~ s{/-}{/x}g; warn "saving to: ``$save_fn.new''";

    Storable::nstore $tree, $save_fn.'.new' or die "saving state failed: $!";

    # warn "okay, Storable::nstore done";

    rename $save_fn, $save_fn.'.last'; # it's okay if it fails... file might not exist
    rename $save_fn.'.new', $save_fn or die "renaming new save file into place as ``$save_fn'' failed: $!";

    return 1;
}