File Coverage

blib/lib/Class/Meta/Express.pm
Criterion Covered Total %
statement 107 107 100.0
branch 21 24 87.5
condition 2 2 100.0
subroutine 22 22 100.0
pod 6 6 100.0
total 158 161 98.1


line stmt bran cond sub pod time code
1             package Class::Meta::Express;
2              
3 2     2   142350 use strict;
  2         13  
  2         64  
4 2     2   9 use vars qw($VERSION);
  2         4  
  2         114  
5 2     2   1461 use Class::Meta 0.60;
  2         30846  
  2         114  
6              
7             $VERSION = '0.14';
8              
9             my %meta_for;
10              
11             sub import {
12 18     18   22914 my $pkg = shift;
13 18         40 my $caller = caller;
14 2     2   14 no strict 'refs';
  2         5  
  2         1381  
15 18 50       29 return shift if defined &{"$caller\::meta"};
  18         176  
16 108         560 *{"$caller\::$_"} = $pkg->can($_)
17 18         109 for qw(class meta ctor has method build);
18 18         2063 return shift;
19             }
20              
21             sub class (&) {
22 14     14 1 25990 my $code = shift;
23             goto sub {
24 14     14   38 $code->();
25 14         1110 goto &build;
26 14         54 };
27             }
28              
29             sub meta {
30 25     25 1 22696 _new_meta( scalar caller, @_ );
31             }
32              
33             sub ctor {
34 8     8 1 54 unshift @_, 'constructor';
35 8         26 goto &_meth;
36             }
37              
38             sub has {
39 21     21 1 1043 my $caller = caller;
40 21         50 my $meta = _meta_for( $caller );
41 21         60 unshift @_, $meta, 'name';
42 21 100       56 splice @_, 3, 1, %{ $_[3] } if ref $_[3] eq 'HASH';
  2         9  
43 21         27 goto &{ $meta->can('add_attribute') };
  21         126  
44             }
45              
46             sub method {
47 4     4 1 472 unshift @_, 'method';
48 4         12 goto &_meth;
49             }
50              
51             sub build {
52 26     26 1 986 my $meta = delete $meta_for{ my $caller = caller };
53             # Remove exported functions.
54 26         70 _unimport($caller);
55              
56             # Build the class.
57 26         54 unshift @_, $meta;
58 26         62 goto &{ $meta->can('build') };
  26         165  
59             }
60              
61             sub _new_meta {
62 26     26   68 my ($caller, $key) = (shift, shift);
63 26 100       96 my $args = ref $_[0] eq 'HASH' ? $_[0] : { @_ };
64 26         62 $args->{key} = $key;
65 26 100       89 _export(delete $args->{reexport}, $caller, $args) if $args->{reexport};
66 26   100     93 my $meta_class = delete $args->{meta_class} || 'Class::Meta';
67 26         44 my $meta = $meta_class->new( package => $caller, %{ $args } );
  26         163  
68 26         6539 $meta_for{$caller} = $meta;
69 26         82 return $meta;
70             }
71              
72             sub _meta_for {
73 33     33   54 my $caller = shift;
74 33 100       129 unless ( $meta_for{ $caller } ) {
75             # Create a key from the last part of the package name.
76 1         8 (my $key = $caller) =~ s/.*:://;
77 1         3 $key = lcfirst $key;
78 1         10 $key =~ s/([[:upper:]]+)/_\L$1/g;
79 1         4 _new_meta( $caller, $key );
80             }
81 33         65 return $meta_for{ $caller };
82             }
83              
84             sub _meth {
85 12     12   29 my $method = 'add_' . shift;
86 12         36 my $meta = _meta_for( scalar caller );
87 12         28 unshift @_, $meta, 'name';
88 12 100       35 if (my $ref = ref $_[3]) {
89 8 100       22 if ($ref eq 'CODE') {
90 4         13 splice @_, 3, 0, 'code';
91             } else {
92 4 50       17 splice @_, 3, 1, %{ $_[3] } if $ref eq 'HASH';
  4         14  
93             }
94             }
95 12         21 goto &{ $meta->can($method) };
  12         71  
96             }
97              
98             sub _unimport {
99 26     26   48 my $caller = shift;
100 26         75 for my $fn (qw(class meta ctor has method build)) {
101 2     2   17 no strict 'refs';
  2         5  
  2         563  
102 156         331 my $name = "$caller\::$fn";
103             # Copy the current glob contents, excluding CODE.
104 156         200 my %things = map { $_ => *{$name}{$_} }
  156         439  
105 156         233 grep { defined *{$name}{$_} }
  780         987  
  780         1905  
106             qw(SCALAR ARRAY HASH IO FORMAT);
107             # Undefine the glob and reinstall the contents.
108 156         232 undef *{$name};
  156         380  
109 156         340 *{$name} = $things{$_} for keys %things;
  156         450  
110             }
111             }
112              
113             sub _export {
114 8     8   18 my ($export, $pkg, $args) = @_;
115 8         19 my @args = map { $_ => $args->{$_} } grep { exists $args->{$_} }
  8         23  
  56         115  
116             Class::Meta::INHERITABLE, 'meta_class';
117              
118             my $meta = !@args ? \&meta : sub {
119 4     4   3362 splice @_, 1, 0, @args;
120 4         14 goto &Class::Meta::Express::meta;
121 8 100       30 };
122              
123 8 100       25 $export = 0 unless ref $export eq 'CODE';
124              
125 2     2   14 no strict 'refs';
  2         5  
  2         137  
126 8         47 *{"$pkg\::import"} = sub {
127 8     8   3133 my $caller = caller;
128 2     2   13 no strict 'refs';
  2         4  
  2         317  
129 8 50       14 unless (defined &{"$caller\::meta"}) {
  8         72  
130 8         15 *{"$caller\::meta"} = $meta;
  8         32  
131 40         156 *{"$caller\::$_"} = \&{__PACKAGE__ . "::$_"}
  40         112  
132 8         19 for qw(class ctor has method build);
133             }
134 8 100       27 goto $export if $export;
135 4         438 return shift;
136 8         27 };
137             }
138              
139             1;
140             __END__