File Coverage

blib/lib/Attribute/Default.pm

Criterion	Covered	Total	%
statement	193	197	97.9
branch	56	68	82.3
condition	13	24	54.1
subroutine	40	40	100.0
pod	0	3	0.0
total	302	332	90.9

package Attribute::Default;
{
  $Attribute::Default::VERSION = '1.35';
}

####
#### Attribute::Default
####
#### $Id$
####
#### See perldoc for details.
####

use 5.0010;
use strict;
use warnings;
no warnings 'redefine';
use attributes;
use Attribute::Handlers 0.79;

use base qw(Attribute::Handlers Exporter);

use Carp;
use Symbol;

our @EXPORT_OK = qw(exsub);

use constant EXSUB_CLASS => ( __PACKAGE__ . '::ExSub' );

##
## import()
##
## Apparently I found it necessary to export 'exsub'
## by hand. I don't know why. Eventually, it may
## be necessary to turn on some specific functionality
## once 'exsub' is exported for compile-time speed.
##
sub import {
  my $class = shift;
  my ($subname) = @_;
  my $callpkg = (caller())[0];

  if (defined($subname) && $subname eq 'exsub') {
    no strict 'refs';
    *{ "${callpkg}::exsub" } = \&exsub;
  }
  else {
    SUPER->import(@_);
  }

}

##
## exsub()
##
## One specifies an expanding subroutine for Default by saying 'exsub
## { YOUR CODE HERE }'. It's run and used as a default at runtime.
##
## Exsubs are marked by being blessed into EXSUB_CLASS.
##
sub exsub(&) {
  my ($sub) = @_;
  ref $sub eq 'CODE' or die "Sub '$sub' can't be blessed: must be CODE ref";
  bless $sub, EXSUB_CLASS;
}

##
## _get_args()
##
## Fairly close to no-op code. Discards the needless
## arguments I get from Attribute::Handlers stuff
## and puts single default arguments into array refs.
##
sub _get_args {
  my ($glob, $orig, $attr, $defaults) = @_[1 .. 4];
  (ref $defaults && ref $defaults ne 'CODE') or $defaults = [$defaults];

  return ($glob, $attr, $defaults, $orig);
}

##
## _is_method()
##
## Returns true if the given reference has a ':method' attribute.
##
sub _is_method {
  my ($orig) = @_;

  foreach ( attributes::get($orig) ) {
    ($_ eq 'method') and return 1;
  }

  return;
}

