Vim Patior

Edit file

File name : Later.pm

Content :

# Copyrights 2001-2018 by [Mark Overmeer].
#  For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.02.
# This code is part of distribution Object-Realize-Later.  Meta-POD processed
# with OODoc into POD and HTML manual-pages.  See README.md
# Copyright Mark Overmeer.  Licensed under the same terms as Perl itself.

package Object::Realize::Later;
use vars '$VERSION';
$VERSION = '0.21';

use Carp;
use Scalar::Util 'weaken';

use warnings;
use strict;
no strict 'refs';

my $named  = 'ORL_realization_method';
my $helper = 'ORL_fake_realized';

sub init_code($)
{   my $args    = shift;

<<INIT_CODE;
  package $args->{class};
  require $args->{source_module};

my \$$helper = bless {}, '$args->{becomes}';
INIT_CODE
}

sub isa_code($)
{   my $args    = shift;

<<ISA_CODE;
  sub isa(\$)
  {   my (\$thing, \$what) = \@_;
      return 1 if \$thing->SUPER::isa(\$what);  # real dependency?
      \$$helper\->isa(\$what);
  }
ISA_CODE
}

sub can_code($)
{   my $args = shift;
    my $becomes = $args->{becomes};

<<CAN_CODE;
  sub can(\$)
  {   my (\$thing, \$method) = \@_;
      my \$func;
      \$func = \$thing->SUPER::can(\$method)
         and return \$func;

\$func = \$$helper\->can(\$method)
         or return;

# wrap func() to trigger load if needed.
      sub { ref \$thing
            ? \$func->(\$thing->forceRealize, \@_)
            : \$func->(\$thing, \@_)
          };
  }
CAN_CODE
}

sub AUTOLOAD_code($)
{   my $args   = shift;

<<'CODE1' . ($args->{believe_caller} ? '' : <<NOT_BELIEVE) . <<CODE2;
  our $AUTOLOAD;
  sub AUTOLOAD(@)
  {  my $call = substr $AUTOLOAD, rindex($AUTOLOAD, ':')+1;
     return if $call eq 'DESTROY';
CODE1

unless(\$$helper->can(\$call) || \$$helper->can('AUTOLOAD'))
     {   use Carp;
         croak "Unknown method \$call called";
     }
NOT_BELIEVE
    # forward as class method if required
    shift and return $args->{becomes}->\$call( \@_ ) unless ref \$_[0];

\$_[0]->forceRealize;
     my \$made = shift;
     \$made->\$call(\@_);
  }
CODE2
}

sub realize_code($)
{   my $args   = shift;
    my $pkg    = __PACKAGE__;
    my $argspck= join "'\n         , '", %$args;

<<REALIZE_CODE .($args->{warn_realization} ? <<'WARN' : '') .<<REALIZE_CODE;
  sub forceRealize(\$)
  {
REALIZE_CODE
      require Carp;
      Carp::carp("Realization of $_[0]");
WARN
      ${pkg}->realize
        ( ref_object => \\\${_[0]}
        , caller     => [ caller 1 ]
        , '$argspck'
        );
  }
REALIZE_CODE
}

sub will_realize_code($)
{   my $args = shift;
    my $becomes = $args->{becomes};
    <<WILL_CODE;
sub willRealize() {'$becomes'}
WILL_CODE
}

sub realize(@)
{   my ($class, %args) = @_;
    my $object  = ${$args{ref_object}};
    my $realize = $args{realize};

my $already = $class->realizationOf($object);
    if(defined $already && ref $already ne ref $object)
    {   if($args{warn_realize_again})
        {   my (undef, $filename, $line) = @{$args{caller}};
            warn "Attempt to realize object again: old reference caught at $filename line $line.\n"
        }

return ${$args{ref_object}} = $already;
    }

my $loaded  = ref $realize ? $realize->($object) : $object->$realize;

warn "Load produces a ".ref($loaded)
       . " where a $args{becomes} is expected.\n"
           unless $loaded->isa($args{becomes});

${$args{ref_object}} = $loaded;
    $class->realizationOf($object, $loaded);
}

my %realization;

sub realizationOf($;$)
{   my ($class, $object) = (shift, shift);
    my $unique = "$object";

if(@_)
    {   $realization{$unique} = shift;
        weaken $realization{$unique};
    }

$realization{$unique};
}

sub import(@)
{   my ($class, %args) = @_;

confess "Require 'becomes'" unless $args{becomes};
    confess "Require 'realize'" unless $args{realize};

$args{class}                = caller;
    $args{warn_realization}   ||= 0;
    $args{warn_realize_again} ||= 0;
    $args{source_module}      ||= $args{becomes};

# A reference to code will stringify at the eval below.  To solve
    # this, it is tranformed into a call to a named subroutine.
    if(ref $args{realize} eq 'CODE')
    {   my $named_method = "$args{class}::$named";
        *{$named_method} = $args{realize};
        $args{realize}   = $named_method;
    }

# Produce the code

my $args = \%args;
    my $eval
       = init_code($args)
       . isa_code($args)
       . can_code($args)
       . AUTOLOAD_code($args)
       . realize_code($args)
       . will_realize_code($args)
       ;
#warn $eval;

# Install the code

eval $eval;
    die $@ if $@;

1;
}