root/lang/perl/Shika/trunk/lib/Shika/Role.pm @ 25463

Revision 25463, 2.5 kB (checked in by yappo, 6 years ago)

role を with した時にちゃんと SUBTYPE/COERCE を引き継ぐ、さっきの壊れてた

Line 
1package Shika::Role;
2use strict;
3use warnings;
4use Shika::Util;
5
6sub import {
7    my $pkg = caller(0);
8    strict->import;
9    warnings->import;
10
11    my $meta = +{
12        requires => [],
13        has      => [],
14        modifier => {},
15        role     => [],
16    };
17
18    no strict 'refs';
19    *{"$pkg\::requires"} = \&_requires;
20    *{"$pkg\::has"}      = \&_has;
21    *{"$pkg\::with"}     = \&_with;
22    *{"$pkg\::before"}   = \&_before;
23    *{"$pkg\::after"}    = \&_after;
24    *{"$pkg\::around"}   = \&_around;
25    *{"$pkg\::meta"}     = sub { $meta };
26}
27
28sub _with {
29    my $pkg = caller(0);
30    my @roles = @_;
31    Shika::Role::apply_roles($pkg, @roles);
32}
33
34sub apply_roles {
35    my ($target, @roles) = @_;
36
37    for my $role (@roles) {
38        my $alias = {};
39        if (ref $role eq 'HASH') {
40            $alias = $role->{alias};
41            $role  = $role->{role};
42        }
43        Shika::Util::load_class($role) unless $role->can('meta');
44        next unless $role->can('meta');
45
46        Shika::Util::copy_functions($role => $target, $alias);
47        unshift @{$target->meta->{has}}, @{ $role->meta->{has} };
48
49        # install method modifiers
50        while (my($name, $modifiers) = each %{ $role->meta->{modifier} }) {
51            my $target_modifier = _init_modifier($target, $name);
52            for my $type (qw/ before after around /) {
53                push @{ $target_modifier->{$type} }, @{ $modifiers->{$type} };
54            }
55        }
56
57        # copy subtype/coerce
58        require Shika::Util::TypeConstraints;
59        Shika::Util::TypeConstraints::copy_types($role, $target, '-all');
60
61        push @{ $target->meta->{role} }, $role;
62    }
63}
64
65sub _requires {
66    my $pkg = caller(0);
67    push @{ $pkg->meta->{requires} }, [ @_ ];
68}
69
70sub _has {
71    my ($name, %attr) = @_;
72    my $pkg = caller(0);
73    push @{ $pkg->meta->{has} }, {name => $name, attr => \%attr};
74}
75
76
77sub _init_modifier {
78    my($pkg, $name) = @_;
79    my $code = $pkg->can($name);
80    $pkg->meta->{modifier}->{$name} ||= +{
81        around       => [],
82        before       => [],
83        after        => [],
84    };
85}
86
87{
88    no strict 'refs';
89    for my $_type (qw/before after around/) {
90        my $type = $_type;
91        *{"_${type}"} = sub {
92            my ($name, $code) = @_;
93            my $pkg = caller(0);
94            my $modifier = _init_modifier($pkg, $name);
95            push @{ $modifier->{$type} }, $code;
96        };
97    }
98}
99
1001;
101
102__END__
103
104=head1 NAME
105
106Shika::Role - the role class of Shika
107
108=head1 TODO
109
110 - hash with +
111 - excludes?
112
113=cut
Note: See TracBrowser for help on using the browser.