File Coverage

blib/lib/constant/defer.pm

Criterion	Covered	Total	%
statement	56	63	88.8
branch	10	14	71.4
condition			n/a
subroutine	12	14	85.7
pod			n/a
total	78	91	85.7

# Copyright 2008, 2009, 2010, 2011, 2012, 2015 Kevin Ryde

# This file is part of constant-defer.
#
# constant-defer is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the Free
# Software Foundation; either version 3, or (at your option) any later
# version.
#
# constant-defer is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with constant-defer.  If not, see .

package constant::defer;
use strict;

use vars '$VERSION';
$VERSION = 6;

sub import {
  my $class = shift;
  $class->_create_for_package (scalar(caller), @_);
}
sub _create_for_package {
  my $class = shift;
  my $target_package = shift;
  while (@_) {
    my $name = shift;
    if (ref $name eq 'HASH') {
      unshift @_, %$name;
      next;
    }
    unless (@_) {
      require Carp;
      Carp::croak ("Missing value sub for $name");
    }
    my $subr = shift;

    ### $constant::defer::DEBUG_LAST_SUBR = $subr;

    my ($fullname, $basename);
    if ($name =~ /::([^:]*)$/s) {
      $fullname = $name;
      $basename = $1;
    } else {
      $basename = $name;
      $fullname = "${target_package}::$name";
    }
    ## print "constant::defer $arg -- $fullname $basename $old\n";
    $class->_validate_name ($basename);
    $class->_create_fullname ($fullname, $subr);
  }
}

sub _create_fullname {
  my ($class, $fullname, $subr) = @_;
  my $run = sub {
    unshift @_, $fullname, $subr;
    goto &_run;
  };
  my $func = sub () {
    unshift @_, \$run;
    goto $run;
  };
  no strict 'refs';
  *$fullname = $func;

  ### $constant::defer::DEBUG_LAST_RUNNER = $run;
}

sub _run {
  my $fullname = shift;
  my $subr = shift;
  my $run_ref = shift;
  ### print "_run() $fullname $subr\n";

  my @ret = &$subr(@_);
  if (@ret == 1) {
    # constant.pm has an optimization to make a constant by storing a scalar
    # value directly into the %{Foo::Bar::} hash if there's no typeglob for
    # the name yet.  But that doesn't apply here, there's always a glob from
    # having converted a function.
    #
    # The function created only has name __ANON__ in its coderef GV (as
    # fetched by Sub::Identify for instance).  This is the same as most
    # function creating modules, including Memoize.pm.  Plain constant.pm
    # likewise, except when it uses the scalar ref in symbol table
    # optimization, in that case a later upgrade to a function gets a name.
    #
    my $value = $ret[0];
    $subr = sub () { $value };

  } elsif (@ret == 0) {
    $subr = \&_nothing;

  } else {
    $subr = sub () { @ret };
  }

  $$run_ref = $subr;
  { no strict 'refs';
    local $^W = 0; # no warnings 'redefine';
    eval { *$fullname = $subr } or die $@;
  }
  goto $subr;
}

# not as strict as constant.pm
sub _validate_name {
  my ($class, $name) = @_;
  if ($name =~ m{[()]   # no parens like CODE(0x1234) if miscounted args
               |^[0-9]  # no starting with a number
               |^$      # not empty
              }x) {
    require Carp;
    Carp::croak ("Constant name '$name' is invalid");
  }
}

sub _nothing () { } ## no critic (ProhibitSubroutinePrototypes)

1;
__END__