view release on metacpan or  search on metacpan

lib/Attribute/Default.pm  view on Meta::CPAN

##
## 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);

lib/Attribute/Default.pm  view on Meta::CPAN

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