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

Revision 25099, 4.9 kB (checked in by tokuhirom, 5 years ago)

cleanup setter code with eval

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