package Sub::Sealed;
# Probably should be Acme::Sealed, eh?

use strict;
use warnings;
no warnings qw(uninitialized redefine);

use Attribute::Handlers;
use B qw(svref_2object);
use Devel::LexAlias qw(lexalias);
use PadWalker qw(peek_my peek_sub);
use Storable qw(dclone);
our $Thread = scalar eval "use Thread::Tie; 1 ";

my $count = 0;

sub UNIVERSAL::Sealed : ATTR(CODE)  {
    my ($package, $symbol, $referent, $attr, $data, $phase) = @_;
        
    ++ $count;
    my $invoked = 0;
    my $pkg = "$package\::ANON$count\::";

    
    # ironically, does not work with closures, where this might
    # actually be useful.  After many hours of experimentation,
    # it appears impossible to modify a closure with an attribute.
    *$symbol = sub {
        if (not $invoked) {
            my $used     = peek_sub($referent);
            my $in_scope = peek_my(1);
            
            my ($names,@values) =
                svref_2object( $referent )->PADLIST->ARRAY;
            $names = $names->object_2svref;
                   
            my %to_save;
            my %is_global;
            foreach my $var (keys %$in_scope) {
                if (exists $used->{$var}) {
                    my $global = 1 if ref $used->{$var} eq 'GLOB';
                    foreach (1..$#$names) {
                        if ($var eq $names->[$_]) {
                            my $value;
                            if ($global) {
                                no strict 'refs';
                                my $type =   substr($var, 0, 1) ne '$'
                                           ? substr($var, 0, 1) eq '@'
                                           ? 'ARRAY' : 'HASH' : 'SCALAR';
                                my $name = substr($var, 1);
                                $value = *{"$package\::$name"}{$type};
                            }
                            else {
                                $value = ($values[0]->ARRAY)[$_]->object_2svref;
                            }
                            $value = dclone($value)
                                if UNIVERSAL::isa($value,'ARRAY') or
                                   UNIVERSAL::isa($value,'HASH');
                            $to_save{$var} = $value;
                            $is_global{$var} = $global;
                        }
                        next;
                    }
                }
            }
            
            no strict 'refs';
            while ( my($var,$value) = each %to_save) {
                my $sigil = substr($var,0,1,"");
                my $newvar = *{"$pkg$var"}{SCALAR};
                if ($is_global{"$sigil$var"}) {
                    my $type =   $sigil ne '$'
                                ? $sigil eq '@'
                                ? 'ARRAY' : 'HASH' : 'SCALAR';
                    my $variable = *{"$package\::$var"}{$type};
                    my @args = (\$value, $package, *$symbol, $type);
                    tie ${*{"main::z"}{$type}}, 'Sub::Sealed::Global', @args
                        if $sigil eq '$';
                    tie @{*{"main::z"}{$type}}, 'Sub::Sealed::Global', @args
                        if $sigil eq '@';
                    tie %{*{"main::z"}{$type}}, 'Sub::Sealed::Global', @args
                        if $sigil eq '%';
                }
                else {
                    if ( $Thread ) {
                       tie $$newvar, 'Thread::Tie', {}, $value;
                    } else {
                       # for non-thread-wary results
                       $$newvar = $value;
                    }
                    
                    # the next line is necessary, for some reason
                    $newvar = ${*{"$pkg$var"}{SCALAR}};
                    lexalias($referent, "$sigil$var", $newvar);
                }
            }
            ++ $invoked;
        }
        return $referent->(@_);
    };
}

package Sub::Sealed::Global;
use Storable qw(dclone);
use strict;
use warnings;

sub TIE {
    my ($class,$data,$pkg,$sub,$type) = @_;
    
    $sub = substr("$sub", rindex("$sub",':')+1);
    my $copy = dclone($$data);
    
    if ( $Thread ) {
        tie $data, 'Thread::Tie', {}, $$data;
    }
    
    my $obj = {
        type   => $type,
        normal => $copy,
        sealed => $data,
        caller => "$pkg\::$sub"
    };
    
    bless $obj, $class;
}

sub pick {
    my ($self,@caller) = @_;

    if ($caller[3] && $caller[3] eq $self->{caller}) {
        return $self->{sealed}
    }
    else {
        return $self->{normal}
    }
}

# Cntr

sub TIESCALAR { goto \&TIE }
sub TIEARRAY  { goto \&TIE }
sub TIEHASH   { goto \&TIE }

# Array
sub FETCHSIZE { scalar @{pick($_[0], caller(1))} }
sub STORESIZE { $#{pick($_[0], caller(1))} = $_[1]-1 }
sub POP       { pop(@{pick($_[0], caller(1))}) }
sub PUSH      { my $o = pick(shift, caller(1)); push(@$o,@_) }
sub SHIFT     { shift(@{pick($_[0], caller(1))}) }
sub UNSHIFT   { my $o = pick(shift, caller(1)); unshift(@$o,@_) }
sub EXTEND    { }
sub SPLICE {
    my $ob  = pick(shift, caller(1));
    my $sz  = $ob->FETCHSIZE;
    my $off = @_ ? shift : 0;
    $off   += $sz if $off < 0;
    my $len = @_ ? shift : $sz-$off;
    return splice(@$ob,$off,$len,@_);
}

# Hash
sub FIRSTKEY { my $a = scalar keys %{pick($_[0], caller(1))};
               each %{pick($_[0], caller(1))}
             }
sub NEXTKEY  { each %{pick($_[0], caller(1))} }

# General
sub STORE {
    my $x = pick($_[0], caller(1));
    if ($_[0]->{type} eq 'SCALAR') {
        $$x = $_[1];
    }
    if ($_[0]->{type} eq 'ARRAY') {
        return $x->[$_[1]] = $_[2]
    }
    elsif ($_[0]->{type} eq 'HASH') {
        return $x->{$_[1]} = $_[2]
    }
}
sub FETCH {
    my $x = pick($_[0], caller(1));
    if ($_[0]->{type} eq 'SCALAR') {
         return $$x
    }
    elsif ($_[0]->{type} eq 'ARRAY') {
        return $x->[$_[1]]
    }
    elsif ($_[0]->{type} eq 'HASH') {
        return $x->{$_[1]}
    }
}
sub EXISTS {
    my $x = pick($_[0], caller(1));
    if ($_[0]->{type} eq 'ARRAY') {
        exists $x->[$_[1]]
    }
    elsif ($_[0]->{type} eq 'HASH') {
        exists $x->{$_[1]}
    }
}
sub DELETE {
    my $x = pick($_[0], caller(1));
    if ($_[0]->{type} eq 'ARRAY') {
        delete $x->[$_[1]]
    }
    elsif ($_[0]->{type} eq 'HASH') {
        delete $x->{$_[1]}
    }
}
sub CLEAR {
    my $x = pick($_[0], caller(1));
    if ($_[0]->{type} eq 'ARRAY') {
        @{$x} = ()
    }
    elsif ($_[0]->{type} eq 'HASH') {
        %{$x} = ()
    }
}

1;