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

Revision 25077, 3.2 kB (checked in by tokuhirom, 5 years ago)

load_class というメソッド定義しておいだした

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