# 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;
}
1;