view release on metacpan or  search on metacpan

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

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