File Coverage

blib/lib/Object/Realize/Later.pm

Criterion	Covered	Total	%
statement	92	94	97.8
branch	26	36	72.2
condition	10	15	66.6
subroutine	19	20	95.0
pod	2	11	18.1
total	149	176	84.6

# This code is part of Perl distribution Object-Realize-Later version 4.00.
# The POD got stripped from this file by OODoc version 3.05.
# For contributors see file ChangeLog.

# This software is copyright (c) 2001-2025 by Mark Overmeer.

# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
# SPDX-License-Identifier: Artistic-1.0-Perl OR GPL-1.0-or-later


package Object::Realize::Later;{
our $VERSION = '4.00';
}


use Log::Report 'object-release-later';

use Scalar::Util qw/weaken/;

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

#--------------------

#------------

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


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

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

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

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

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

	<
  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} ? '' : <
  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;

	<{warn_realization} ? <<'WARN' : '') . <
  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};
	<
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;

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

	${$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) = @_;

	$args{becomes} or panic "import requires 'becomes'";
	$args{realize} or panic "import requires '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;
	panic $@ if $@;

	1;
}

#--------------------

1;