root/lang/perl/Shika/trunk/lib/Shika.pm @ 25088

Revision 25088, 4.3 kB (checked in by tokuhirom, 5 years ago)

handles に scalar もわたせるようにした

Line 
1package Shika;
2
3use strict;
4use warnings;
5our $VERSION = '0.01';
6eval "use mro; 1;" or eval "use MRO::Compat; 1;"; ## no critic
7
8sub import {
9    my $pkg = caller(0);
10    strict->import;
11    warnings->import;
12
13    my $meta = +{
14        has      => {},
15        default  => {},
16    };
17
18    no strict 'refs';
19    *{"$pkg\::new"}     = \&_new;
20    *{"$pkg\::has"}     = \&_has;
21    *{"$pkg\::extends"} = \&_extends;
22    *{"$pkg\::with"}    = \&_with;
23    *{"$pkg\::meta"}    = sub { $meta };
24}
25
26sub _new {
27    my $class = shift;
28    my %attr = @_;
29
30    # set default values
31    for my $klass ($class, @{mro::get_linear_isa($class)}) {
32        next unless $klass->can('meta');
33        while (my ($name, $has) = each %{ $klass->meta->{has} }) {
34            next if     exists $attr{$name};
35            next unless exists $has->{default} && $has->{default};
36            next if     exists $has->{lazy} && $has->{lazy};
37            my $code = $has->{default};
38            $attr{$name} = ref($code) eq 'CODE' ? $code->() : $code;
39        }
40    }
41
42    my $self = bless { %attr }, $class;
43    if ($self->can('BUILD')) {
44        $self->BUILD(\%attr);
45    }
46    $self;
47}
48
49sub _has {
50    my $pkg = caller(0);
51    my $n = shift;
52    my %attr = @_;
53    $pkg->meta->{has}->{$n} = \%attr;
54
55    if (my $handles = $attr{handles}) {
56        $handles = [$handles] unless ref $handles;
57        for my $handle (@$handles) {
58            no strict 'refs';
59            *{"$pkg\::$handle"} = sub {
60                shift->$n->$handle(@_)
61            };
62        }
63    }
64   
65    if (exists $attr{lazy} && $attr{lazy}) {
66        _has_lazy_install($pkg, $n, %attr);
67    } else {
68        _has_install($pkg, $n, %attr);
69    }
70}
71
72sub _has_install {
73    my($pkg, $n) = @_;
74    no strict 'refs';
75    *{"$pkg\::$n"} = sub {
76        return $_[0]->{$n} if @_ == 1;
77        return $_[0]->{$n} = $_[1] if @_ == 2;
78        shift->{$n} = \@_;
79    };
80}
81
82sub _has_lazy_install {
83    my($pkg, $n) = @_;
84    my $has = $pkg->meta->{has}->{$n};
85    no strict 'refs';
86    *{"$pkg\::$n"} = sub {
87        if (@_ == 1) {
88            unless (exists $_[0]->{$n} && exists $has->{default}) {
89                my $code = $has->{default};
90                return $_[0]->{$n} = ref($code) eq 'CODE' ? $code->() : $code;
91            }
92            return $_[0]->{$n};
93        }
94        return $_[0]->{$n} = $_[1] if @_ == 2;
95        shift->{$n} = \@_;
96    };
97}
98
99sub _extends {
100    my $pkg = caller(0);
101    my @parents = @_;
102    no strict 'refs';
103    unshift @{"$pkg\::ISA"}, @parents;
104}
105
106sub _with {
107    my $pkg = caller(0);
108    my @roles = @_;
109
110    for my $role (@roles) {
111        Shika::_load_class($role) unless $role->can('meta');
112        next unless $role->can('meta');
113
114        for my $method (@{ _get_functions($role) }) {
115            next if $method eq 'has' || $method eq 'requires' || $method eq 'meta';
116            next if $pkg->can($method);
117            no strict 'refs';
118            *{"$pkg\::$method"} = *{"$role\::$method"};
119        }
120    }
121}
122
123sub _load_class {
124    my $role = shift;
125    eval "require $role" ## no critic ### too bad
126}
127
128# copied from Class::Inspector
129sub _get_functions {
130    my $name = shift;
131
132    no strict 'refs';
133    # Get all the CODE symbol table entries
134    my @functions = sort grep { /\A[^\W\d]\w*\z/o }
135        grep { defined &{"${name}::$_"} }
136            keys %{"${name}::"};
137    \@functions;
138}
139
1401;
141__END__
142
143=head1 NAME
144
145Shika - Lightweight class builder with DSL
146
147=head1 SYNOPSIS
148
149  package Point;
150  use Shika; # automatically turns on strict and warnings
151
152  has 'x';
153  has 'y';
154
155  sub clear {
156      my $self = shift;
157      $self->x(0);
158      $self->y(0);
159  }
160
161  package Point3D;
162  use Shika;
163
164  extends 'Point';
165
166  has 'z';
167
168  after 'clear' => sub {
169      my $self = shift;
170      $self->z(0);
171  };
172
173=head1 DESCRIPTION
174
175Shika is
176
177=head1 AUTHOR
178
179tokuhirom
180
181yappo
182
183lestrrat
184
185typester
186
187charsbar
188
189miyagawa
190
191kan
192
193walf443
194
195kazuho
196
197hidek
198
199mattn
200
201=head1 TODO
202
203    - coerce
204    - method modifiers
205    - role support
206    - isa?
207    - set default value lazily
208
209=head1 SEE ALSO
210
211=head1 REPOSITORY
212
213  svn co http://svn.coderepos.org/share/lang/perl/Shika/trunk Shika
214
215Shika is Subversion repository is hosted at L<http://coderepos.org/share/>.
216patches and collaborators are welcome.
217
218=head1 LICENSE
219
220This library is free software; you can redistribute it and/or modify
221it under the same terms as Perl itself.
222
223=cut
Note: See TracBrowser for help on using the browser.