view release on metacpan or  search on metacpan

inc/Spiffy.pm  view on Meta::CPAN

    my $package = caller;
    my ($args, @values) = do {
        no warnings;
        local *paired_arguments = sub { (qw(-package)) };
        Spiffy->parse_arguments(@_);
    };
    my ($field, $default) = @values;
    $package = $args->{-package} if defined $args->{-package};
    no strict 'refs';
    return if defined &{"${package}::$field"};
    *{"${package}::$field"} = sub { $default }
}

sub stub {
    my $package = caller;
    my ($args, @values) = do {
        no warnings;
        local *paired_arguments = sub { (qw(-package)) };
        Spiffy->parse_arguments(@_);
    };
    my ($field, $default) = @values;
    $package = $args->{-package} if defined $args->{-package};
    no strict 'refs';
    return if defined &{"${package}::$field"};
    *{"${package}::$field"} = 
    sub { 
        require Carp;
        Carp::confess 
          "Method $field in package $package must be subclassed";
    }
}

sub parse_arguments {
    my $class = shift;
    my ($args, @values) = ({}, ());
    my %booleans = map { ($_, 1) } $class->boolean_arguments;
    my %pairs = map { ($_, 1) } $class->paired_arguments;
    while (@_) {
        my $elem = shift;
        if (defined $elem and defined $booleans{$elem}) {
            $args->{$elem} = (@_ and $_[0] =~ /^[01]$/)
            ? shift
            : 1;
        }
        elsif (defined $elem and defined $pairs{$elem} and @_) {
            $args->{$elem} = shift;
        }
        else {
            push @values, $elem;
        }
    }
    return wantarray ? ($args, @values) : $args;        
}

sub boolean_arguments { () }
sub paired_arguments { () }

# get a unique id for any node
sub id {
    if (not ref $_[0]) {
        return 'undef' if not defined $_[0];
        \$_[0] =~ /\((\w+)\)$/o or die;
        return "$1-S";
    }
    require overload;
    overload::StrVal($_[0]) =~ /\((\w+)\)$/o or die;
    return $1;
}

#===============================================================================
# It's super, man.
#===============================================================================
package DB;
{
    no warnings 'redefine';
    sub super_args { 
        my @dummy = caller(@_ ? $_[0] : 2); 
        return @DB::args;
    }
}

package Spiffy;
sub super {
    my $method;
    my $frame = 1;
    while ($method = (caller($frame++))[3]) {
        $method =~ s/.*::// and last;
    }
    my @args = DB::super_args($frame);
    @_ = @_ ? ($args[0], @_) : @args;
    my $class = ref $_[0] ? ref $_[0] : $_[0];
    my $caller_class = caller;
    my $seen = 0;
    my @super_classes = reverse grep {
        ($seen or $seen = ($_ eq $caller_class)) ? 0 : 1;
    } reverse @{all_my_bases($class)};
    for my $super_class (@super_classes) {
        no strict 'refs';
        next if $super_class eq $class;
        if (defined &{"${super_class}::$method"}) {
            ${"$super_class\::AUTOLOAD"} = ${"$class\::AUTOLOAD"}
              if $method eq 'AUTOLOAD';
            return &{"${super_class}::$method"};
        }
    }
    return;
}

#===============================================================================
# This code deserves a spanking, because it is being very naughty.
# It is exchanging base.pm's import() for its own, so that people
# can use base.pm with Spiffy modules, without being the wiser.
#===============================================================================
my $real_base_import;
my $real_mixin_import;

BEGIN {
    require base unless defined $INC{'base.pm'};
    $INC{'mixin.pm'} ||= 'Spiffy/mixin.pm';
    $real_base_import = \&base::import;
    $real_mixin_import = \&mixin::import;