File Coverage

blib/lib/rubyisms.pm

Criterion	Covered	Total	%
statement	53	64	82.8
branch	11	16	68.7
condition	4	9	44.4
subroutine	14	15	93.3
pod	3	5	60.0
total	85	109	77.9

package DB;
sub uplevel_args { my @foo = caller($_[0]+1); return @DB::args };

package rubyisms;

use strict;
use warnings;
use Carp;
use Exporter;

our @ISA = qw(Exporter);
our @EXPORT = qw( self super yield );
our $VERSION = '1.0';

sub import {
    no strict 'refs';
    push @{(caller())[0]."::ISA"}, "Class"
      unless (caller())[0] eq "Class"; # Although Perl should deal it anyway
    rubyisms->export_to_level(1, @_);
}

sub self () {
    my $call_pack = (caller())[0];

    # So we're looking for the first thing that ISA $call_pack
    my $level =1;
    while (caller($level)) {
        my @their_args = DB::uplevel_args($level);
        if (ref $their_args[0]
            and eval { $their_args[0]->isa($call_pack) }) {
            return $their_args[0];
        }
        $level++;
    }
    # Well, hey, maybe it's a class method.
    return $call_pack;
}

sub yield (@) {
    my @their_args = DB::uplevel_args(1);
    if ((!@their_args) or ref $their_args[0] ne "CODE") {
        croak "no block given (LocalJumpError)";
    }
    my @stuff = (@_||$_);
    $their_args[0]->(@stuff)
        unless $stuff[0] == $their_args[0]; #Don't yield onto yourself.
}


sub super() {
    if (@_) {
        # Someone's trying to find SUPER's super. Blah.
        goto &UNIVERSAL::super;
    }
    @_ = DB::uplevel_args(1);
    my $self = $_[0];
    if (!$self) { carp "super called outside of method" }
    my $caller= (caller(1))[3];
    $caller =~ s/.*:://;
    goto &{$self->UNIVERSAL::super($caller)};
}

package Class;
rubyisms->import;

sub new {
    my $class = shift;
    my $self = bless {}, $class;
    # Cheat.
    my @args = @_;
    @_ = $self;
    no strict 'refs';
    $self->initialize(@args);
    return self();
}

sub initialize { } # Just to be sure.

package UNIVERSAL;

sub super {
    my ($class, $method) = @_;

    if (ref $class) { $class = ref $class; }
    my $x;
    no strict 'refs';
    for (@{$class."::ISA"}, "UNIVERSAL") {
        return $x if $x = $_->can($method);
    }
}

# Preloaded methods go here.

1;
__END__