##
## _extract_exsubs_array()
##
## Arguments:
##    DEFAULTS -- arrayref : The list of default arguments
##
## Returns:
##    hashref: list of exsubs we found and their array indices
##    arrayref: list of defaults without exsubs
##
sub _extract_exsubs_array {
  my ($defaults) = @_;

  my %exsubs = ();
  my @noexsubs = ();

  for ( $[ .. $#$defaults ) {
    if (UNIVERSAL::isa( $defaults->[$_], EXSUB_CLASS )) {
      $exsubs{$_} = $defaults->[$_];
    }
    else {
      $noexsubs[$_] = $defaults->[$_];
    }
  }

  return (\%exsubs, \@noexsubs);
}


##
## _get_fill()
##
## Returns an appropriate subroutine to process the given defaults.
##
sub _get_fill {
  my ($defaults) = @_;

  if (ref $defaults eq 'ARRAY') {
    return _fill_array_sub($defaults);
  }
  elsif(ref $defaults eq 'HASH') {
    return _fill_hash_sub($defaults);
  }
  else {
    return _fill_array_sub([$defaults]);
  }
}

##
## _fill_array_sub()
##
## Arguments:
##   DEFAULTS: arrayref
##
##
## Returns:
##    coderef-- closure to fill sub with defaults
##    coderef-- closure to fill in exsubs
##
sub _fill_array_sub {
  my ($defaults) = @_;

  my ($exsubs, $plain) = _extract_exsubs_array($defaults);
  my $fill_sub = sub { return _fill_arr($plain, @_) };
  if ( %$exsubs ) {
      return ( $fill_sub,
	       sub {
		 my ($processed, $exsub_args) = @_;
		 while (my ($idx, $exsub) = each %$exsubs) {
		   defined( $processed->[$idx] ) and next;
		   $processed->[$idx] = &$exsub(@$exsub_args);
		 }
		 return $processed;
	       });
    }
  else {
    return ($fill_sub, undef);
  }
}

##
## _extract_exsubs_hash()
##
## Arguments:
##
##   DEFAULTS: hashref -- Name-value pairs of defaults
##
## Returns: (array)
##
##   hashref -- name-value pairs of all exsubs
##   hashref -- name-value pairs of all non-exsub defaults
##
## Returns the exsubs in a hash of defaults.
##
sub _extract_exsubs_hash {
  my ($defaults) = @_;

  my %exsubs = ();
  my %noexsubs = ();
  while ( my ($key, $value) = each %$defaults ) {
    if (UNIVERSAL::isa( $value, EXSUB_CLASS ) ) {
      $exsubs{$key} = $value;
    }
    else {
      $noexsubs{$key} = $value;
    }
  }
  return (\%exsubs, \%noexsubs);
}

##
## _fill_hash_sub()
##
##  Arguments
##    DEFAULTS: hashref -- name-value pairs of defaults
##
## Returns: list
##    coderef -- closure to fill default values
##    coderef -- closure to fill exsubs
##
## Returns the appropriate preprocessor to fill a hash
## with defaults.
##
sub _fill_hash_sub {
  my ($defaults) = @_;

  my ($exsubs, $plain) = _extract_exsubs_hash($defaults);
  my $fill_sub = sub { return _fill_hash($plain, @_); };
  if ( %$exsubs ) {
    return ($fill_sub,
	    sub {
	      my ($filled, $exsub_args) = @_;
	      my %processed = @$filled;
	      while (my ($key, $exsub) = each %$exsubs) {
		(! defined $processed{$key}) or next;
		$processed{$key} = &$exsub(@$exsub_args);
	      }
	      @$filled = %processed;
	      return $filled;
	    });
  }
  else {
    return ( $fill_sub, undef );
  }
}

##
## _get_sub()
##
## Arguments:
##    DEFAULTS: arrayref -- Array of defaults to a subroutine
##    ORIG: code ref -- The subroutine we're applying defaults to
##
## Returns the appropriate subroutine wrapper that
## will call ORIG with the given default values.
##
sub _get_sub {
  my ($defaults, $orig) = @_;

  my ($fill_sub, $exsub_sub) = _get_fill($defaults);

  if ( _is_method($orig) ) {
      if (defined $exsub_sub) {
	  return sub {
	      my ($self, @args) = @_;
	      my @filled = &$fill_sub(@args);
	      @_ = ($self, @{ &$exsub_sub( \@filled, [$self, @filled] ) } );
	      goto $orig;
	  };
      }
      else {
	  return sub {
	      my ($self, @args) = @_;
	      @_ = ($self, &$fill_sub(@args));
	      goto $orig;
	  };
      }
  }
  else {
      if (defined $exsub_sub) {
	  return sub {
	      my @filled = &$fill_sub(@_);
	      @_ = @{ &$exsub_sub( \@filled, \@filled ) };
	      goto $orig;
	  };
      }
      else {
	  return sub {
	      @_ = &$fill_sub(@_);
	      goto $orig;
	  };
      }
  }
}


sub Default : ATTR(CODE) {
  my ($glob, $attr, $defaults_arg, $orig) = _get_args(@_);

  my $defaults = $defaults_arg;

  if ( defined $defaults && (ref $defaults eq 'ARRAY') && ( scalar @{ $defaults } == 1 ) ) {
  	$defaults = $defaults_arg->[0];
  }

  *$glob = _get_sub($defaults, $orig);

}


##
## _fill_hash()
##
## Arguments:
##    DEFAULTS: hashref -- Hash table of default arguments
##    ARGS: list -- The arguments to be filtered
##
## Returns:
##    list -- Arguments with defaults filled in
##
sub _fill_hash {
  my $defaults = shift;
  my %args = @_;
  while (my ($key, $value) = each %$defaults) {
    unless ( defined($args{$key}) ) {
      if ( UNIVERSAL::isa( $value, EXSUB_CLASS ) ) {
	$args{$key} = undef;
      }
      else {
	$args{$key} = $value;
      }
    }
  }
  return %args;
}

##
## _fill_arr()
##
## Arguments:
##    DEFAULTS: arrayref -- Array of default arguments
##    ARGS: list -- The arguments to be filtered
##
## Returns:
##    list -- Arguments with defaults filled in
##
sub _fill_arr {
  my $defaults = shift;
  my @filled = ();
  foreach (0 .. $#_) {
    push @filled, ( defined( $_[$_] ) ? $_[$_] : $defaults->[$_] );
  }
  if ($#$defaults > $#_) {
    push(@filled, @$defaults[scalar @_ .. $#$defaults]);
  }

  return @filled;
}

##
## Defaults()
##
## Arguments:
##   GLOB: typeglobref -- Typeglob of name of sub to wrap
##   ORIG: coderef -- Ref to original sub
##   ATTR: string -- name of the attribute (Always 'Defaults' right now)
##   DEFAULTS_LIST -- list of default arguments
##
## Defaults() creates a wrapper subroutine that does a two-layer check on
## incoming arguments. It first processes the toplevel arguments as an
## array, then processes any reference defaults.
##
## If the default and the argument are of differing reference types, the
## argument is passed through unscathed.
##
## An undef of a reference type is treated like someone passing an empty
## array or hash.
##
## Implementation note: Using huge numbers of closures like I am may
## waste too much memory. It's a hell of a lot cleaner than what I was doing
## before, though.
##
##
sub Defaults : ATTR(CODE) {
  my ($glob, $orig, $attr, $defaults) = @_[1 .. 4];
  (ref $defaults) && (ref $defaults eq 'ARRAY') or $defaults = [$defaults];

  my @ref_defaults = ();
  my @ref_exsubs = ();
  my @toplevel_defaults = ();

  foreach ($[ .. $#$defaults) {
    if ( (my $type = ref $$defaults[$_]) && (! UNIVERSAL::isa($$defaults[$_], EXSUB_CLASS) ) ) {
      my ($fill_sub, $fill_exsub) = _get_fill($$defaults[$_]);
      push @ref_defaults, [$_, $type, $fill_sub];
      defined $fill_exsub and push @ref_exsubs, [$_, $type, $fill_exsub];
    }
    else {
      $toplevel_defaults[$_] = $$defaults[$_];
    }
  }

  my ($toplevel_sub, $toplevel_exsub) = _fill_array_sub(\@toplevel_defaults);

  if ( _is_method($orig) ) {
    *$glob =
sub {
  my @filled = &$toplevel_sub(@_[ ($[ + 1) .. $#_ ]);
  _fill_sublevel(\@filled, \@ref_defaults);
  defined ($toplevel_exsub) && &$toplevel_exsub(\@filled, [$_[0], @filled]);
  _fill_exsubs(\@filled, \@ref_exsubs, [$_[0], @filled]);
  @_ = ($_[0], @filled);
  goto $orig;
}
  }
  else {
      *$glob =
 sub {

	  # First, fill toplevel arguments
	  my @filled = &$toplevel_sub(@_);

	  # Next, fill all sublevel arguments
	  _fill_sublevel(\@filled, \@ref_defaults);

	  defined ($toplevel_exsub) && &$toplevel_exsub(\@filled, \@filled);
	  _fill_exsubs(\@filled, \@ref_exsubs, \@filled);
	  @_ = @filled;
	  goto $orig;
      }

  }


}

sub _fill_exsubs {
  my ($args, $ref_exsubs, $exsub_args) = @_;

  foreach (@$ref_exsubs) {
    my ($idx, $type, $exsub_sub) = @$_;
    ($type eq ref $$args[$idx]) || (! defined $$args[$idx]) or next;
    if ($type eq 'HASH') {
      $$args[$idx] = { @{ &$exsub_sub( [%{ $$args[$idx] } ], $exsub_args  ) } };
    }
    elsif ($type eq 'ARRAY') {
      $$args[$idx] = &$exsub_sub( $$args[$idx], $exsub_args );
    }
    else {
      die "Exsub expansion cannot handle '$type'";
    }
  }
}



sub _fill_sublevel {
  my ($filled, $ref_defaults) = @_;

  foreach (@$ref_defaults) {
    my ($idx, $type, $fill_sub) = @$_;
    ($type eq ref $$filled[$idx]) || (! defined $$filled[$idx]) or next;
    if ($type eq 'HASH') {
      $$filled[$idx] = { &$fill_sub( defined $$filled[$idx] ? %{ $$filled[$idx] } : () ) };
    } elsif ($type eq 'ARRAY') {
      $$filled[$idx] = [ &$fill_sub( defined $$filled[$idx] ? @{ $$filled[$idx] } : () ) ];
    } else {
      die "I don't know what to do with '$type'";
    }

  }

}

1;
__END__