← Back to branch summary

~ubuntu-branches/ubuntu/trusty/libperl5i-perl/trusty-proposed

« back to all changes in this revision

Viewing changes to lib/perl5i/2/Meta.pm

  • Committer: Bazaar Package Importer
  • Author(s): Ivan Kohler
  • Date: 2010-05-08 17:42:00 UTC
  • Revision ID: james.westby@ubuntu.com-20100508174200-7ogg0zrimh9gvcuw
Tags: upstream-2.1.1
Import upstream version 2.1.1

Show diffs side-by-side

added added

removed removed

Lines of Context:
lib/perl5i/2/Meta.pm
 
1
package perl5i::2::Meta;
 
2
 
 
3
use strict;
 
4
use warnings;
 
5
 
 
6
# Be very careful not to import anything.
 
7
require Carp;
 
8
require mro;
 
9
 
 
10
require perl5i::2::Meta::Instance;
 
11
require perl5i::2::Meta::Class;
 
12
 
 
13
sub UNIVERSAL::mo {
 
14
    return perl5i::2::Meta::Instance->new($_[0]);
 
15
}
 
16
 
 
17
sub UNIVERSAL::mc {
 
18
    return perl5i::2::Meta::Class->new($_[0]);
 
19
}
 
20
 
 
21
sub new {
 
22
    my( $class, $thing ) = @_;
 
23
    return bless \$thing, $class;
 
24
}
 
25
 
 
26
sub ISA {
 
27
    my $class = $_[0]->class;
 
28
 
 
29
    no strict 'refs';
 
30
    return wantarray ? @{$class.'::ISA'} : \@{$class.'::ISA'};
 
31
}
 
32
 
 
33
sub linear_isa {
 
34
    my $self = shift;
 
35
    my $class = $self->class;
 
36
 
 
37
    # get_linear_isa() does not return UNIVERSAL
 
38
    my @extra;
 
39
    @extra = qw(UNIVERSAL) unless $class eq 'UNIVERSAL';
 
40
 
 
41
    my $isa = [@{mro::get_linear_isa($class)}, @extra];
 
42
    return wantarray ? @$isa : $isa;
 
43
}
 
44
 
 
45
 
 
46
# A single place to put the "method not found" error.
 
47
my $method_not_found = sub {
 
48
    my $class  = shift;
 
49
    my $method = shift;
 
50
 
 
51
    Carp::croak sprintf q[Can't locate object method "%s" via package "%s"],
 
52
      $method, $class;
 
53
};
 
54
 
 
55
 
 
56
# caller() will return if its inside an eval, need to skip over those.
 
57
my $find_method = sub {
 
58
    my $method;
 
59
    my $height = 2;
 
60
    do {
 
61
        $method = (caller($height))[3];
 
62
        $height++;
 
63
    } until( !defined $method or $method ne '(eval)' );
 
64
 
 
65
    return $method;
 
66
};
 
67
 
 
68
 
 
69
sub super {
 
70
    my $self = shift;
 
71
    my $class = $self->class;
 
72
 
 
73
    my $fq_method = $find_method->();
 
74
    Carp::croak "super() called outside a method" unless $fq_method;
 
75
 
 
76
    my($parent, $method) = $fq_method =~ /^(.*)::(\w+)$/;
 
77
 
 
78
    Carp::croak sprintf qq["%s" is not a parent class of "%s"], $parent, $class
 
79
      unless $class->isa($parent);
 
80
 
 
81
    my @isa = $self->linear_isa();
 
82
 
 
83
    while(@isa) {
 
84
        my $class = shift @isa;
 
85
        last if $class eq $parent;
 
86
    }
 
87
 
 
88
    for (@isa) {
 
89
        my $code = $_->can($method);
 
90
        @_ = ($$self, @_);
 
91
        goto &$code if $code;
 
92
    }
 
93
 
 
94
    $class->$method_not_found($method);
 
95
}
 
96
 
 
97
1;