File Coverage

blib/lib/Scalar/Defer.pm

Criterion	Covered	Total	%
statement	96	107	89.7
branch	15	30	50.0
condition	7	15	46.6
subroutine	26	27	96.3
pod	3	4	75.0
total	147	183	80.3

package Scalar::Defer;

use 5.006;
use strict;
use warnings;

BEGIN {
    our $VERSION   = '0.23';
    our @EXPORT    = qw( lazy defer force );
    our @EXPORT_OK = qw( is_deferred );
}

use Scalar::Util;
use Exporter::Lite;
use Class::InsideOut qw( register id );
use constant DEFER_PACKAGE => '0'; # This may change soon

BEGIN {
    my %_defer;

    sub defer (&) {
        my $cv  = shift;
        my $obj = register( bless(\(my $id) => __PACKAGE__) );
        $_defer{ $id = id $obj } = $cv;
        bless($obj => DEFER_PACKAGE);
    }

    sub lazy (&) {
        my $cv  = shift;
        my $obj = register( bless(\(my $id) => __PACKAGE__) );

        my ($value, $forced);
        $_defer{ $id = id $obj } = sub {
            $forced ? $value : scalar(++$forced, $value = &$cv)
        };

        bless $obj => DEFER_PACKAGE;
    }

    sub DEMOLISH {
        delete $_defer{ id $_[0] };
    }

    sub is_deferred ($) {
        no warnings 'uninitialized';
        ref $_[0] eq DEFER_PACKAGE;
    }

    use constant SUB_FORCE => sub ($) {
        no warnings 'uninitialized';
        &{
            $_defer{ id $_[0] } ||= $_defer{do {
                #
                # The memory address was dislocated.  Fortunately, its original
                # refaddr is saved directly inside the scalar referent slot.
                #
                # So we remove the overload by blessing into UNIVERSAL, get the
                # original refaddr back, and register it with ||= above to avoid
                # doing the same thing next time. (Afterwards we rebless it back.)
                #
                # This of course assumes that nobody overloads ${} for UNIVERSAL
                # (which will naturally break all objects using scalar-ref layout);
                # if someone does, that someone is more crazy than we are and should
                # be able to handle the consequences.
                #
                my $self = $_[0];
                ref($self) eq DEFER_PACKAGE or return $self;

                bless($self => 'UNIVERSAL');
                my $id = $$self;
                bless($self => DEFER_PACKAGE);
                $id;
            }} or do {
                return 0 if caller eq 'Class::InsideOut';
                die sprintf("Cannot locate thunk for memory address: 0x%X", id $_[0]);
            };
        };
    };

    *force = SUB_FORCE();
}

BEGIN {
    package Scalar::Defer::Deferred;
    use overload (
        fallback => 1, map {
            $_ => Scalar::Defer::SUB_FORCE(),
        } qw( bool "" 0+ ${} @{} %{} &{} *{} )
    );

    sub AUTOLOAD {
        my $meth = our $AUTOLOAD;
        my $idx  = index($meth, '::');

        if ($idx >= 0) {
            $meth = substr($meth, $idx + 2);
        }

        unshift @_, Scalar::Defer::SUB_FORCE()->(shift(@_));
        goto &{$_[0]->can($meth)};
    };

    {
        foreach my $sym (grep {
             $_ ne 'DESTROY' and $_ ne 'DEMOLISH' and $_ ne 'BEGIN'
         and $_ ne 'END' and $_ ne 'AUTOLOAD' and $_ ne 'CLONE_SKIP'
        } keys %UNIVERSAL::) {
            my $code = q[
                sub $sym {
                    if ( defined Scalar::Util::blessed($_[0]) ) {
                        unshift @_, Scalar::Defer::SUB_FORCE()->(shift(@_));
                        goto &{$_[0]->can("$sym")};
                    }
                    else {
                        # Protect against future ALLCAPS methods
                        return if $_[0] eq Scalar::Defer::DEFER_PACKAGE;

                        return shift->SUPER::$sym(@_);
                    }
                }
            ];

            $code =~ s/\$sym/$sym/g;

            local $@;
            eval $code;
            warn $@ if $@;
        }

        *DESTROY  = \&Scalar::Defer::DESTROY;
        *DEMOLISH = \&Scalar::Defer::DEMOLISH;
    }
}

BEGIN {
    no strict 'refs';
    @{DEFER_PACKAGE().'::ISA'} = ('Scalar::Defer::Deferred');
}

1;

__END__