File Coverage

blib/lib/MooX/Press.pm
Criterion Covered Total %
statement 1395 1596 87.4
branch 493 720 68.4
condition 225 421 53.4
subroutine 203 212 95.7
pod 10 53 18.8
total 2326 3002 77.4


line stmt bran cond sub pod time code
1 40     40   3531213 use 5.008008;
  40         286  
2 40     40   156 use strict;
  40         54  
  40         720  
3 40     40   147 use warnings;
  40         68  
  40         2364  
4              
5              
6             our $AUTHORITY = 'cpan:TOBYINK';
7             our $VERSION = '0.084';
8              
9             use Types::Standard 1.010000 -is, -types;
10 40     40   11624 use Types::TypeTiny qw(ArrayLike HashLike);
  40         1979857  
  40         288  
11 40     40   266034 use Type::Registry ();
  40         79  
  40         244  
12 40     40   84051 use Exporter::Tiny qw(mkopt);
  40         227281  
  40         914  
13 40     40   279 use Import::Into;
  40         64  
  40         136  
14 40     40   20025 use match::simple qw(match);
  40         70632  
  40         1054  
15 40     40   12325 use Module::Runtime qw(use_module);
  40         55423  
  40         223  
16 40     40   6423 use namespace::autoclean;
  40         61  
  40         186  
17 40     40   13943  
  40         396312  
  40         135  
18             my $p = shift;
19             $] lt '5.018' ? "main::$p" : "::$p";
20 311     311 0 408 }
21 311 50       1035  
22             if ( $] lt '5.010' ) {
23             require UNIVERSAL::DOES;
24             }
25              
26             # Options not to carry up into subclasses;
27             # mostly because subclasses inherit behaviour anyway.
28             my @delete_keys = qw(
29             subclass
30             has
31             with
32             extends
33             overload
34             factory
35             coerce
36             around
37             before
38             after
39             type_name
40             can
41             type_library_can
42             factory_package_can
43             abstract
44             multimethod
45             symmethod
46             multifactory
47             );
48              
49             my $_handle_list = sub {
50             my ($thing) = @_;
51             return ()
52             unless defined $thing;
53             return $thing
54             if is_Str $thing;
55             return %$thing
56             if is_HashRef $thing;
57             return @$thing
58             if is_ArrayRef $thing;
59             goto $thing
60             if is_CodeRef $thing;
61             die "Unexepcted thing; got $thing";
62             };
63              
64             my $_handle_list_add_nulls = sub {
65             my ($thing) = @_;
66             return map @$_, @{mkopt $thing}
67             if is_ArrayRef $thing;
68             goto $_handle_list;
69             };
70              
71             my %_cached_moo_helper;
72              
73             my $builder = shift;
74             my $opts = $_[0];
75            
76 49     49   126 $opts->{default_is} ||= 'ro';
77 49         71
78             $opts->{toolkit} ||= $ENV{'PERL_MOOX_PRESS_TOOLKIT'} || 'Moo';
79 49   50     276
80             $opts->{version} = $opts->{caller}->VERSION
81 49   50     211 unless exists $opts->{version};
      66        
82            
83             $opts->{authority} = do { no strict 'refs'; no warnings 'once'; ${$opts->{caller}."::AUTHORITY"} }
84 49 100       716 unless exists $opts->{authority};
85            
86 40     40   10863 unless (exists $opts->{prefix}) {
  40     40   76  
  40         1114  
  40         199  
  40         69  
  40         23199  
  42         63  
  42         200  
87 49 100       146 $opts->{prefix} = $opts->{caller};
88             if ($opts->{prefix} eq 'main') {
89 49 100       274 $opts->{prefix} = undef;
90 10         23 }
91 10 100       32 }
92 2         4
93             my $no_warn = exists($opts->{factory_package});
94            
95             $opts->{factory_package} = defined($opts->{prefix}) ? $opts->{prefix} : 'Local'
96 49         94 unless exists $opts->{factory_package};
97            
98             if (!$no_warn and defined($opts->{factory_package}) and $opts->{factory_package} eq 'Local') {
99 49 50       207 require FindBin;
    100          
100             if ($FindBin::Script ne '-e') {
101 49 50 66     252 require Carp;
      66        
102 0         0 Carp::carp('Using "Local" as factory; please set prefix or factory_package');
103 0 0       0 }
104 0         0 }
105 0         0
106             unless (exists $opts->{type_library}) {
107             $opts->{type_library} = $builder->qualify_name('Types', $opts->{prefix});
108             }
109 49 50       128 }
110 49         142  
111             my $builder = shift;
112             my $caller = caller;
113             my %opts = @_==1 ? shift->$_handle_list_add_nulls : @_;
114             $opts{caller} ||= $caller;
115 49     49   41540 $opts{caller_file} ||= [caller]->[1];
116 49         103
117 49 50       291 $builder->_apply_default_options(\%opts);
118 49   66     1124 $builder->munge_options(\%opts);
119 49   33     287
120             $builder->_mark_package_as_loaded('factory package' => $opts{factory_package}, \%opts);
121 49         186
122 49         193 my @role_generators = @{ mkopt $opts{role_generator} };
123             my @class_generators = @{ mkopt $opts{class_generator} };
124 49         159 my @roles = @{ mkopt $opts{role} };
125             my @classes = @{ mkopt $opts{class} };
126 49         78
  49         226  
127 49         321 # Canonicalize these now, saves repeatedly doing it later!
  49         129  
128 49         221 for my $pkg (@role_generators) {
  49         113  
129 49         656 if (is_CodeRef($pkg->[1])
  49         117  
130             or is_HashRef($pkg->[1]) && is_CodeRef($pkg->[1]{code})) {
131             $pkg->[1] = { generator => $pkg->[1] };
132 49         810 }
133 2 50 33     14 $pkg->[1] = { $pkg->[1]->$_handle_list };
      66        
134             $builder->munge_role_generator_options($pkg->[1], \%opts);
135 2         3 }
136             for my $pkg (@class_generators) {
137 2         7 if (is_CodeRef($pkg->[1])
138 2         6 or is_HashRef($pkg->[1]) && is_CodeRef($pkg->[1]{code})) {
139             $pkg->[1] = { generator => $pkg->[1] };
140 49         92 }
141 2 50 33     11 $pkg->[1] = { $pkg->[1]->$_handle_list };
      66        
142             $builder->munge_class_generator_options($pkg->[1], \%opts);
143 2         4 }
144             for my $pkg (@roles) {
145 2         5 $pkg->[1] = { $pkg->[1]->$_handle_list };
146 2         5 # qualify names in role list early
147             $pkg->[0] = make_absolute_package_name(
148 49         90 $builder->qualify_name($pkg->[0], exists($pkg->[1]{prefix})?$pkg->[1]{prefix}:$opts{prefix})
149 57         126 );
150             $builder->munge_role_options($pkg->[1], \%opts);
151             }
152             for my $pkg (@classes) {
153 57 50       178 $pkg->[1] = { $pkg->[1]->$_handle_list };
154 57         182 if (defined $pkg->[1]{extends} and not ref $pkg->[1]{extends}) {
155             $pkg->[1]{extends} = [$pkg->[1]{extends}];
156 49         90 }
157 69         139 $builder->munge_class_options($pkg->[1], \%opts);
158 69 100 100     252 }
159 9         26  
160             if ($opts{type_library}) {
161 69         182 $builder->prepare_type_library($opts{type_library}, %opts);
162             # no type for role generators
163             for my $pkg (@class_generators) {
164 49 50       139 $builder->make_type_for_class_generator($pkg->[0], %opts, %{$pkg->[1]});
165 49         248 }
166             for my $pkg (@roles) {
167 49         181 $builder->make_type_for_role($pkg->[0], %opts, %{$pkg->[1]});
168 2         5 }
  2         7  
169             for my $pkg (@classes) {
170 49         166 $builder->make_type_for_class($pkg->[0], %opts, %{$pkg->[1]});
171 57         216 }
  57         346  
172             }
173 49         154
174 69         205 my $reg;
  69         319  
175             if ($opts{factory_package}) {
176             require Type::Registry;
177             $reg = 'Type::Registry'->for_class($opts{factory_package});
178 49         86 $reg->add_types($_) for (
179 49 100       127 $opts{type_library},
180 47         204 qw( Types::Standard Types::Common::Numeric Types::Common::String Types::TypeTiny ),
181 47         1155 );
182 47         372 }
183            
184             if (defined $opts{'factory_package'}) {
185             no strict 'refs';
186            
187             my %methods;
188 49 100       2094042 my $method_installer = $opts{toolkit_install_methods} || ("install_methods");
189 40     40   250
  40         65  
  40         7451  
190             %methods = delete($opts{factory_package_can})->$_handle_list_add_nulls;
191 47         93 if ( my $p = $opts{'prefix'} ) {
192 47   50     261 $methods{qualify} ||= sub { $builder->qualify_name($_[1], $p) }
193             unless exists &{$opts{'factory_package'}.'::qualify'};
194 47         190 $methods{get_class} ||= sub { shift; $builder->_get_class($p, @_) }
195 47 50       207 unless exists &{$opts{'factory_package'}.'::get_class'};
196 0     0   0 $methods{get_role} ||= sub { shift; $builder->_get_role($p, @_) }
197 47 100 50     73 unless exists &{$opts{'factory_package'}.'::get_role'};
  47         587  
198 2     2   4 }
  2         7  
199 47 100 50     75 $builder->$method_installer($opts{'factory_package'}, \%methods) if keys %methods;
  47         439  
200 1     1   2
  1         4  
201 47 100 50     66 %methods = delete($opts{type_library_can})->$_handle_list_add_nulls;
  47         437  
202             $builder->$method_installer($opts{type_library}, \%methods) if keys %methods;
203 47 100       414
204             no strict 'refs';
205 47         163 push @{ $opts{'factory_package'} . '::ISA' }, 'Exporter::Tiny';
206 47 50       145 }
207            
208 40     40   235 my %modifiers;
  40         80  
  40         14341  
209 47         79 $opts{$_} && ($modifiers{$_} = delete $opts{$_})
  47         523  
210             for qw/ before after around can with constant symmethod multimethod extends /;
211            
212 49         99 for my $pkg (@roles) {
213             $builder->do_coercions_for_role($pkg->[0], %opts, reg => $reg, %{$pkg->[1]});
214 49   66     431 }
215             for my $pkg (@classes) {
216 49         120 $builder->do_coercions_for_class($pkg->[0], %opts, reg => $reg, %{$pkg->[1]});
217 57         177 }
  57         212  
218            
219 49         106 for my $pkg (@role_generators) {
220 69         201 $builder->make_role_generator($pkg->[0], %opts, %{$pkg->[1]});
  69         259  
221             }
222             for my $pkg (@class_generators) {
223 49         114 $builder->make_class_generator($pkg->[0], %opts, %{$pkg->[1]});
224 2         5 }
  2         10  
225             for my $pkg (@roles) {
226 49         102 $builder->make_role($pkg->[0], _parent_opts => \%opts, _roles => \@roles, %opts, %{$pkg->[1]});
227 2         5 }
  2         7  
228             for my $pkg (@classes) {
229 49         86 $builder->make_class($pkg->[0], _parent_opts => \%opts, _classes => \@classes, _roles => \@roles, %opts, %{$pkg->[1]});
230 57         178 }
  57         198  
231            
232 49         95 if (keys %modifiers) {
233 69         262 $builder->patch_package( $opts{'factory_package'}, prefix => $opts{'prefix'}, %modifiers );
  69         279  
234             }
235            
236 49 100       176 %_cached_moo_helper = (); # cleanups
237 2         10 }
238              
239             my $builder = shift;
240 49         3322 my ($kind, $pkg, $opts) = @_;
241             defined $pkg or return;
242             $INC{Module::Runtime::module_notional_filename($pkg)} = $opts->{caller_file} || 1;
243             if (defined $opts->{factory_package}) {
244 304     304   435 no strict 'refs';
245 304         526 my $idx = \%{ $opts->{factory_package} . '::PACKAGES' };
246 304 100       2392 $idx->{$pkg} = $kind;
247 302   100     1152 }
248 302 100       6006 }
249 40     40   243  
  40         82  
  40         28832  
250 291         351 my $builder = shift;
  291         927  
251 291         650 my ($opts) = @_;
252             for my $key (sort keys %$opts) {
253             if ($key =~ /^(class|role|class_generator|role_generator):((?:::)?[^:].*)$/) {
254             my ($kind, $pkg) = ($1, $2);
255             my $val = delete $opts->{$key};
256 49     49 0 78 if (ref $val) {
257 49         87 push @{ $opts->{$kind} ||= [] }, $pkg, $val;
258 49         1088 }
259 548 100       939 elsif ($val eq 1 or not defined $val) {
260 55         154 push @{ $opts->{$kind} ||= [] }, $pkg;
261 55         82 }
262 55 100 33     102 else {
    50          
263 53   100     64 $builder->croak("$kind\:$pkg shortcut should be '1' or reference");
  53         222  
264             }
265             }
266 2   100     3 }
  2         6  
267             return;
268             }
269 0         0  
270             shift;
271             my ($roleopts, $opts) = @_;
272             return;
273 49         97 }
274              
275             shift;
276             my ($classopts, $opts) = @_;
277 57     57 0 67 return;
278 57         81 }
279 57         79  
280             shift;
281             my ($cgenopts, $opts) = @_;
282             return;
283 69     69 0 85 }
284 69         105  
285 69         100 shift;
286             my ($rgenopts, $opts) = @_;
287             return;
288             }
289 2     2 0 2  
290 2         3 my $me = shift;
291 2         3 my ($name, $prefix, $parent) = @_;
292             my $sigil = "";
293             if ($name =~ /^[@%\$]/) {
294             $sigil = substr $name, 0, 1;
295 2     2 0 4 $name = substr $name, 1;
296 2         3 }
297 2         4 $name = join("::", '', $parent->$_handle_list, $1) if (defined $parent and $name =~ /^\+(.+)/);
298             return $sigil.$2 if $name =~ /^(main)?::(.+)$/;
299             $prefix ? $sigil.join("::", $prefix, $name) : $sigil.$name;
300             }
301 909     909 1 1036  
302 909         1529 shift;
303 909         1005 my ($name, $prefix) = @_;
304 909 50       2140 $name =~ s/^(main)?::// while $name =~ /^(main)?::/;
305 0         0 $prefix = '' unless defined $prefix;
306 0         0 my $stub = $name;
307             if (length $prefix and lc substr($name, 0, length $prefix) eq lc $prefix) {
308 909 100 100     1902 $stub = substr($name, 2 + length $prefix);
309 909 100       2938 }
310 619 100       2087 $stub =~ s/^(main)?::// while $stub =~ /^(main)?::/;
311             $stub =~ s/::/_/g;
312             $stub;
313             }
314 402     402 1 448  
315 402         573 my $me = shift;
316 402         925 my $pfx = shift;
317 402 100       679
318 402         483 my @packages;
319 402 100 100     2103 while ( @_ ) {
320 380         717 my $qname = $me->qualify_name( shift, $pfx );
321             push @packages, (
322 402         815 ref($_[0]) ? $qname->generate_package( shift->$_handle_list ) : $qname
323 402         639 );
324 402         779 }
325            
326             return @packages;
327             }
328 3     3   6  
329 3         4 my %_anony_counter;
330             my $me = shift;
331 3         3 my ($pfx) = @_;
332 3         5 my ($class, @roles) = $me->_helper_for_get_class( @_ );
333 5         10
334 5 100       16 return make_absolute_package_name($class) unless @roles;
335            
336             no warnings qw( uninitialized numeric );
337            
338             my $new_class = $class->can('with_traits')
339 3         7 ? $class->with_traits( @roles )
340             : $me->make_class(
341             make_absolute_package_name(
342             sprintf('%s::__WITH_TRAITS__::__GEN%06d__', $class, ++$_anony_counter{$class})
343             ),
344 2     2   4 extends => make_absolute_package_name($class),
345 2         3 with => [ map make_absolute_package_name($_), @roles ],
346 2         6 prefix => do { no strict 'refs'; ${"$class\::PREFIX"} } || $pfx,
347             factory => $class->FACTORY,
348 2 100       7 toolkit => do { no strict 'refs'; ${"$class\::TOOLKIT"} } || 'Moo',
349             );
350 40     40   258
  40         58  
  40         3246  
351             return make_absolute_package_name($new_class);
352             }
353              
354             my $me = shift;
355             my ($pfx) = @_;
356             my (@roles) = $me->_helper_for_get_class( @_ );
357            
358             return make_absolute_package_name($roles[0]) if @roles==1;
359            
360 40     40   251 no warnings qw( uninitialized numeric );
  40         74  
  40         2321  
361            
362 40 50 33 40   354 my $new_role = $me->make_role(
  40   50     152  
  40         4113  
  1         14  
363             make_absolute_package_name(
364             sprintf('%s::__WITH_TRAITS__::__GEN%06d__', $roles[0], ++$_anony_counter{$roles[0]})
365 1         6 ),
366             with => [ map make_absolute_package_name($_), @roles ],
367             prefix => do { no strict 'refs'; ${$roles[0]."::PREFIX"} } || $pfx,
368             toolkit => do { no strict 'refs'; ${$roles[0]."::TOOLKIT"} } || 'Moo',
369 1     1   2 );
370 1         3
371 1         2 return make_absolute_package_name($new_role);
372             }
373 1 50       5  
374             shift;
375 40     40   231 require Carp;
  40         61  
  40         2645  
376             goto \&Carp::croak;
377             }
378              
379             my $none;
380             no strict 'refs';
381             no warnings 'once';
382 40     40   226 my $builder = shift;
  40         75  
  40         1483  
383 40   0 40   205 my ($lib, %opts) = @_;
  40   0     273  
  40         4271  
  0         0  
384             return if exists &{"$lib\::_mooxpress_add_type"};
385             my ($version, $authority) = ($opts{version}, $opts{authority});
386 0         0 my %types_hash;
387             require Type::Tiny::Role;
388             require Type::Tiny::Class;
389             require Type::Registry;
390 0     0 1 0 use_module('Type::Library')->import::into($lib, -base);
391 0         0 $builder->_mark_package_as_loaded('type library' => $lib, \%opts);
392 0         0 my $adder = sub {
393             my $me = shift;
394             my ($name, $kind, $target, $coercions) = @_;
395             return if $types_hash{$kind}{$target};
396             my $tc_class = 'Type::Tiny::' . ucfirst($kind);
397 40     40   230 my $tc_obj = $tc_class->new(
  40         58  
  40         1020  
398 40     40   165 name => $name,
  40         57  
  40         76377  
399 49     49 1 84 library => $me,
400 49         230 $kind => $target,
401 49 100       73 );
  49         816  
402 47         115 $types_hash{$kind}{$target} = $tc_obj;
403 47         61 $types_hash{'any'}{$target} = $tc_obj;
404 47         13919 $me->add_type($tc_obj);
405 47         75027 Type::Registry->for_class($opts{factory_package})->add_type($tc_obj)
406 47         52587 if defined $opts{factory_package};
407 47         198 if ($coercions) {
408 47         18483 $none ||= ~Any;
409             $tc_obj->coercion->add_type_coercions($none, 'die()');
410 191     191   239 }
411 191         361 };
412 191 100       438 my $getter = sub {
413 190         440 my $me = shift;
414 190         802 my ($kind, $target) = @_;
415             if ($target =~ /^([@%])(.+)$/) {
416             my $sigil = $1;
417             $target = $2;
418             if ($sigil eq '@') {
419 190         23094 return ArrayRef->of($types_hash{$kind}{$target})
420 190         370 if $types_hash{$kind}{$target};
421 190         658 }
422             elsif ($sigil eq '%') {
423 190 100       163677 return HashRef->of($types_hash{$kind}{$target})
424 190 100       5892 if $types_hash{$kind}{$target};
425 7   33     37 }
426 7         699 }
427             $types_hash{$kind}{$target};
428 47         229 };
429             if (defined $opts{'factory_package'} or not exists $opts{'factory_package'}) {
430 224     224   105246 require B;
431 224         348 eval(
432 224 100       496 sprintf '
433 6         18 package %s;
434 6         14 sub type_library { %s };
435 6 50       22 sub get_type_for_package { shift->type_library->get_type_for_package(@_) };
    0          
436             1;
437 6 50       87 ',
438             $opts{'factory_package'},
439             B::perlstring($lib),
440             ) or $builder->croak("Could not install type library methods into factory package: $@");
441 0 0       0 }
442             *{"$lib\::_mooxpress_add_type"} = $adder;
443             *{"$lib\::get_type_for_package"} = $getter;
444 218         550 ${"$lib\::VERSION"} = $version if defined $version;
445 47         148 ${"$lib\::AUTHORITY"} = $authority if defined $authority;
446 47 100 66     193 }
447 45         211  
448             my $builder = shift;
449             my ($name, %opts) = @_;
450             return unless $opts{'type_library'};
451             $builder->croak("Roles ($name) cannnot extend things") if $opts{extends};
452             $builder->_make_type($name, %opts, is_role => 1);
453             }
454              
455 45 50   4 0 3425 my $builder = shift;
  4     15 0 16  
  15       0 57  
          0    
456             my ($name, %opts) = @_;
457             return unless $opts{'type_library'};
458             $builder->_make_type($name, %opts, is_role => 0);
459 47         109 }
  47         220  
460 47         80  
  47         141  
461 47 100       127 my $builder = shift;
  7         20  
462 47 100       153 my ($name, %opts) = @_;
  7         27  
463             my $qname = $builder->qualify_name($name, $opts{prefix});
464              
465             if ($opts{'type_library'}) {
466 61     61 1 973 my $class_type_name = $opts{'class_type_name'}
467 59         289 || sprintf('%sClass', $builder->type_name($qname, $opts{'prefix'}));
468 59 50       142 my $class_type = $opts{'type_library'}->add_type({
469 59 50       115 name => $class_type_name,
470 59         289 parent => ClassName,
471             constraint => sprintf('$_->can("GENERATOR") && ($_->GENERATOR eq %s)', B::perlstring($qname)),
472             });
473            
474 132     132 1 187 my $instance_type_name = $opts{'instance_type_name'}
475 132         1808 || sprintf('%sInstance', $builder->type_name($qname, $opts{'prefix'}));
476 132 50       281 my $instance_type = $opts{'type_library'}->add_type({
477 132         493 name => $instance_type_name,
478             parent => Object,
479             constraint => sprintf('$_->can("GENERATOR") && ($_->GENERATOR eq %s)', B::perlstring($qname)),
480             });
481 2     2 0 4
482 2         8 if ($opts{'factory_package'}) {
483 2         5 my $reg = Type::Registry->for_class($opts{'factory_package'});
484             $reg->add_type($_) for $class_type, $instance_type;
485 2 50       5 }
486             }
487 2   33     8 }
488 2         8  
489             my $builder = shift;
490             my ($name, %opts) = @_;
491             my $qname = $builder->qualify_name($name, $opts{prefix}, $opts{extends});
492            
493             my $type_name = $opts{'type_name'} || $builder->type_name($qname, $opts{'prefix'});
494            
495 2   33     2848 if ($opts{'type_library'}->can('_mooxpress_add_type')) {
496 2         8 $opts{'type_library'}->_mooxpress_add_type(
497             $type_name,
498             $opts{is_role} ? 'role' : 'class',
499             $qname,
500             !!$opts{coerce},
501             );
502 2 50       2450 }
503 2         9  
504 2         25 if (defined $opts{'with'}) {
505             my @tag_roles = grep /\?$/, $opts{'with'}->$_handle_list;
506             for my $role (@tag_roles) {
507             $role =~ s/\?$//;
508             my %opts_clone = %opts;
509             delete $opts_clone{$_} for @delete_keys;
510 191     191   256 $builder->make_type_for_role($role, %opts_clone);
511 191         676 }
512 191         540 }
513              
514 191   66     712 if (defined $opts{'subclass'} and not $opts{'is_role'}) {
515             my @subclasses = $opts{'subclass'}->$_handle_list_add_nulls;
516 191 50       1047 while (@subclasses) {
517             my ($sc_name, $sc_opts) = splice @subclasses, 0, 2;
518             my %opts_clone = %opts;
519             delete $opts_clone{$_} for @delete_keys;
520             $builder->make_type_for_class($sc_name, %opts_clone, extends => make_absolute_package_name($qname), $sc_opts->$_handle_list);
521             }
522 191 100       643 }
523             }
524              
525 191 100       3201 my $builder = shift;
526 75         231 my ($name, %opts) = @_;
527 75         160 $builder->_do_coercions($name, %opts, is_role => 1);
528 2         6 }
529 2         11  
530 2         12 my $builder = shift;
531 2         10 my ($name, %opts) = @_;
532             $builder->_do_coercions($name, %opts, is_role => 0);
533             }
534              
535 191 100 66     1301 my $builder = shift;
536 15         44 my ($name, %opts) = @_;
537 15         479
538 63         127 my $qname = $builder->qualify_name($name, $opts{prefix}, $opts{extends});
539 63         354 my $mytype;
540 63         377 if ($opts{type_library}) {
541 63         177 $mytype = $opts{type_library}->get_type_for_package($opts{'is_role'} ? 'role' : 'class', $qname);
542             }
543            
544             if ($opts{coerce}) {
545             if ($opts{abstract}) {
546             require Carp;
547 57     57 0 82 Carp::croak("abstract class $qname cannot have coercions")
548 57         297 }
549 57         236 my $method_installer = $opts{toolkit_install_methods} || ("install_methods");
550             my @coercions = @{$opts{'coerce'} || []};
551            
552             while (@coercions) {
553 132     132 0 171 my $type = shift @coercions;
554 132         568 if (!ref $type) {
555 132         467 my $tc = $opts{reg}->lookup($type);
556             $type = $tc if $tc;
557             }
558             my $method_name = shift @coercions;
559 189     189   219 defined($method_name) && !ref($method_name)
560 189         644 or $builder->croak("No method name found for coercion to $qname from $type");
561            
562 189         493 my $coderef;
563 189         285 $coderef = shift @coercions if is_CodeRef $coercions[0];
564 189 50       315
565 189 100       589 if ($coderef) {
566             $builder->$method_installer(
567             $qname,
568 189 100       333 { $method_name => sub { local $_ = $_[1]; &$coderef } },
569 7 50       23 );
570 0         0 }
571 0         0
572             if ($mytype) {
573 7   50     30 require B;
574 7 50       14 $mytype->coercion->add_type_coercions($type, sprintf('%s->%s($_)', B::perlstring($qname), $method_name));
  7         27  
575             }
576 7         20 }
577 7         12 }
578 7 100       22
579 3         14 if (defined $opts{'subclass'} and not $opts{'is_role'}) {
580 3 50       55 my @subclasses = $opts{'subclass'}->$_handle_list_add_nulls;
581             while (@subclasses) {
582 7         25 my ($sc_name, $sc_opts) = splice @subclasses, 0, 2;
583 7 50 33     34 my %opts_clone = %opts;
584             delete $opts_clone{$_} for @delete_keys;
585             $builder->do_coercions_for_class($sc_name, %opts_clone, extends => make_absolute_package_name($qname), $sc_opts->$_handle_list);
586 7         10 }
587 7 50       25 }
588             }
589 7 50       18  
590             my $builder = shift;
591             my ($name, %opts) = @_;
592 14     14   29
  14         34  
593 7         41 if ($opts{interface}) {
594             for my $key (qw/ can before after around has multimethod /) {
595             if ($opts{$key}) {
596 7 50       35 require Carp;
597 7         62 my $qname = $builder->qualify_name($name, $opts{prefix});
598 7         21 Carp::croak("interface $qname cannot have $key");
599             }
600             }
601             }
602              
603 189 100 66     1692 for my $key (qw/ abstract extends subclass factory overload multifactory /) {
604 15         39 if ($opts{$key}) {
605 15         477 require Carp;
606 63         105 my $qname = $builder->qualify_name($name, $opts{prefix});
607 63         296 my $kind = $opts{interface} ? 'interface' : 'role';
608 63         337 Carp::croak("$kind $qname cannot have $key");
609 63         177 }
610             }
611            
612             $builder->_make_package($name, %opts, is_role => 1);
613             }
614              
615 71     71 1 107 my $builder = shift;
616 71         413 my ($name, %opts) = @_;
617            
618 71 50       188 if ($opts{abstract}) {
619 0         0 for my $key (qw/ factory /) {
620 0 0       0 if ($opts{$key}) {
621 0         0 require Carp;
622 0         0 my @isa = $opts{extends} ? $builder->_expand_isa($opts{prefix}, $opts{extends}) : ();
623 0         0 my $qname = $builder->qualify_name($name, $opts{prefix}, @isa);
624             Carp::croak("abstract class $qname cannot have $key");
625             }
626             }
627             }
628 71         133
629 426 50       643 for my $key (qw/ interface before_apply after_apply requires /) {
630 0         0 if ($opts{$key}) {
631 0         0 require Carp;
632 0 0       0 my @isa = $opts{extends} ? $builder->_expand_isa($opts{prefix}, $opts{extends}) : ();
633 0         0 my $qname = $builder->qualify_name($name, $opts{prefix}, @isa);
634             my $kind = $opts{abstract} ? 'abstract class' : 'class';
635             Carp::croak("$kind $qname cannot have $key");
636             }
637 71         368 }
638            
639             $builder->_make_package($name, %opts, is_role => 0);
640             }
641 140     140 1 210  
642 140         772 my $builder = shift;
643             my ($name, %opts) = @_;
644 140 100       364 $builder->_make_package_generator($name, %opts, is_role => 1);
645 1         2 }
646 1 50       4  
647 0         0 my $builder = shift;
648 0 0       0 my ($name, %opts) = @_;
649 0         0 $builder->_make_package_generator($name, %opts, is_role => 0);
650 0         0 }
651              
652             my ($builder, $pfx, $ext) = @_;
653             my @raw = $ext->$_handle_list;
654             my @isa;
655 140         240 my $changed;
656 560 50       1699 while (@raw) {
657 0         0 if (@raw > 1 and ref($raw[1])) {
658 0 0       0 my $gen = $builder->qualify_name(shift(@raw), $pfx);
659 0         0 my @args = shift(@raw)->$_handle_list;
660 0 0       0 push @isa, make_absolute_package_name($gen->generate_package(@args));
661 0         0 $changed++;
662             }
663             else {
664             push @isa, shift(@raw);
665 140         786 }
666             }
667             @$ext = @isa if $changed;;
668             map $builder->qualify_name($_, $pfx), @isa;
669 2     2 0 3 }
670 2         10  
671 2         12 my $nondeep;
672             my $builder = shift;
673             my ($name, %opts) = @_;
674            
675 2     2 0 2 my @isa = $opts{extends} ? $builder->_expand_isa($opts{prefix}, $opts{extends}) : ();
676 2         8 my $qname = $builder->qualify_name($name, $opts{prefix}, @isa);
677 2         8 my $tn = $builder->type_name($qname, $opts{prefix});
678              
679             no strict 'refs';
680             no warnings 'once';
681 84     84   154 return if ${"$qname\::BUILT"};
682 84         159
683 84         116 $builder->_mark_package_as_loaded(($opts{is_role} ? 'role' : 'class') => $qname, \%opts);
684            
685 84         183 if (!exists $opts{factory} and !exists $opts{multifactory}) {
686 84 100 66     230 $opts{factory} = $opts{abstract} ? undef : sprintf('new_%s', lc $tn);
687 2         5 }
688 2         4
689 2         63 my $toolkit = {
690 2         7 moo => 'Moo',
691             moose => 'Moose',
692             mouse => 'Mouse',
693 82         209 }->{lc $opts{toolkit}} || $opts{toolkit};
694            
695             if ($opts{is_role}) {
696 84 100       164 use_module("$toolkit\::Role")->import::into($qname);
697 84         243 use_module("namespace::autoclean")->import::into($qname);
698             }
699             else {
700             use_module($toolkit)->import::into($qname);
701             use_module("MooX::TypeTiny")->import::into($qname) if $toolkit eq 'Moo' && eval { require MooX::TypeTiny; 'MooX::TypeTiny'->VERSION('0.002001') };
702 211     211   327 use_module("MooseX::XSAccessor")->import::into($qname) if $toolkit eq 'Moose' && eval { require MooseX::XSAccessor };
703 211         876 use_module("namespace::autoclean")->import::into($qname);
704            
705 211 100       638 my $method = "extend_class_" . lc $toolkit;
706 211         526 if (@isa) {
707 211         567
708             # Check that each parent class exists
709 40     40   277 PARENT: for my $parent_qname ( @isa ) {
  40         76  
  40         1110  
710 40     40   181 no strict 'refs';
  40         59  
  40         16034  
711 211 100       289 no warnings 'once';
  211         1207  
712             next if ${"$parent_qname\::BUILT"};
713 204 100       798 next if eval { use_module($parent_qname); 1 };
714            
715 204 100 100     738 # Parent class is not already built by MooX::Press.
716 186 100       803 # Parent class is not loadable.
717             # This is going to be an issue when we try to extend it.
718            
719             my @dfns = @{ $opts{_classes} || [] } or last PARENT;
720            
721             DFN: for my $dfn ( @dfns ) {
722             my ( $dfn_shortname, $dfn_spec ) = @$dfn;
723 204   33     1004 my %dfn_spec = %opts;
724             delete $dfn_spec{$_} for @delete_keys;
725 204 100       531 %dfn_spec = ( %dfn_spec, %$dfn_spec );
726 65         211 my @dfn_isa = $dfn_spec{extends} ? $builder->_expand_isa($dfn_spec{prefix}, $dfn_spec{extends}) : ();
727 65         212550 my $dfn_qname = $builder->qualify_name($dfn_shortname, $dfn_spec{prefix}, @dfn_isa);
728            
729             # We have found a saviour!
730 139         380 if ($parent_qname eq $dfn_qname) {
731 139 100 66     295682 $builder->make_class(
  88         9147  
  88         7788  
732 139 50 66     199704 make_absolute_package_name($parent_qname),
  26         3039  
733 139         467 %dfn_spec,
734             );
735 139         26559 last DFN;
736 139 100       397 }
737             }
738             }
739 81         146
740 40     40   245 $builder->$method($qname, \@isa);
  40         74  
  40         1093  
741 40     40   172 }
  40         72  
  40         7762  
742 81 100       99 }
  81         330  
743 1 50       1
  1         4  
  0         0  
744             my $reg;
745             if ($opts{factory_package}) {
746             require Type::Registry;
747             'Type::Registry'->for_class($qname)->set_parent(
748             'Type::Registry'->for_class($opts{factory_package})
749 1 50       194 );
  1 50       6  
750             $reg = 'Type::Registry'->for_class($qname);
751 1         3 }
752 3         6
753 3         19 {
754 3         21 no strict 'refs';
755 3         24 no warnings 'once';
756 3 100       13 ${"$qname\::TOOLKIT"} = $toolkit;
757 3         8 ${"$qname\::PREFIX"} = $opts{prefix};
758             ${"$qname\::FACTORY"} = $opts{factory_package};
759             ${"$qname\::TYPES"} = $opts{type_library};
760 3 100       9 ${"$qname\::BUILT"} = 1;
761 1         4 &Internals::SvREADONLY(\${"$qname\::$_"}, 1)
762             for qw/TOOLKIT PREFIX FACTORY TYPES BUILT/;
763             for my $var (qw/VERSION AUTHORITY/) {
764             if (defined $opts{lc $var}) {
765 1         5 ${"$qname\::$var"} = $opts{lc $var};
766             &Internals::SvREADONLY(\${"$qname\::$var"}, 1);
767             }
768             }
769             if ( $opts{factory_package} ) {
770 81         272 eval "sub $qname\::FACTORY { q[".$opts{factory_package}."] }; 1"
771             or $builder->croak("Couldn't create link back to factory $qname\::FACTORY: $@");
772             }
773             }
774 204         31860
775 204 100       544 if (defined $opts{'import'}) {
776 195         842 my @imports = $opts{'import'}->$_handle_list;
777             while (@imports) {
778             my $import = shift @imports;
779 195         961 my @params;
780 195         3795 if (is_HashRef($imports[0])) {
781             @params = %{ shift @imports };
782             }
783             elsif (is_ArrayRef($imports[0])) {
784 40     40   229 @params = @{ shift @imports };
  40         55  
  40         1020  
  204         878  
785 40     40   171 }
  40         64  
  40         23966  
786 204         276 use_module($import)->import::into($qname, @params);
  204         921  
787 204         306 }
  204         542  
788 204         269 }
  204         570  
789 204         268
  204         782  
790 204         258 if (my $hook = $opts{'begin'}) {
  204         389  
791 1020         2157 my @coderefs = map {
792 204         381 is_HashRef($_) ? $builder->wrap_coderef(package => $qname, %$_) : $_
793 204         353 } is_ArrayRef($hook) ? @$hook : $hook;
794 408 100       2353 for my $cb (@coderefs) {
795 140         169 $cb->($qname, $opts{is_role} ? 'role' : 'class');
  140         368  
796 140         161 }
  140         284  
797             }
798            
799 204 100       451 if ($opts{overload}) {
800 195 50     0 9815 my @overloads = $opts{overload}->$_handle_list;
          0    
          0    
801             require overload;
802             require Import::Into;
803             'overload'->import::into($qname, @overloads);
804             }
805 204 100       629
806 51         110 if (defined $opts{can}) {
807 51         120 my %methods = $opts{can}->$_handle_list_add_nulls;
808 0         0 $builder->install_methods($qname, \%methods) if keys %methods;
809 0         0 }
810 0 0       0
    0          
811 0         0 if (defined $opts{factory_package_can} and defined $opts{factory_package}) {
  0         0  
812             my %methods = $opts{factory_package_can}->$_handle_list_add_nulls;
813             $builder->install_methods($opts{factory_package}, \%methods) if keys %methods;
814 0         0 }
  0         0  
815            
816 0         0 if (defined $opts{type_library_can} and defined $opts{type_library}) {
817             my %methods = $opts{type_library_can}->$_handle_list_add_nulls;
818             $builder->install_methods($opts{type_library}, \%methods) if keys %methods;
819             }
820 204 100       549
821             if (defined $opts{constant}) {
822 1 50       5 my %constants = $opts{constant}->$_handle_list_add_nulls;
  1 50       4  
823             $builder->install_constants($qname, \%constants) if keys %constants;
824 1         2 }
825 1 50       4
826             if (defined $opts{has}) {
827             $builder->install_attributes($qname, $opts{has}, \%opts);
828             }
829 204 100       1734
830 1         4 if (defined $opts{symmethod}) {
831 1         5 $builder->install_symmethods($qname, $opts{symmethod});
832 1         3 }
833 1         10
834             if (defined $opts{multimethod}) {
835             my @mm = $opts{multimethod}->$_handle_list_add_nulls;
836 204 100       547 while (@mm) {
837 30         99 my ($method_name, $method_spec) = splice(@mm, 0, 2);
838 30 50       295 $builder->install_multimethod($qname, $opts{is_role}?'role':'class', $method_name, $method_spec);
839             }
840             }
841 204 50 33     617
842 0         0 if (defined $opts{with}) {
843 0 0       0 my @roles = $opts{with}->$_handle_list;
844             if (@roles) {
845             my @processed;
846 204 50 33     472 while (@roles) {
847 0         0 if (@roles > 1 and ref($roles[1])) {
848 0 0       0 my $gen = $builder->qualify_name(shift(@roles), $opts{prefix});
849             my @args = shift(@roles)->$_handle_list;
850             push @processed, $gen->generate_package(@args);
851 204 100       359 }
852 5         15 else {
853 5 50       25 my $role_qname = $builder->qualify_name(shift(@roles), $opts{prefix});
854             push @processed, $role_qname;
855             no strict 'refs';
856 204 100       416 no warnings 'once';
857 36         177 if ( $role_qname !~ /\?$/ and not ${"$role_qname\::BUILT"} ) {
858             my ($role_dfn) = grep { $_->[0] eq make_absolute_package_name($role_qname) } @{$opts{_roles}};
859             $builder->make_role(
860 204 100       381 make_absolute_package_name($role_qname),
861 10         36 _parent_opts => $opts{_parent_opts},
862             _roles => $opts{_roles},
863             %{ $opts{_parent_opts} },
864 204 100       2161 %{ $role_dfn->[1] },
865 4         10 ) if $role_dfn;
866 4         76 }
867 4         10 }
868 4 100       21 }
869            
870             my $installer = "apply_roles_" . lc $toolkit;
871             $builder->$installer($qname, $opts{is_role}?'role':'class', \@processed);
872 204 100       1582 }
873 76         216 }
874 76 50       181
875 76         214 if ($opts{is_role} and defined $opts{requires}) {
876 76         158 my $installer = "require_methods_" . lc $toolkit;
877 103 100 100     313 my %requires = $opts{requires}->$_handle_list_add_nulls;
878 1         5 $builder->$installer($qname, \%requires) if keys %requires;
879 1         3 }
880 1         18
881             if (defined $opts{'factory_package'}) {
882             my $fpackage = $opts{'factory_package'};
883 102         277 if ($opts{'factory'}) {
884 102         201 if ($opts{abstract} and $opts{'factory'}->$_handle_list) {
885 40     40   226 require Carp;
  40         62  
  40         921  
886 40     40   150 Carp::croak("abstract class $qname cannot have factory");
  40         76  
  40         34213  
887 102 100 100     268 }
  100         481  
888 6         10 $builder->install_factories($fpackage, $qname, $opts{'factory'});
  24         36  
  6         13  
889             }
890             if ($opts{multifactory}) {
891             my @mm = $opts{multifactory}->$_handle_list_add_nulls;
892             while (@mm) {
893 6         20 my ($method_name, $method_spec) = splice(@mm, 0, 2);
894 6 50       16 my $old_coderef = $method_spec->{code} or die;
  6         27  
895             my $new_coderef = sub { splice(@_, 1, 0, "$qname"); goto $old_coderef };
896             $builder->install_multimethod($fpackage, 'class', $method_name, { %$method_spec, code => $new_coderef });
897             }
898             }
899             }
900 76         176  
901 76 100       331 for my $modifier (qw(before after around)) {
902             if (defined $opts{$modifier}) {
903             my @methods = $opts{$modifier}->$_handle_list;
904             my $installer = "modify_method_" . lc $toolkit;
905 204 100 100     681 while (@methods) {
906 1         3 my @method_names;
907 1         2 push(@method_names, shift @methods)
908 1 50       25 while (@methods and not ref $methods[0]);
909             my $coderef = $builder->_prepare_method_modifier($qname, $modifier, \@method_names, shift(@methods));
910             $builder->$installer($qname, $modifier, \@method_names, $coderef);
911 204 100       479 }
912 195         327 }
913 195 100       391 }
914 182 50 33     433
915 0         0 if ($opts{is_role}) {
916 0         0 for my $event (qw/ before_apply after_apply /) {
917             if (my $hook = $opts{$event}) {
918 182         602 require Role::Hooks;
919             my @coderefs = map {
920 195 100       501 is_HashRef($_) ? $builder->wrap_coderef(package => $qname, %$_) : $_
921 4         10 } is_ArrayRef($hook) ? @$hook : $hook;
922 4         77 'Role::Hooks'->$event($qname, @coderefs);
923 4         10 }
924 4 50       13 }
925 4     4   14 }
  4         9586  
  4         12  
926 4         24
927             # not role
928             else {
929             if ($toolkit eq 'Moose' && !$opts{'mutable'}) {
930             require Moose::Util;
931 204         794 my %args = %{ $opts{'definition_context'} or {} };
932 612 100       1428 delete $args{'package'};
933 20         47 Moose::Util::find_meta($qname)->make_immutable(%args);
934 20         42 }
935 20         42
936 20         21 if ($toolkit eq 'Moo' && eval { require MooX::XSConstructor }) {
937 20   66     111 'MooX::XSConstructor'->setup_for($qname);
938             }
939 20         56
940 20         60 if ($opts{abstract}) {
941             my $orig_can = $qname->can('can');
942             my $orig_BUILD = do { no strict 'refs'; exists(&{"$qname\::BUILD"}) ? \&{"$qname\::BUILD"} : sub {} };
943             'namespace::clean'->clean_subroutines($qname, 'new', 'BUILD');
944             $builder->install_methods($qname, {
945 204 100       1088 can => sub {
946 65         111 if ((ref($_[0])||$_[0]) eq $qname and $_[1] eq 'new') { return; };
947 130 100       1462 goto $orig_can;
948 9         467 },
949             BUILD => sub {
950 9 50       4426 if (ref($_[0]) eq $qname) { require Carp; Carp::croak('abstract class'); };
  9 100       37  
951             goto $orig_BUILD;
952 9         54 },
953             });
954             }
955            
956             if (defined $opts{'subclass'}) {
957             my @subclasses = $opts{'subclass'}->$_handle_list_add_nulls;
958             while (@subclasses) {
959 139 100 66     482 my ($sc_name, $sc_opts) = splice @subclasses, 0, 2;
960 26         104 my %opts_clone = %opts;
961 26 100       38 delete $opts_clone{$_} for @delete_keys;
  26         145  
962 26         55 $builder->make_class($sc_name, %opts_clone, extends => make_absolute_package_name($qname), $sc_opts->$_handle_list);
963 26         1510 }
964             }
965             }
966 139 50 66     101048
  88         9248  
967 0         0 if (my $hook = $opts{'end'}) {
968             my @coderefs = map {
969             is_HashRef($_) ? $builder->wrap_coderef(package => $qname, %$_) : $_
970 139 100       483 } is_ArrayRef($hook) ? @$hook : $hook;
971 1         5 for my $cb (@coderefs) {
972 40 50   40   351 $cb->($qname, $opts{is_role} ? 'role' : 'class');
  40     6   65  
  40         24600  
  1         2  
  1         1  
  1         8  
  0         0  
973 1         14 }
974             }
975            
976 8 100 33 11   39 if ($opts{type_library} and $opts{type_name}) {
  1   100     4  
977 7         43 my $mytype = $opts{type_library}->get_type_for_package($opts{'is_role'} ? 'role' : 'class', $qname);
978             $mytype->coercion->freeze if $mytype;
979             }
980 2 100   3   8
  1         5  
  1         146  
981 1         2 return $qname;
982             }
983 1         74  
984             my ( $me, $package, %spec ) = ( shift, @_ );
985            
986 139 100       362 my $kind = ( $spec{is_role} or do { require Role::Hooks; 'Role::Hooks'->is_role($package) } )
987 15         45 ? 'role'
988 15         533 : 'class';
989 63         150 delete $spec{is_role};
990 63         543
991 63         453 my $fp =
992 63         232 exists($spec{'factory_package'}) ? delete($spec{'factory_package'}) :
993             $package->can('FACTORY') ? $package->FACTORY :
994             do { no strict 'refs'; no warnings; ${"$package\::FACTORY"} };
995            
996             my $prefix =
997 204 50       1545 exists($spec{'prefix'}) ? delete($spec{'prefix'}) :
998             do { no strict 'refs'; no warnings; ${"$package\::PREFIX"} || $fp };
999 0 0       0
  0 0       0  
1000             my $toolkit =
1001 0         0 exists($spec{'toolkit'}) ? delete($spec{'toolkit'}) :
1002 0 0       0 do { no strict 'refs'; no warnings; ${"$package\::TOOLKIT"} || 'Moo' };
1003            
1004             if ( my $version = delete $spec{version} ) {
1005             no strict 'refs';
1006 204 100 100     745 ${"$package\::VERSION"} = $version;
1007 8 50       63 }
1008 8 50       110
1009             if ( my $auth = delete $spec{authority} ) {
1010             no strict 'refs';
1011 204         1929 ${"$package\::AUTHORITY"} = $auth;
1012             }
1013            
1014             if ( $kind eq 'class' and my $extends = delete $spec{extends} ) {
1015 8     8 0 26 my @isa = $me->_expand_isa( $prefix, $extends );
1016             if ( $package->isa("$toolkit\::Object") ) {
1017 13 100 66     5464 my $method = "extend_class_" . lc $toolkit;
1018             $me->$method( $package, \@isa );
1019             }
1020 11         158 else {
1021             no strict 'refs';
1022             no warnings 'once';
1023             @{"$package\::ISA"} = @isa;
1024             }
1025 40 100   40   234 }
  40 50   40   83  
  40         1272  
  40         173  
  40         60  
  40         2227  
  9         149  
  3         4  
  3         10  
1026            
1027             if ( $kind eq 'class' and my $overload = delete $spec{overload} ) {
1028             require overload;
1029 40 100   40   202 require Import::Into;
  40 100   40   61  
  40         890  
  40         166  
  40         65  
  40         2539  
  8         23  
  12         5724  
  9         611  
1030             'overload'->import::into( $package, $overload->$_handle_list );
1031             }
1032            
1033 40 100   40   212 if ( my @coercions = @ { delete $spec{coerce} or [] } ) {
  40 50   40   67  
  40         943  
  40         159  
  40         69  
  40         2062  
  11         7718  
  11         531  
  8         34  
1034             my $to_type = $fp->type_library->get_type_for_package( any => $package );
1035 8 50       40 while ( @coercions ) {
1036 40     40   186 my $from_type = 'Type::Registry'->for_class( $package )->lookup( shift @coercions );
  40         65  
  40         1782  
1037 0         0 my $via_method = shift @coercions;
  0         0  
1038             if ( is_CodeRef $coercions[0] or is_HashRef $coercions[0] ) {
1039             my $coderef = shift @coercions;
1040 8 50       22 'MooX::Press'->install_methods( $package, { $via_method => sub { local $_ = $_[1]; &$coderef } } );
1041 40     40   202 }
  40         57  
  40         3822  
1042 3         493 $to_type->coercion->add_type_coercions(
  0         0  
1043             $from_type,
1044             sprintf( '%s->%s($_)', B::perlstring($package), $via_method ),
1045 8 100 100     38 );
1046 1         4 }
1047 1 50       7 }
1048 1         3
1049 1         5 if ( my $methods = delete $spec{can} ) {
1050             $me->install_methods( $package, $methods );
1051             }
1052 40     40   195
  40         74  
  40         1071  
1053 40     40   172 if ( my $constants = delete $spec{constant} ) {
  40         59  
  40         29529  
1054 0         0 $me->install_constants( $package, $constants );
  0         0  
1055             }
1056            
1057             if ( my $atts = delete $spec{has} ) {
1058 8 50 66     112 $me->install_attributes( $package, $atts );
1059 0         0 }
1060 0         0
1061 0         0 if ( my $symm = delete $spec{symmethod} ) {
1062             $me->install_symmethods($package, $symm);
1063             }
1064 8 50       13
  8 50       44  
1065 0         0 if ( my $multimethods = delete $spec{multimethod} ) {
1066 0         0 my @mm = $multimethods->$_handle_list_add_nulls;
1067 0         0 while ( my ( $name, $code ) = splice( @mm, 0, 2 ) ) {
1068 0         0 'MooX::Press'->install_multimethod( $package, $kind, $name, $code );
1069 0 0 0     0 }
1070 0         0 }
1071 0     0   0
  0         0  
  0         0  
1072             if (defined $spec{with}) {
1073             my @roles = $spec{with}->$_handle_list;
1074 0         0 if (@roles) {
1075             my @processed;
1076             while (@roles) {
1077             if (@roles > 1 and ref($roles[1])) {
1078             my $gen = $me->qualify_name(shift(@roles), $prefix);
1079             my @args = shift(@roles)->$_handle_list;
1080 8 100       22 push @processed, $gen->generate_package(@args);
1081 4         10 }
1082             else {
1083             my $role_qname = $me->qualify_name(shift(@roles), $prefix);
1084 8 100       24 push @processed, $role_qname;
1085 1         7 }
1086             }
1087             my $installer = "apply_roles_" . lc $toolkit;
1088 8 100       29 $me->$installer($package, $kind, \@processed);
1089 1         5 }
1090             }
1091            
1092 8 50       20 if ( $kind eq 'class' ) {
1093 0         0
1094             if ( $fp and my $factory = delete $spec{factory} ) {
1095             $me->install_factories( $fp, $package, $factory );
1096 8 100       19 }
1097 1         3
1098 1         26 if ( $fp and my $factory = delete $spec{multifactory} ) {
1099 2         99 my @mm = $factory->$_handle_list_add_nulls;
1100             while (@mm) {
1101             my ($method_name, $method_spec) = splice(@mm, 0, 2);
1102             my $old_coderef = $method_spec->{code} or die;
1103 8 100       70 my $new_coderef = sub { splice(@_, 1, 0, "$package"); goto $old_coderef };
1104 2         7 $me->install_multimethod( $fp , 'class', $method_name, { %$method_spec, code => $new_coderef });
1105 2 50       6 }
1106 2         2 }
1107 2         7
1108 2 50 33     9 #TODO: subclass???
1109 0         0 }
1110 0         0
1111 0         0 for my $modifier ( qw/ before after around / ) {
1112             my @mm = delete($spec{$modifier})->$_handle_list or next;
1113             require Class::Method::Modifiers;
1114 2         11 my @names;
1115 2         6 while ( @mm ) {
1116             if ( is_ArrayRef $mm[0] ) {
1117             push @names, @{ shift @mm };
1118 2         8 }
1119 2         10 elsif ( is_Str $mm[0] ) {
1120             push @names, shift @mm;
1121             }
1122             else {
1123 8 100       24 my $coderef = $me->_prepare_method_modifier( $package, $modifier, [@names], shift(@mm) );
1124             Class::Method::Modifiers::install_modifier( $package, $modifier, @names, $coderef );
1125 7 50 66     31 @names = ();
1126 0         0 }
1127             }
1128             }
1129 7 50 66     24
1130 0         0 return %spec;
1131 0         0 }
1132 0         0  
1133 0 0       0 my ($builder, $fpackage, $qname, $factories) = @_;
1134 0     0   0 my $to_type;
  0         0  
  0         0  
1135 0         0 my @methods = $factories->$_handle_list;
1136             while (@methods) {
1137             my @method_names;
1138             push(@method_names, shift @methods)
1139             while (@methods and not ref $methods[0]);
1140             my $coderef = shift(@methods) || \1;
1141             NAME: for my $name (@method_names) {
1142 8         16 no warnings 'closure';
1143 24 100       50 if (is_CodeRef $coderef) {
1144 4         22 eval "package $fpackage; sub $name :method { splice(\@_, 1, 0, '$qname'); goto \$coderef }; 1"
1145 4         6 or $builder->croak("Could not create factory $name in $fpackage: $@");
1146 4         11 }
1147 8 50       27 elsif (is_ScalarRef $coderef) {
    100          
1148 0         0 my $target = $$coderef;
  0         0  
1149             if ($target eq 1) {
1150             # default factory shouldn't overwrite manually created one
1151 4         10 next NAME if $fpackage->can($name);
1152             $target = 'new';
1153             }
1154 4         24 eval "package $fpackage; sub $name :method { shift; '$qname'->$target\(\@_) }; 1"
1155 4         19 or $builder->croak("Couldn't create factory $name in $fpackage: $@");
1156 4         954 }
1157             elsif (is_HashRef $coderef) {
1158             my %meta = %$coderef;
1159             $meta{curry} ||= [$qname];
1160            
1161 8         32 if ( match('coercion', $meta{attributes}) or match('coerce', $meta{attributes}) ) {
1162             my @sigtypes = grep !is_HashRef($_), @{$meta{signature}};
1163            
1164             $to_type ||= $fpackage->type_library->get_type_for_package( any => $qname );
1165 182     188 0 422
1166 182         215 $builder->croak('Factories used as coercions must take exactly one positional argument')
1167 182         409 unless is_ArrayRef( $meta{signature} ) && 1==@sigtypes && !$meta{named};
1168 182         387
1169 191         226 $builder->croak("Too late to add coercion to $to_type")
1170 191   100     939 if $to_type->coercion->frozen;
1171            
1172 191   100     600 my $from_type = 'Type::Registry'->for_class($qname)->lookup( $sigtypes[0] );
1173 191         357
1174 40     40   250 $to_type->coercion->add_type_coercions(
  40         78  
  40         16374  
1175 207 100       718 $from_type, sprintf('%s->%s($_)', B::perlstring($fpackage), $name),
    100          
    50          
1176 3 50       174 );
1177            
1178             my @new_attrs = grep !/^coerc/, @{$meta{attributes}};
1179             $meta{attributes} = \@new_attrs;
1180 194         288 }
1181 194 100       436
1182             $builder->install_methods($fpackage, { $name => \%meta });
1183 179 50       1459 }
1184 179         301 else {
1185             die "lolwut?";
1186 194 50       13073 }
1187             }
1188             $builder->_make_exportable_factories($fpackage, @method_names);
1189             }
1190 10         28 }
1191 10   50     47  
1192             my $builder = shift;
1193 10 50 33     53 my ($factory, @methods) = @_;
1194 0         0 foreach my $method ( @methods ) {
  0         0  
1195             eval qq{
1196 0   0     0 package ${factory};
1197             no warnings 'redefine';
1198             sub _generate_${method} :method {
1199 0 0 0     0 sub { q[${factory}]->${method}( \@_ ) };
      0        
1200             }
1201 0 0       0 1;
1202             } or die "Yikes: $@";
1203             }
1204 0         0 no strict 'refs';
1205             push @{ $factory . '::EXPORT_OK' }, @methods;
1206 0         0 push @{ ${ $factory . '::EXPORT_TAGS' }{'factories'} ||= [] }, @methods;
1207             }
1208              
1209             my $builder = shift;
1210 0         0 my ($name, %opts) = @_;
  0         0  
1211 0         0 my $gen = $opts{generator} or die 'no generator code given!';
1212            
1213             my $kind = $opts{is_role} ? 'role' : 'class';
1214 10         39
1215             my $qname = $builder->qualify_name($name, $opts{prefix});
1216            
1217 0         0 $builder->_mark_package_as_loaded("$kind generator" => $qname, \%opts);
1218            
1219             $builder->install_methods(
1220 191         667 $qname,
1221             {
1222             '_generate_package_spec' => $gen,
1223             'generate_package' => sub {
1224             my ($generator_package, @args) = @_;
1225 191     194   303 $builder->generate_package(
1226 191         389 $kind,
1227 198         4950 $generator_package,
1228 214 50   54   10578 \%opts,
  54     32   23042  
  51     19   258  
  41     14   14499  
  31     13   162  
  26     10   912  
  26     7   1446  
  18     7   96  
  18     7   31  
  18     7   938  
  14     6   77  
  14     6   23  
  14     6   764  
  13     6   72  
  13     6   20  
  13     6   633  
  10     6   63  
  10     4   16  
  10     4   586  
  7     4   37  
  7     4   13  
  7     4   399  
  7     4   40  
  7         13  
  7         379  
  7         35  
  7         12  
  7         404  
  7         36  
  7         10  
  7         393  
  6         29  
  6         10  
  6         295  
  6         30  
  6         10  
  6         306  
  6         29  
  6         11  
  6         289  
  6         30  
  6         13  
  6         287  
  6         27  
  6         11  
  6         346  
  6         34  
  6         10  
  6         319  
  6         28  
  6         11  
  6         279  
  4         20  
  4         6  
  4         191  
  4         19  
  4         8  
  4         211  
  4         70  
  4         9  
  4         212  
  4         20  
  4         7  
  4         233  
  4         20  
  4         6  
  4         218  
  4         19  
  4         13  
  4         211  
1229             $generator_package->_generate_package_spec(@args),
1230             );
1231             },
1232             },
1233             );
1234            
1235             if ($opts{factory_package}) {
1236             require Type::Registry;
1237 40     40   233 'Type::Registry'->for_class($qname)->set_parent(
  40         78  
  40         29932  
1238 198         10074 'Type::Registry'->for_class($opts{factory_package})
  198         858  
1239 199   100     14153 );
  199         327  
  199         7714  
1240            
1241             my $tn = $builder->type_name($qname, $opts{prefix});
1242             if (!exists $opts{factory}) {
1243 12     14   90 $opts{factory} = 'generate_' . lc $tn;
1244 13         15693 }
1245 13 50       142 my $fp = $opts{factory_package};
1246             my $f = $opts{factory};
1247 18 100       19038 eval qq{
1248             package $fp;
1249 18         170 sub $f :method {
1250             shift;
1251 4         18 q($qname)->generate_package(\@_);
1252             }
1253             };
1254             }
1255            
1256             return $qname;
1257             }
1258 6     16   17  
1259 6         87 my %_generate_counter;
1260             my $builder = shift;
1261             my $kind = shift;
1262             my $generator_package = shift;
1263             my $global_opts = shift;
1264             my %local_opts = ( @_ == 1 ? $_[0] : \@_ )->$_handle_list;
1265            
1266             $generator_package =~ s/^(main)?::// while $generator_package =~ /^(main)?::/;
1267 4         27
1268             my %opts;
1269 4 50       16 for my $key (qw/ extends with has can constant around before after
1270 4         19 toolkit version authority mutable begin end requires import overload
1271             before_apply after_apply symmethod multimethod definition_context /) {
1272             if (exists $local_opts{$key}) {
1273 6         1161 $opts{$key} = delete $local_opts{$key};
1274             }
1275 6         113 }
1276 11 50       12395
1277 11         136 if (keys %local_opts) {
1278             die "bad keys from generator: ".join(", ", sort keys %local_opts);
1279 4         8 }
1280 4         5
1281 11         17321 # must not generate types or factory methods
1282             $opts{factory} = undef;
1283             $opts{multifactory} = undef;
1284             $opts{type_name} = undef;
1285            
1286             $_generate_counter{$generator_package} = 0 unless exists $_generate_counter{$generator_package};
1287             my $qname = sprintf('%s::__GEN%06d__', $generator_package, ++$_generate_counter{$generator_package});
1288            
1289             require Type::Registry;
1290 11         143 'Type::Registry'->for_class($qname)->set_parent(
1291             'Type::Registry'->for_class($generator_package)
1292             );
1293            
1294             if ($kind eq 'class') {
1295 8     16 0 235 my $method = $opts{toolkit_install_constants} || ("install_constants");
1296 8         42 $builder->$method($qname, { GENERATOR => $generator_package });
1297 6         8 }
1298 6         15
1299 12 50       4899 if ($kind eq 'role') {
1300             return $builder->make_role(make_absolute_package_name($qname), %$global_opts, %opts);
1301 12         124 }
1302             else {
1303 12         4890 return $builder->make_class(make_absolute_package_name($qname), %$global_opts, %opts);
1304 12         91 }
1305             }
1306              
1307 138 100       4896 my $builder = shift;
1308 16         97 my ($package, $helpername) = @_;
1309             return $_cached_moo_helper{"$package\::$helpername"}
1310             if $_cached_moo_helper{"$package\::$helpername"};
1311             die "lolwut?" unless $helpername =~ /^(has|with|extends|around|before|after|requires)$/;
1312 12 50       5135 my $is_role = ($INC{'Moo/Role.pm'} && 'Moo::Role'->is_role($package));
1313 6         77 my $tracker = $is_role ? $Moo::Role::INFO{$package}{exports} : $Moo::MAKERS{$package}{exports};
1314             if (ref $tracker) {
1315             $_cached_moo_helper{"$package\::$helpername"} ||= $tracker->{$helpername};
1316             }
1317 6         12 # I hate this...
1318 6         11 $_cached_moo_helper{"$package\::$helpername"} ||= eval sprintf(
1319 6         9 'do { package %s; use Moo%s; my $coderef = \&%s; no Moo%s; $coderef };',
1320             $package,
1321 6 100       18 $is_role ? '::Role' : '',
1322 6         29 $helpername,
1323             $is_role ? '::Role' : '',
1324 6         29 );
1325 6         32 die "BADNESS: couldn't get helper '$helpername' for package '$package'" unless $_cached_moo_helper{"$package\::$helpername"};
1326             $_cached_moo_helper{"$package\::$helpername"};
1327             }
1328              
1329 6 100       128 my ($builder, $qname) = @_;
1330 4   50     22 {
1331 4         20 no strict 'refs';
1332             return ${"$qname\::TOOLKIT"} if ${"$qname\::TOOLKIT"};
1333             }
1334 6 100       21 for my $tk (qw/ Moo Moose Mouse /) {
1335 2         6 return $tk if $qname->isa("$tk\::Object");
1336             }
1337            
1338 4         11 require Role::Hooks;
1339             if (my $detected = 'Role::Hooks'->is_role($qname)) {
1340             return 'Moo' if $detected eq 'Role::Tiny';
1341             return 'Moo' if $detected eq 'Moo::Role';
1342             return 'Moose' if $detected eq 'Moose::Role';
1343 134     142   206 return 'Mouse' if $detected eq 'Mouse::Role';
1344 134         200 }
1345            
1346 134 100       373 'Moo'; # guess
1347 125 50       548 }
1348 125   66     627  
1349 125 100       2782 my ($builder, $qname) = @_;
1350 125 50       284 {
1351 0   0     0 no strict 'refs';
1352             return ${"$qname\::PREFIX"} if ${"$qname\::PREFIX"};
1353             }
1354 125 100 33 33   7149 return undef;
  33 100   33   1029  
  33     20   3667  
  33     20   165  
  33     14   9348  
  33     14   58  
  33     10   108  
  20     10   113  
  20     7   33  
  20     7   74  
  20     4   5646  
  20     4   35  
  20     3   64  
  14     3   77  
  14     3   24  
  14     3   50  
  14     3   3174  
  14     3   26  
  14     3   43  
  10     3   51  
  10     3   13  
  10     3   32  
  10     2   2173  
  10     2   23  
  10     2   35  
  7     2   40  
  7     2   15  
  7     2   23  
  7     2   1614  
  7     2   12  
  7     2   22  
  4     2   21  
  4     2   7  
  4     2   11  
  4     2   797  
  4     2   6  
  4     2   11  
  3     2   14  
  3     2   5  
  3     2   11  
  3     2   686  
  3     2   5  
  3     2   8  
  3     2   15  
  3         53  
  3         13  
  3         605  
  3         6  
  3         7  
  3         14  
  3         4  
  3         19  
  3         731  
  3         4  
  3         8  
  3         16  
  3         5  
  3         9  
  3         570  
  3         5  
  3         8  
  3         15  
  3         4  
  3         10  
  3         689  
  3         5  
  3         8  
  2         10  
  2         3  
  2         6  
  2         830  
  2         3  
  2         7  
  2         9  
  2         2  
  2         6  
  2         811  
  2         4  
  2         17  
  2         10  
  2         4  
  2         5  
  2         809  
  2         3  
  2         5  
  2         10  
  2         2  
  2         8  
  2         466  
  2         3  
  2         6  
  2         10  
  2         4  
  2         6  
  2         384  
  2         3  
  2         5  
  2         10  
  2         9  
  2         7  
  2         449  
  2         4  
  2         4  
  2         9  
  2         4  
  2         6  
  2         369  
  2         3  
  2         6  
  2         10  
  2         4  
  2         7  
  2         483  
  2         4  
  2         6  
  2         9  
  2         4  
  2         5  
  2         382  
  2         2  
  2         7  
  2         10  
  2         3  
  2         6  
  2         449  
  2         4  
  2         5  
  2         11  
  2         3  
  2         6  
  2         392  
  2         1221  
  2         8  
1355             }
1356              
1357             my ($builder, $qname) = @_;
1358             {
1359             no strict 'refs';
1360             return ${"$qname\::TYPES"} if ${"$qname\::TYPES"};
1361 125 50       507 }
1362 125         310
1363             my $factory = $qname->can('FACTORY');
1364             $factory ||= do {
1365             no strict 'refs';
1366 1     10   3 ${"$qname\::FACTORY"} || ${"$qname\::FACTORY"};
1367             };
1368 40     40   241 return $factory->type_library
  40         79  
  40         6223  
  1         2  
1369 1 50       1 if $factory && $factory->can('type_library');
  1         5  
  1         5  
1370            
1371 0         0 return undef;
1372 0 0       0 }
1373              
1374             my ($builder, $qname, $has, $opts) = @_;
1375 0         0 $opts ||= {};
1376 0 0       0
1377 0 0       0 my $prefix = $opts->{prefix} || $builder->_detect_prefix($qname);
1378 0 0       0 my $toolkit = $opts->{toolkit} || $builder->_detect_toolkit($qname);
1379 0 0       0 my $types = $opts->{type_library} || $builder->_detect_type_library($qname);
1380 0 0       0 my $reg = $opts->{reg} || 'Type::Registry'->for_class($qname);
1381             my $installer = 'make_attribute_' . lc $toolkit;
1382            
1383 0         0 my @attrs = $has->$_handle_list_add_nulls;
1384            
1385             my $make_immutable = 0;
1386             my $meta =
1387 4     18   8 ( $toolkit eq 'Moose' ) ? Moose::Util::find_meta( $qname ) :
1388             ( $toolkit eq 'Mouse' ) ? Mouse::Util::find_meta( $qname ) :
1389 40     40   223 undef;
  40         68  
  40         2914  
  4         7  
1390 4 100       4 if ( $meta and $meta->is_immutable ) {
  1         4  
  4         14  
1391             $meta->make_mutable;
1392 3         7 $make_immutable = 1;
1393             }
1394            
1395             while (@attrs) {
1396 1     1   3 my ($attrname, $attrspec) = splice @attrs, 0, 2;
1397            
1398 40     40   214 my %spec_hints;
  40         86  
  40         2430  
  1         2  
1399 1 50       2 if ($attrname =~ /^(\+?)(\$|\%|\@)(.+)$/) {
  1         4  
  1         5  
1400             $spec_hints{isa} ||= {
1401             '$' => ($nondeep ||= ((~ArrayRef)&(~HashRef))),
1402 0         0 '@' => ArrayLike,
1403 0   0     0 '%' => HashLike,
1404 40     40   206 }->{$2};
  40         73  
  40         11039  
1405 0 0       0 no warnings 'uninitialized';
  0         0  
  0         0  
1406             $attrname = $1.$3; # allow plus before sigil
1407 0 0 0     0 }
1408             if ($attrname =~ /^(.+)\!$/) {
1409             $spec_hints{required} = 1;
1410 0         0 $attrname = $1;
1411             }
1412            
1413             (my $buildername = "_build_$attrname") =~ s/\+//;
1414 37     40 0 102 (my $clearername = ($attrname =~ /^_/ ? "_clear$attrname" : "clear_$attrname")) =~ s/\+//;
1415 37   100     111
1416             my %spec =
1417 37   100     144 is_CodeRef($attrspec) ? (is => $opts->{default_is}, lazy => 1, builder => $attrspec, clearer => $clearername) :
1418 37   66     162 is_Object($attrspec) && $attrspec->can('check') ? (is => $opts->{default_is}, isa => $attrspec) :
1419 37   66     98 $attrspec->$_handle_list;
1420 37   33     191
1421 37         337 if (is_CodeRef $spec{builder}) {
1422             my $code = delete $spec{builder};
1423 37         123 $spec{builder} = $buildername;
1424             $builder->install_methods($qname, { $buildername => $code });
1425 37         705 }
1426 37 100       164
    100          
1427             if (defined $spec{clearer} and !ref $spec{clearer} and $spec{clearer} eq 1) {
1428             $spec{clearer} = $clearername;
1429             }
1430 37 50 66     218
1431 0         0 %spec = (%spec_hints, %spec);
1432 0         0 $spec{is} ||= ($opts->{default_is} || 'ro');
1433            
1434             if ($spec{is} eq 'lazy') {
1435 37         102 $spec{is} = 'ro';
1436 58         141 $spec{lazy} = !!1;
1437             $spec{builder} ||= $buildername unless exists $spec{default};
1438 58         78 }
1439 58 100       261 elsif ($spec{is} eq 'private') {
1440             $spec{is} = 'rw';
1441             $spec{lazy} = !!1;
1442             $spec{init_arg} = undef;
1443             $spec{lexical} = !!1;
1444 8   66     107 }
      33        
1445 40     40   238
  40         72  
  40         45715  
1446 8         10418 if ($spec{does}) {
1447             my $target = $builder->qualify_name(delete($spec{does}), $prefix);
1448 58 100       152 $spec{isa} ||= $types->get_type_for_package(role => $target) if $types;
1449 9         22 $spec{isa} ||= ConsumerOf->of($target);
1450 9         22 }
1451            
1452             if ($spec{isa} && !ref $spec{isa}) {
1453 58         160 my $target = $builder->qualify_name(delete($spec{isa}), $prefix);
1454 58 50       196 $spec{isa} ||= $types->get_type_for_package(class => $target) if $types;
1455             $spec{isa} ||= InstanceOf->of($target);
1456             }
1457            
1458 58 100 66     354 if ($spec{enum}) {
    100          
1459             $spec{isa} = Enum->of(@{delete $spec{enum}});
1460             }
1461 58 100       362
1462 3         8 if (is_Object($spec{type}) and $spec{type}->can('check')) {
1463 3         5 $spec{isa} = delete $spec{type};
1464 3         13 }
1465             elsif ($spec{type}) {
1466             $reg ||= 'Type::Registry'->for_class($qname);
1467 58 50 100     213 $spec{isa} = $reg->lookup(delete $spec{type});
      66        
1468 0         0 }
1469            
1470             if (ref $spec{isa} && !exists $spec{coerce} && $spec{isa}->has_coercion) {
1471 58         181 $spec{coerce} = 1;
1472 58   100     273 }
      66        
1473            
1474 58 100       222 if ($toolkit ne 'Moo') {
    100          
1475 1         3 if (defined $spec{trigger} and !ref $spec{trigger} and $spec{trigger} eq 1) {
1476 1         2 $spec{trigger} = sprintf('_trigger_%s', $attrname);
1477 1 50 33     9 }
1478             if (defined $spec{trigger} and !ref $spec{trigger}) {
1479             my $trigger_method = delete $spec{trigger};
1480 2         3 $spec{trigger} = sub { shift->$trigger_method(@_) };
1481 2         4 }
1482 2         4 if ($spec{is} eq 'rwp') {
1483 2         4 $spec{is} = 'ro';
1484             $spec{writer} = '_set_'.$attrname unless exists $spec{writer};
1485             }
1486 58 50       164 }
1487 0         0
1488 0 0 0     0 if (is_CodeRef $spec{coerce}) {
1489 0   0     0 $spec{isa} = $spec{isa}->no_coercions->plus_coercions(Types::Standard::Any, $spec{coerce});
1490             $spec{coerce} = !!1;
1491             }
1492 58 100 100     202
1493 7         27 if ( is_ScalarRef $spec{default} ) {
1494 7 50 33     54 require Ask::Question;
1495 7   33     29 my $text = ${ $spec{default} };
1496             $spec{default} = 'Ask::Question'->new( { text => $text } );
1497             }
1498 58 100       302
1499 8         32 if ( is_Object $spec{default} and $spec{default}->isa('Ask::Question') ) {
  8         116  
1500             my %spec_copy = %spec;
1501             my $default = delete $spec_copy{default};
1502 58 100 66     131171
    100          
1503 3         38 if ( $spec{isa} and not $default->has_type ) {
1504             $default->_set_type( $spec{isa} );
1505             }
1506 9   33     26 if ( not $default->has_spec ) {
1507 9         40 $default->_set_spec( \%spec_copy );
1508             }
1509             if ( not $default->has_title ) {
1510 58 100 100     3214 $default->_set_title( "$qname\::$attrname" );
      100        
1511 7         93 }
1512             }
1513            
1514 58 100       748 my $default_codulate = 0;
1515 23 50 66     99 # Mouse doesn't support overloaded objects as defaults.
      66        
1516 1         5 if ( $toolkit eq 'Mouse' and is_Object $spec{default} ) {
1517             $default_codulate = 1;
1518 23 100 66     55 }
1519 1         3 # Moose doesn't usually either
1520 1     2   5 elsif ( $toolkit eq 'Moose' and is_Object $spec{default} and not $spec{default}->isa('Class::MOP::Method') ) {
  2         1911  
1521             $default_codulate = 1;
1522 23 50       52 }
1523 0         0
1524 0 0       0 if ( $default_codulate ) {
1525             my $deref = eval { \&{ $spec{default} } };
1526             if ( is_CodeRef $deref ) {
1527             $spec{default} = $deref;
1528 58 100       195 }
1529 1         7 }
1530 1         645  
1531             if ($spec{lexical}) {
1532             require Lexical::Accessor;
1533 58 50       215 if ($spec{traits} || $spec{handles_via}) {
1534 0         0 'Lexical::Accessor'->VERSION('0.010');
1535 0         0 }
  0         0  
1536 0         0 my $la = 'Lexical::Accessor'->new_from_has(
1537             $attrname,
1538             package => $qname,
1539 58 50 33     198 %spec,
1540 0         0 );
1541 0         0 $la->install_accessors;
1542             }
1543 0 0 0     0 else
1544 0         0 {
1545             my ($shv_toolkit, $shv_data);
1546 0 0       0 my $lex = $builder->_pre_attribute($qname, $attrname, \%spec);
1547 0         0 if ($spec{handles_via}) {
1548             $shv_toolkit = "Sub::HandlesVia::Toolkit::$toolkit";
1549 0 0       0 use_module($shv_toolkit);
1550 0         0 $shv_data = $shv_toolkit->clean_spec($qname, $attrname, \%spec);
1551             }
1552             $builder->$installer($qname, $attrname, \%spec);
1553             $shv_toolkit->install_delegations($shv_data) if $shv_data;
1554 58         99 $builder->_post_attribute($qname, $attrname, \%spec, $lex) if $lex;
1555             }
1556 58 50 66     320 }
    50 66        
      33        
1557 0         0
1558             $meta->make_immutable if $make_immutable;
1559             return;
1560             }
1561 0         0  
1562             my ($builder, $target, $attrname, $spec) = @_;
1563             my %lex;
1564 58 50       119
1565 0         0 for my $thing (qw/ reader writer accessor clearer predicate /) {
  0         0  
  0         0  
1566 0 0       0 if (is_ScalarRef $spec->{$thing}) {
1567 0         0 my $rand = sprintf('__lexical_%d', 10_000_000 + int rand(89_000_000));
1568             $lex{$rand} = $spec->{$thing};
1569             $spec->{$thing} = $rand;
1570             }
1571 58 100       116 }
1572 2         419
1573 2 100 66     5636 if (is_ArrayRef $spec->{handles}) {
1574 1         17 my %new_handles;
1575             my @handles = @{$spec->{handles}};
1576 2         17 while (@handles) {
1577             my ($src, $dst) = splice @handles, 0, 2;
1578             if (is_ScalarRef $src) {
1579             my $rand = sprintf('__lexical_%d', 10_000_000 + int rand(89_000_000));
1580             $new_handles{$rand} = $dst;
1581 2         190 $lex{$rand} = $src;
1582             }
1583             else {
1584             $new_handles{$src} = $dst;
1585 56         81 }
1586 56         208 }
1587 56 100       149 $spec->{handles} = \%new_handles;
1588 5         9 }
1589 5         16
1590 5         23304 return unless keys %lex;
1591             \%lex;
1592 56         394 }
1593 56 100       290467  
1594 56 100       59209 my ($builder, $target, $attrname, $spec) = @_;
1595             my %lex = %{ +pop };
1596            
1597             foreach my $tmp (sort keys %lex) {
1598 37 50       46522 my $coderef = do { no strict 'refs'; \&{"$target\::$tmp"} };
1599 37         103 ${ $lex{$tmp} } = $coderef;
1600             'namespace::clean'->clean_subroutines($target, $tmp);
1601             }
1602             }
1603 56     58   131  
1604 56         69 my $builder = shift;
1605             my ($class, $attribute, $spec) = @_;
1606 56         110 my $helper = $builder->_get_moo_helper($class, 'has');
1607 280 100       726 if (is_Object($spec->{isa}) and $spec->{isa}->isa('Type::Tiny::Enum') and $spec->{handles}) {
1608 3         35 $builder->_process_enum_moo(@_);
1609 3         7 }
1610 3         6 $helper->($attribute, %$spec);
1611             }
1612              
1613             my $builder = shift;
1614 56 100       184 my ($class, $attribute, $spec) = @_;
1615 1         1 require MooX::Enumeration;
1616 1         1 my %new_spec = 'MooX::Enumeration'->process_spec($class, $attribute, %$spec);
  1         4  
1617 1         2 if (delete $new_spec{moox_enumeration_process_handles}) {
1618 3         5 'MooX::Enumeration'->install_delegates($class, $attribute, \%new_spec);
1619 3 100       9 }
1620 2         5 %$spec = %new_spec;
1621 2         4 }
1622 2         4  
1623             my $builder = shift;
1624             my ($class, $attribute, $spec) = @_;
1625 1         3 if (is_Object($spec->{isa}) and $spec->{isa}->isa('Type::Tiny::Enum')||$spec->{isa}->isa('Moose::Meta::TypeConstraint::Enum') and $spec->{handles}) {
1626             $builder->_process_enum_moose(@_);
1627             }
1628 1         2 require Moose::Util;
1629             (Moose::Util::find_meta($class) or $class->meta)->add_attribute($attribute, %$spec);
1630             }
1631 56 100       225  
1632 1         3 my $builder = shift;
1633             my ($class, $attribute, $spec) = @_;
1634             require MooseX::Enumeration;
1635             push @{ $spec->{traits}||=[] }, 'Enumeration';
1636 1     8   4 }
1637 1         2  
  1         5  
1638             my $builder = shift;
1639 1         5 my ($class, $attribute, $spec) = @_;
1640 40     40   275 if (is_Object($spec->{isa}) and $spec->{isa}->isa('Type::Tiny::Enum') and $spec->{handles}) {
  40         84  
  40         67174  
  5         264  
  5         5  
  5         14  
1641 5         6 $builder->_process_enum_mouse(@_);
  5         8  
1642 5         14 }
1643             require Mouse::Util;
1644             my %spec = %$spec;
1645             delete $spec{definition_context};
1646             (Mouse::Util::find_meta($class) or $class->meta)->add_attribute($attribute, %spec);
1647 33     33 0 54 }
1648 33         55  
1649 33         92 die 'not implemented';
1650 33 100 100     245 }
      100        
1651 1         13  
1652             my $builder = shift;
1653 33         383 my ($class, $isa) = @_;
1654             my $helper = $builder->_get_moo_helper($class, 'extends');
1655             $helper->(@$isa);
1656             }
1657 1     8   1  
1658 1         3 my $builder = shift;
1659 1         354 my ($class, $isa) = @_;
1660 1         1792
1661 1 50       58 PARENT: for my $parent ( @$isa ) {
1662 1         3 next PARENT if $parent->isa('Moose::Object');
1663             next PARENT if $parent->isa('Moo::Object');
1664 1         12105 use_module("MooseX::NonMoose")->import::into($class);
1665             last PARENT;
1666             }
1667            
1668 12     12 0 17 require Moose::Util;
1669 12         25 (Moose::Util::find_meta($class) or $class->meta)->superclasses(@$isa);
1670 12 50 66     81 }
      100        
      66        
1671 0         0  
1672             my $builder = shift;
1673 12         16583 my ($class, $isa) = @_;
1674 12   33     50
1675             PARENT: for my $parent ( @$isa ) {
1676             next PARENT if $parent->isa('Mouse::Object');
1677             use_module("MouseX::NonMoose")->import::into($class);
1678 0     0   0 last PARENT;
1679 0         0 }
1680 0         0
1681 0   0     0 require Mouse::Util;
  0         0  
1682             (Mouse::Util::find_meta($class) or $class->meta)->superclasses(@$isa);
1683             }
1684              
1685 11     17 0 13 my $builder = shift;
1686 11         17 my ($target, $symm) = @_;
1687 11 50 100     51
      66        
1688 0         0 my @symm = $symm->$_handle_list or return;
1689            
1690 11         137 require Sub::SymMethod;
1691 11         33
1692 11         13 while ( @symm ) {
1693 11   33     26 my $name = shift(@symm);
1694             my $spec = is_CodeRef($symm[0]) ? { code => shift(@symm) } : shift(@symm);
1695            
1696             if ( $spec->{signature} ) {
1697 0     6   0 my $signature_style = CodeRef->check($spec->{signature})
1698             ? 'code'
1699             : ($spec->{named} ? 'named' : 'positional');
1700             my $new_sig = $builder->_build_method_signature_check(
1701 46     52 0 68 $target,
1702 46         79 $name,
1703 46         105 $signature_style,
1704 46         120 $spec->{signature},
1705             exists($spec->{signature}) ? $spec->{signature} : 1,
1706             1,
1707             );
1708 18     24 0 27 $spec->{signature} = $new_sig;
1709 18         33 }
1710            
1711 18         32 'Sub::SymMethod'->install_symmethod( $target, $name, %$spec );
1712 18 50       80 }
1713 0 0       0 }
1714 0         0  
1715 0         0 my $builder = shift;
1716             my ($target, $kind, $method_name, $method_spec) = @_;
1717            
1718 18         69 HashRef->($method_spec);
1719 18   33     62 Ref->($method_spec->{signature});
1720             CodeRef->($method_spec->{code});
1721            
1722             my $signature_style = CodeRef->check($method_spec->{signature})
1723 18     18 0 22 ? 'code'
1724 18         26 : ($method_spec->{named} ? 'named' : 'positional');
1725            
1726 18         22 my $new_sig = $builder->_build_method_signature_check(
1727 18 50       75 $target,
1728 0         0 $method_name,
1729 0         0 $signature_style,
1730             $method_spec->{signature},
1731             undef,
1732 18         71 1,
1733 18   33     37 );
1734             $method_spec->{signature} = $new_sig;
1735              
1736             if ( match('coercion', $method_spec->{'attributes'}) or match('coerce', $method_spec->{'attributes'}) ) {
1737 10     10 0 19 my $to_type = $target->FACTORY->type_library->get_type_for_package( any => $target );
1738 10         18
1739             my @sigtypes = grep Scalar::Util::blessed($_), @{$method_spec->{signature}};
1740 10 50       24
1741             $builder->croak('Multimethods used as coercions must take exactly one positional argument')
1742 10         952 unless is_ArrayRef( $method_spec->{signature} ) && 1==@sigtypes && $signature_style eq 'positional';
1743            
1744 10         15820 $builder->croak("Too late to add coercion to $to_type")
1745 14         293 if $to_type->coercion->frozen;
1746 14 100       50
1747             my $from_type = 'Type::Registry'->for_class($target)->lookup( $sigtypes[0] );
1748 14 100       35
1749             my $code = $method_spec->{code};
1750             $to_type->coercion->add_type_coercions( $from_type, sub { $code->($target, $_) } );
1751 2 50       10 }
    50          
1752              
1753             require Sub::MultiMethod;
1754             'Sub::MultiMethod'->install_candidate($target, $method_name, no_dispatcher=>($kind eq 'role'), %$method_spec);
1755             }
1756              
1757 2 50       38 {
1758             my $_process_roles = sub {
1759             my ($builder, $r, $tk, $opts) = @_;
1760 2         6 map {
1761             my $role = $_;
1762             if ($role =~ /\?$/) {
1763 14         85 $role =~ s/\?$//;
1764             eval "require $role; 1" or do {
1765             $builder->make_role(make_absolute_package_name($role), %$opts, toolkit => $tk);
1766             };
1767             }
1768 10     10 0 20 $role;
1769 10         20 } @$r;
1770             };
1771 10         36
1772 10         1875 my $_maybe_do_multimethods = sub {
1773 10         1739 my $tk = 'Sub::MultiMethod';
1774             if ($tk->can('copy_package_candidates') and $tk->VERSION lt '0.901') {
1775             my ($target, $kind, @sources) = @_;
1776             $tk->copy_package_candidates(@sources => $target);
1777 10 50       1626 $tk->install_missing_dispatchers($target) unless $kind eq 'role';
    50          
1778             }
1779             return;
1780             };
1781            
1782             my $builder = shift;
1783             my ($class, $kind, $roles, $opts) = @_;
1784             my $helper = $builder->_get_moo_helper($class, 'with');
1785 10         175 my @roles = $builder->$_process_roles($roles, 'Moo', $opts);
1786             $helper->(@roles);
1787 10         19 $class->$_maybe_do_multimethods($kind, @roles) if $INC{'Sub/MultiMethod.pm'};
1788             }
1789 10 50 33     70  
1790 0         0 my $builder = shift;
1791             my ($class, $kind, $roles, $opts) = @_;
1792 0         0 require Moose::Util;
  0         0  
1793             my @roles = $builder->$_process_roles($roles, 'Moose', $opts);
1794             Moose::Util::ensure_all_roles($class, @roles);
1795 0 0 0     0 $class->$_maybe_do_multimethods($kind, @roles) if $INC{'Sub/MultiMethod.pm'};
      0        
1796             }
1797 0 0       0  
1798             my $builder = shift;
1799             my ($class, $kind, $roles, $opts) = @_;
1800 0         0 require Mouse::Util;
1801             my @roles = $builder->$_process_roles($roles, 'Mouse', $opts);
1802 0         0 # this can double-apply roles? :(
1803 0     0   0 Mouse::Util::apply_all_roles($class, @roles);
  0         0  
1804             $class->$_maybe_do_multimethods($kind, @roles) if $INC{'Sub/MultiMethod.pm'};
1805             }
1806 10         1174 }
1807 10         59921  
1808             my $builder = shift;
1809             my ($role, $methods) = @_;
1810             my $helper = $builder->_get_moo_helper($role, 'requires');
1811             $helper->(sort keys %$methods);
1812             }
1813              
1814             my $builder = shift;
1815             my ($role, $methods) = @_;
1816             require Moose::Util;
1817             (Moose::Util::find_meta($role) or $role->meta)->add_required_methods(sort keys %$methods);
1818             }
1819              
1820             my $builder = shift;
1821             my ($role, $methods) = @_;
1822             require Mouse::Util;
1823             (Mouse::Util::find_meta($role) or $role->meta)->add_required_methods(sort keys %$methods);
1824             }
1825              
1826             my $builder = shift;
1827             my %method = (@_==1) ? %{$_[0]} : @_;
1828             my $qname = delete($method{package}) || caller;
1829             $method{lexical} = !!1;
1830             my $return = $builder->install_methods($qname, { '__ANON__' => \%method });
1831             $return->{'__ANON__'};
1832             }
1833              
1834             my $builder = shift;
1835             my ($class, $methods) = @_;
1836 46     46 0 81 my %return;
1837 46         99
1838 46         127 my $to_type;
1839 46         140
1840 46         127 for my $name (sort keys %$methods) {
1841 46 100       171205 no strict 'refs';
1842             my ($code, $signature, $signature_style, $invocant_count, $is_coderef, $caller, $attrs, @curry, $ctx);
1843             $caller = $class;
1844            
1845 16     16 0 22 if (is_CodeRef($methods->{$name})) {
1846 16         31 $code = $methods->{$name};
1847 16         60 $signature_style = 'none';
1848 16         44 }
1849 16         55 elsif (is_HashRef($methods->{$name})) {
1850 16 50       48794 $attrs = $methods->{$name}{attributes};
1851             $code = $methods->{$name}{code};
1852             $signature = $methods->{$name}{signature};
1853             @curry = @{ $methods->{$name}{curry} || [] };
1854 16     16 0 19 $invocant_count = exists($methods->{$name}{invocant_count}) ? $methods->{$name}{invocant_count} : 1;
1855 16         25 $signature_style = is_CodeRef($signature)
1856 16         52 ? 'code'
1857 16         32 : ($methods->{$name}{named} ? 'named' : 'positional');
1858             $is_coderef = !!$methods->{$name}{lexical};
1859 16         41 $caller = $methods->{$name}{caller};
1860 16 50       15655 $ctx = $methods->{$name}{'definition_context'};
1861             }
1862            
1863             if ($signature) {
1864             CodeRef->assert_valid($signature) if $signature_style eq 'code';
1865 1     1 0 3 ArrayRef->assert_valid($signature) if $signature_style eq 'named';
1866 1         1 ArrayRef->assert_valid($signature) if $signature_style eq 'positional';
1867 1         3 };
1868 1         4
1869             my $optimized = 0;
1870             my $checkcode = '&$check';
1871             if ($signature and $methods->{$name}{optimize}) {
1872 0     0 0 0 if (my $r = $builder->_optimize_signature($class, "$class\::$name", $signature_style, $signature)) {
1873 0         0 $checkcode = $r;
1874 0         0 ++$optimized;
1875 0   0     0 }
1876             }
1877            
1878             my $callcode;
1879 0     0 0 0 if (is_CodeRef($code)) {
1880 0         0 $callcode = 'goto $code';
1881 0         0 }
1882 0   0     0 else {
1883             ($callcode = $code) =~ s/\A \s* sub \s* \{ (.+) \} \s* \z/$1/xs;
1884             $callcode = "package $caller; $callcode" if defined $caller;
1885             }
1886 1     1 0 451
1887 1 50       3 my $attrs_string = $is_coderef ? "" : ":method";
  1         4  
1888 1   33     5 $attrs_string .= " :lvalue" if match("lvalue", $attrs);
1889 1         2
1890 1         4 my $magic_comment = '';
1891 1         5 if ($ctx) {
1892             $magic_comment = sprintf("#line %d \"%s\"\n", $ctx->{line}, $ctx->{file});
1893             }
1894            
1895 105     105 1 174 no warnings 'printf';
1896 105         295 my $subcode = sprintf(
1897 105         154 q{%s} . # magic comment
1898             q{package %-49s} . # package name
1899             q{%-49s} . # my $check variable to close over
1900             q{sub %-49s} . # method name
1901 105         356 q[{] .
1902 40     40   268 q{%-49s} . # strip @invocants from @_ if necessary
  40         66  
  40         11736  
1903 208         307 q{%-49s} . # build $check
1904 208         257 q{%-49s} . # reassemble @_ from @invocants, @curry, and &$check
1905             q{%-49s} . # run sub code
1906 208 100       593 q[};] .
    50          
1907 169         215 q[%s] # 1;
1908 169         212 ,
1909             $magic_comment,
1910             "$class;",
1911 39         71 (($signature && !$optimized)
1912 39         54 ? 'my $check;'
1913 39         57 : ''),
1914 39 100       48 ($is_coderef ? $attrs_string : "$name $attrs_string"),
  39         142  
1915 39 100       91 ($signature
1916             ? sprintf('my @invocants = splice(@_, 0, %d);', $invocant_count)
1917             : ''),
1918 39 100       127 (($signature && !$optimized)
    100          
1919 39         65 ? sprintf('$check ||= %s->_build_method_signature_check(%s, %s, %s, $signature, \\@invocants);', map(B::perlstring($_), $builder, $class, "$class\::$name", $signature_style))
1920 39         56 : ''),
1921 39         55 ($signature
1922             ? (@curry ? sprintf('@_ = (@invocants, @curry, %s);', $checkcode) : sprintf('@_ = (@invocants, %s);', $checkcode))
1923             : (@curry ? sprintf('splice(@_, %d, 0, @curry);', $invocant_count) : '')),
1924 208 100       329 $callcode,
1925 6 100       18 ($is_coderef ? '' : '1;'),
1926 6 100       22 );
1927 6 100       30
1928             no warnings 'closure';
1929             ($return{$name} = eval($subcode))
1930 208         280 or $builder->croak("Could not create method $name in package $class: $@");
1931 208         244
1932 208 100 100     352 if ( match('coercion', $attrs) or match('coerce', $attrs) ) {
1933 2 50       8 my @sigtypes = grep !is_HashRef($_), @$signature;
1934 2         4
1935 2         3 $to_type ||= $class->FACTORY->type_library->get_type_for_package( any => $class );
1936            
1937             $builder->croak('Methods used as coercions must take exactly one positional argument')
1938             unless is_ArrayRef( $signature ) && 1==@sigtypes && $signature_style eq 'positional';
1939 208         202
1940 208 100       407 $builder->croak("Too late to add coercion to $to_type")
1941 203         222 if $to_type->coercion->frozen;
1942            
1943             my $from_type = 'Type::Registry'->for_class($class)->lookup( $sigtypes[0] );
1944 5         30
1945 5 100       13 $to_type->coercion->add_type_coercions(
1946             $from_type, sprintf('%s->%s($_)', B::perlstring($class), $name),
1947             );
1948 208 100       336 }
1949 208 100       471 }
1950             \%return;
1951 208         240 }
1952 208 100       318  
1953 21         82 my $builder = shift;
1954             my ($method_class, $method_name, $signature_style, $signature) = @_;
1955            
1956 40     40   240 $signature_style ||= 'none' if !$signature;
  40         64  
  40         6426  
1957 208 100 100     1932
    100 100        
    100          
    100          
    100          
    100          
    100          
    100          
1958             return if $signature_style eq 'none';
1959             return if $signature_style eq 'code';
1960            
1961             my @sig = @$signature;
1962             require Type::Params;
1963             my $global_opts = {};
1964             $global_opts = shift(@sig) if is_HashRef($sig[0]) && !$sig[0]{slurpy};
1965             $global_opts->{want_details} = 1;
1966            
1967             my $details = $builder->_build_method_signature_check($method_class, $method_name, $signature_style, [$global_opts, @sig]);
1968             return if keys %{$details->{environment}};
1969             return if $details->{source} =~ /return/;
1970            
1971             $details->{source} =~ /^sub \{(.+)\};$/s or return;
1972             return "do { $1 }";
1973             }
1974              
1975             # need to partially parse stuff for Type::Params to look up type names
1976             my $builder = shift;
1977             my ($method_class, $method_name, $signature_style, $signature, $invocants, $gimme_list) = @_;
1978             my $type_library;
1979            
1980             $signature_style ||= 'none' if !$signature;
1981            
1982             return sub { @_ } if $signature_style eq 'none';
1983             return $signature if $signature_style eq 'code';
1984             my @sig = @$signature;
1985            
1986             require Type::Params;
1987            
1988             my $global_opts = {};
1989 40     40   303 $global_opts = shift(@sig) if is_HashRef($sig[0]) && !$sig[0]{slurpy};
  40         123  
  40         36119  
1990 208 50   27 0 11435
  27     18 0 22142  
  14     1 0 6986  
  3         2813  
1991             $global_opts->{subname} ||= $method_name;
1992            
1993 208 50 33     1340 my $is_named = ($signature_style eq 'named');
1994 0         0 my @params;
1995            
1996 0   0     0 my $reg;
1997            
1998 0 0 0     0 while (@sig) {
      0        
1999             if (is_HashRef($sig[0]) and $sig[0]{slurpy}) {
2000             push @params, shift @sig;
2001 0 0       0 # die "lolwut? after slurpy? you srs?" if @sig;
2002             }
2003            
2004 0         0 my ($name, $type, $opts) = (undef, undef, {});
2005             if ($is_named) {
2006 0         0 ($name, $type) = splice(@sig, 0, 2);
2007             }
2008             else {
2009             $type = shift(@sig);
2010             }
2011 105         273 if (is_HashRef($sig[0]) && !ref($sig[0]{slurpy})) {
2012             $opts = shift(@sig);
2013             }
2014            
2015 23     21   5405 # All that work, just to do this!!!
2016 28         7920 if (is_Str($type) and not $type =~ /^[01]$/) {
2017             $reg ||= do {
2018 12 50 100     20970 require Type::Registry;
2019             'Type::Registry'->for_class($method_class);
2020 8 100       911 };
2021 4 50       37
2022             if ($type =~ /^\%/) {
2023 6         14 $type = HashRef->of(
2024 6         849 $reg->lookup(substr($type, 1))
2025 6         14051 );
2026 6 50 100     15 }
2027 6         13 elsif ($type =~ /^\@/) {
2028             $type = ArrayRef->of(
2029 5         16 $reg->lookup(substr($type, 1))
2030 5 100       4804 );
  4         12  
2031 5 100       36 }
2032             else {
2033 5 50       17 $type = $reg->lookup($type);
2034 5         48 }
2035             }
2036            
2037             my $hide_opts = 0;
2038             if ($opts->{slurpy} && !ref($opts->{slurpy})) {
2039 22     39   1641 delete $opts->{slurpy};
2040 22         55 $type = { slurpy => $type };
2041 22         28 $hide_opts = 1;
2042             }
2043 22 100 33     55
2044             push(
2045 22 50   5   53 @params,
  2         60  
2046 21 100       6364 $is_named
2047 20         49 ? ($name, $type, $hide_opts?():($opts))
2048             : ( $type, $hide_opts?():($opts))
2049 20         3045 );
2050             }
2051 20         44955
2052 20 100 66     93 for my $position (qw( head tail )) {
2053             if (ref $global_opts->{$position}) {
2054 19   33     98 require Type::Params;
2055             'Type::Params'->VERSION(1.009002);
2056 19         32 $reg ||= do {
2057 19         30 require Type::Registry;
2058             'Type::Registry'->for_class($method_class);
2059             };
2060             $global_opts->{$position} = [map {
2061 19         39 my $type = $_;
2062 28 0 33     73 if (ref $type) {
2063 0         0 $type;
2064             }
2065             elsif ($type =~ /^\%/) {
2066             HashRef->of(
2067 28         52 $reg->lookup(substr($type, 1))
2068 28 100       50 );
2069 5         12 }
2070             elsif ($type =~ /^\@/) {
2071             ArrayRef->of(
2072 23         31 $reg->lookup(substr($type, 1))
2073             );
2074 28 50 33     96 }
2075 0         0 else {
2076             $reg->lookup($type);
2077             }
2078             } @{$global_opts->{$position}} ];
2079 28 100 66     115 }
2080 15   66     47 }
2081 12         47
2082 12         59 my $next = $is_named ? \&Type::Params::compile_named_oo : \&Type::Params::compile;
2083             @_ = ($global_opts, @params);
2084             return [@_] if $gimme_list;
2085 15 50       125 goto($next);
    50          
2086 0         0 }
2087              
2088             my $builder = shift;
2089             my ($class, $methods) = @_;
2090             for my $name (sort keys %$methods) {
2091 0         0 no strict 'refs';
2092             my $value = $methods->{$name};
2093             if (defined $value && !ref $value) {
2094             require B;
2095             my $stringy = B::perlstring($value);
2096 15         45 eval "package $class; sub $name () { $stringy }; 1"
2097             or $builder->croak("Could not create constant $name in package $class: $@");
2098             }
2099             else {
2100 28         1251 eval "package $class; sub $name () { \$value }; 1"
2101 28 50 33     71 or $builder->croak("Could not create constant $name in package $class: $@");
2102 0         0 }
2103 0         0 }
2104 0         0 }
2105              
2106             my ($builder, $class, $kind, $names, $method) = @_;
2107             return $method if is_CodeRef $method;
2108 28 50       102
    50          
    100          
2109             my $coderef = $method->{code};
2110             my $signature = $method->{signature};
2111             my @curry = @{ $method->{curry} || [] };
2112             my $signature_style = $method->{named} ? 'named' : 'positional';
2113            
2114             return $coderef unless $signature || @curry;
2115 19         41 $signature ||= sub { @_ };
2116 38 50       86
2117 0         0 my $invocant_count = 1 + !!($kind eq 'around');
2118 0         0 $invocant_count = $method->{invocant_count} if exists $method->{invocant_count};
2119 0   0     0
2120 0         0 my $name = join('|', @$names)."($kind)";
2121 0         0
2122             no warnings 'closure';
2123             my $wrapped = eval qq{
2124 0         0 my \$check;
2125 0 0       0 sub {
    0          
    0          
2126 0         0 my \@invocants = splice(\@_, 0, $invocant_count);
2127             \$check ||= q($builder)->_build_method_signature_check(q($class), q($class\::$name), \$signature_style, \$signature, \\\@invocants);
2128             \@_ = (\@invocants, \@curry, \&\$check);
2129 0         0 goto \$coderef;
2130             };
2131             };
2132             $wrapped or die("YIKES: $@");
2133             }
2134 0         0  
2135             my $builder = shift;
2136             my ($class, $modifier, $method_names, $coderef) = @_;
2137             my $helper = $builder->_get_moo_helper($class, $modifier);
2138             $helper->(@$method_names, $coderef);
2139 0         0 }
2140              
2141 0         0 my $builder = shift;
  0         0  
2142             my ($class, $modifier, $method_names, $coderef) = @_;
2143             my $m = "add_$modifier\_method_modifier";
2144             require Moose::Util;
2145 19 100       48 my $meta = Moose::Util::find_meta($class) || $class->meta;
2146 19         46 for my $method_name (@$method_names) {
2147 19 100       60 $meta->$m($method_name, $coderef);
2148 7         25 }
2149             }
2150              
2151             my $builder = shift;
2152 10     10 1 18 my ($class, $modifier, $method_names, $coderef) = @_;
2153 10         17 my $m = "add_$modifier\_method_modifier";
2154 10         33 require Mouse::Util;
2155 40     40   252 my $meta = (Mouse::Util::find_meta($class) or $class->meta);
  40         57  
  40         9769  
2156 15         27 for my $method_name (@$method_names) {
2157 15 50 33     53 $meta->$m($method_name, $coderef);
2158 15         52 }
2159 15         43 }
2160 15 50       808  
2161             1;
2162              
2163              
2164 0 0       0 =pod
2165              
2166             =encoding utf-8
2167              
2168             =head1 NAME
2169              
2170             MooX::Press - quickly create a bunch of Moo/Moose/Mouse classes and roles
2171 24     24   52  
2172 24 100       164 =head1 SYNOPSIS
2173              
2174 2         4 package MyApp;
2175 2         2 use Types::Standard qw(Str Num);
2176 2 50       3 use MooX::Press (
  2         6  
2177 2 50       5 role => [
2178             'Livestock',
2179 2 50 33     4 'Pet',
2180 2   50 0   3 'Milkable' => {
  0         0  
2181             can => [
2182 2         5 'milk' => sub { print "giving milk\n"; },
2183 2 50       3 ],
2184             },
2185 2         5 ],
2186             class => [
2187 40     40   241 'Animal' => {
  40         74  
  40         11458  
2188 2         222 has => [
2189             'name' => Str,
2190             'colour',
2191             'age' => Num,
2192             'status' => { enum => ['alive', 'dead'], default => 'alive' },
2193             ],
2194             subclass => [
2195             'Panda',
2196             'Cat' => { with => ['Pet'] },
2197 2 50       8 'Dog' => { with => ['Pet'] },
2198             'Cow' => { with => ['Livestock', 'Milkable'] },
2199             'Pig' => { with => ['Livestock'] },
2200             ],
2201 8     8 0 11 },
2202 8         25 ],
2203 8         15 );
2204 8         20  
2205             Using your classes:
2206              
2207             use MyApp;
2208 6     6 0 9
2209 6         9 my $kitty = MyApp->new_cat(name => "Grey", status => "alive");
2210 6         11 # or: MyApp::Cat->new(name => "Grey", status => "alive");
2211 6         21
2212 6   33     18 MyApp->new_cow(name => "Daisy")->milk();
2213 6         52  
2214 8         204 I realize this is a longer synopsis than most CPAN modules give, but
2215             considering it sets up six classes and three roles with some attributes
2216             and methods, applies the roles to the classes, and creates a type library
2217             with nine types in it, it's pretty concise.
2218              
2219 6     6 0 7 =head1 DESCRIPTION
2220 6         9  
2221 6         8 L<MooX::Press> (pronounced "Moo Express") is a quick way of creating a bunch
2222 6         20 of simple Moo classes and roles at once without needing to create separate
2223 6   33     13 Perl modules for each class and each role, and without needing to add a bunch
2224 6         49 of boilerplate to each file.
2225 8         49  
2226             It also supports Moose and Mouse, though Moo classes and roles play nicely
2227             with Moose (and to a certain extent with Mouse) anyway.
2228              
2229             =head2 Import Options
2230              
2231             MooX::Press is called like:
2232              
2233             use MooX::Press %import_opts;
2234              
2235             The following options are supported. To make these easier to remember, options
2236             follow the convention of using lower-case singular, and reusing keywords from
2237             Perl and Moo/Moose/Mouse when possible.
2238              
2239             =over
2240              
2241             =item C<< class >> I<< (OptList) >>
2242              
2243             This is the list of classes to create as an optlist. An optlist is an arrayref
2244             of strings, where each string is optionally followed by a reference.
2245              
2246             [ "A", "B", "C", \%opt_for_C, "D", "E", \%opts_for_E, "F" ]
2247              
2248             In particular, for the class optlist the references should be hashrefs of
2249             class options (see L</Class Options>), though key-value pair arrayrefs are
2250             also accepted.
2251              
2252             =item C<< role >> I<< (OptList) >>
2253              
2254             This is the list of roles to create, structured almost the same as the optlist
2255             for classes, but see L</Role Options>.
2256              
2257             =item C<< class_generator >> I<< (OptList) >>
2258              
2259             Kind of like C<class>, but:
2260              
2261             [ "A", \&generator_for_A, "B", \&generator_for_B, ... ]
2262              
2263             "A" and "B" are not classes, but when C<< MyApp->generate_a(...) >>
2264             is called, it will pass arguments to C<< &generator_for_A >> which is expected
2265             to return a hashref like C<< \%opts_for_A >>. Then a new pseudononymous class
2266             will be created with those options.
2267              
2268             See the FAQ for an example.
2269              
2270             =item C<< role_generator >> I<< (OptList) >>
2271              
2272             The same but for roles.
2273              
2274             See the FAQ for an example.
2275              
2276             =item C<< toolkit >> I<< (Str) >>
2277              
2278             The strings "Moo", "Moose", or "Mouse" are accepted and instruct MooX::Press
2279             to use your favourite OO toolkit. "Moo" is the default.
2280              
2281             =item C<< version >> I<< (Num) >>
2282              
2283             This has nothing to do with the version of MooX::Press you are using.
2284             It sets the C<< our $VERSION >> variable for the classes and roles being
2285             generated.
2286              
2287             =item C<< authority >> I<< (Str) >>
2288              
2289             This sets the C<< our $AUTHORITY >> variable for the classes and roles being
2290             generated.
2291              
2292             C<version> and C<authority> will be copied from the caller if they are not set,
2293             but you can set them to undef explicitly if you want to avoid that.
2294              
2295             =item C<< prefix >> I<< (Str|Undef) >>
2296              
2297             A namespace prefix for MooX::Press to put all your classes into. If MooX::Press
2298             is told to create a class "Animal" and C<prefix> is set to "MyApp::OO", then
2299             it will create a class called "MyApp::OO::Animal".
2300              
2301             This is optional and defaults to the caller. If you wish to have no prefix,
2302             then pass an explicit C<< prefix => undef >> option. (If the caller is
2303             C<main>, then the prefix defaults to undef.)
2304              
2305             You can bypass the prefix for a specific class or a specific role using a
2306             leading double colon, like "::Animal" (or "main::Animal").
2307              
2308             =item C<< factory_package >> I<< (Str|Undef) >>
2309              
2310             A package name to install methods like the C<new_cat> and C<new_cow> methods
2311             in L</SYNOPSIS>.
2312              
2313             This defaults to prefix if the prefix is defined, and "Local" otherwise, but
2314             may be explicitly set to undef to suppress the creation of such methods. If
2315             the factory_package is "Local", you'll get a warning, except in C<< perl -e >>
2316             one-liners.
2317              
2318             In every class (but not role) that MooX::Press builds, there will be a
2319             C<FACTORY> method created so that, for example
2320              
2321             MyApp::Cow->FACTORY # returns "MyApp"
2322              
2323             The factory package will also have a method called C<qualify> installed,
2324             which uses the same logic as MooX::Press to add prefixes to class/role
2325             names.
2326              
2327             MyApp::Cow->FACTORY->qualify('Pig') # 'MyApp::Pig'
2328             MyApp::Cow->FACTORY->qualify('::Pig') # 'Pig'
2329              
2330             There will also be C<get_role> and C<get_class> methods:
2331              
2332             my $Clever = MyApp->get_role( 'Clever' );
2333             my $Brave = MyApp->get_role( 'Brave' );
2334             my $Pig = MyApp->get_class( 'Pig', $Clever, $Brave );
2335             my $wilbur = $Pig->new( name => 'Wilbur' );
2336              
2337             Class generators and role generators are also allowed; just follow the name
2338             with an arrayref of parameters.
2339              
2340             The factory package will have a global variable C<< %PACKAGES >> where the
2341             keys are names of all the packages MooX::Press created for you, and the values
2342             are what kind of package they are:
2343              
2344             say $MyApp::PACKAGES{"MyApp::Cow"}; # 'class'
2345              
2346             =item C<< type_library >> I<< (Str|Undef) >>
2347              
2348             MooX::Press will automatically create a L<Type::Library>-based type library
2349             with type constraints for all your classes and roles. It will be named using
2350             your prefix followed by "::Types".
2351              
2352             You can specify a new name or explicitly set to undef to suppress this
2353             behaviour, but a lot of the coercion features of MooX::Press rely on there
2354             being a type library.
2355              
2356             MooX::Press will create a get_type_for_package method that allows you to
2357             do this:
2358              
2359             MyApp::Types->get_type_for_package(class => "MyApp::Animal")
2360              
2361             MooX::Press will mark "MyApp/Types.pm" as loaded in %INC, so you can do
2362             things like:
2363              
2364             use MyApp::Types qw(Animal);
2365              
2366             And it won't complain about "MyApp/Types.pm" not being found.
2367              
2368             MooX::Press will install a C<type_library> method into the factory package
2369             which returns the name of the type library, so you can do:
2370              
2371             MyApp->type_library->get_type_for_package(class => "MyApp::Animal")
2372              
2373             =item C<< caller >> I<< (Str) >>
2374              
2375             MooX::Press determines some things based on which package called it. If you
2376             are wrapping MooX::Press, you can fake the caller by passing it as an option.
2377              
2378             =item C<< end >> I<< (CodeRef|ArrayRef[CodeRef]) >>
2379              
2380             After creating each class or role, this coderef will be called. It will be
2381             passed two parameters; the fully-qualified package name of the class or role,
2382             plus the string "class" or "role" as appropriate.
2383              
2384             Optional; defaults to nothing.
2385              
2386             =item C<< begin >> I<< (CodeRef|ArrayRef[CodeRef]) >>
2387              
2388             Like C<end>, but called before setting up any attributes, methods, or
2389             method modifiers. (But after loading Moo/Moose/Mouse.)
2390              
2391             Optional; defaults to nothing.
2392              
2393             =item C<< mutable >> I<< (Bool) >>
2394              
2395             Boolean to indicate that classes should be left mutable after creating them
2396             rather than making them immutable. Constructors for mutable classes are
2397             considerably slower than for immutable classes, so this is usually a bad
2398             idea.
2399              
2400             Only supported for Moose. Unnecessary for Moo anyway. Defaults to false.
2401              
2402             =item C<< factory_package_can >> I<< (HashRef[CodeRef]) >>
2403              
2404             Hashref of additional subs to install into the factory package.
2405              
2406             =item C<< type_library_can >> I<< (HashRef[CodeRef]) >>
2407              
2408             Hashref of additional subs to install into the type library package.
2409              
2410             =item C<< default_is >>
2411              
2412             The default for the C<is> option when defining attributes. The default
2413             C<default_is> is "ro".
2414              
2415             =back
2416              
2417             At this top level, a shortcut is available for the 'class' and 'role' keys.
2418             Rather than:
2419              
2420             use MooX::Press (
2421             role => [
2422             'Quux',
2423             'Quuux' => { ... },
2424             ],
2425             class => [
2426             'Foo',
2427             'Bar' => { ... },
2428             'Baz' => { ... },
2429             ],
2430             );
2431              
2432             It is possible to write:
2433              
2434             use MooX::Press (
2435             'role:Quux' => {},
2436             'role:Quuux' => { ... },
2437             'class:Foo' => {},
2438             'class:Bar' => { ... },
2439             'class:Baz' => { ... },
2440             );
2441              
2442             This saves a level of indentation. (C<< => undef >> or C<< => 1 >> are
2443             supported as synonyms for C<< => {} >>.)
2444              
2445             The C<can>, C<before>, C<after>, C<around>, C<multimethod>, C<symmethod>,
2446             C<constant>, C<with>, and C<extends> options documented under Class Options
2447             can also be used as top-level import options to apply them to the factory
2448             package.
2449              
2450             =head3 Class Options
2451              
2452             Each class in the list of classes can be followed by a hashref of
2453             options:
2454              
2455             use MooX::Press (
2456             class => [
2457             'Foo' => \%options_for_foo,
2458             'Bar' => \%options_for_bar,
2459             ],
2460             );
2461              
2462             The following class options are supported.
2463              
2464             =over
2465              
2466             =item C<< extends >> I<< (Str|ArrayRef[Str]) >>
2467              
2468             The parent class for this class.
2469              
2470             The prefix is automatically added. Include a leading "::" if you
2471             don't want the prefix to be added.
2472              
2473             Multiple inheritance is supported.
2474              
2475             If you are using Moose to extend a non-Moose class, MooseX::NonMoose
2476             will load automatically. (This also happens with MouseX::Foreign.)
2477              
2478             =item C<< with >> I<< (ArrayRef[Str]) >>
2479              
2480             Roles for this class to consume.
2481              
2482             The prefix is automatically added. Include a leading "::" if you don't
2483             want the prefix to be added.
2484              
2485             Roles may include a trailing "?". When these are seen, the role will be
2486             created if it doesn't seem to exist. This is because sometimes it's useful
2487             to have roles to classify classes (and check them with the C<does> method)
2488             even if those roles don't have any other functionality.
2489              
2490             use MooX::Press (
2491             prefix => 'Farm',
2492             class => [
2493             'Sheep' => { with => ['Bleat?'] },
2494             ],
2495             );
2496            
2497             if (Farm::Sheep->new->does('Farm::Bleat')) {
2498             ...;
2499             }
2500              
2501             Without the "?", trying to compose a role that does not exist is an error.
2502              
2503             =item C<< has >> I<< (OptList) >>
2504              
2505             The list of attributes to add to the class as an optlist.
2506              
2507             The strings are the names of the attributes, but these strings may be
2508             "decorated" with sigils and suffixes:
2509              
2510             =over
2511              
2512             =item C<< $foo >>
2513              
2514             Creates an attribute "foo" intended to hold a single value.
2515             This adds a type constraint forbidding arrayrefs and hashrefs
2516             but allowing any other value, including undef, strings, numbers,
2517             and any other reference.
2518              
2519             =item C<< @foo >>
2520              
2521             Creates an attribute "foo" intended to hold a list of values.
2522             This adds a type constraint allowing arrayrefs or objects
2523             overloading C<< @{} >>.
2524              
2525             =item C<< %foo >>
2526              
2527             Creates an attribute "foo" intended to hold a collection of key-value
2528             pairs. This adds a type constraint allowing hashrefs or objects
2529             overloading C<< %{} >>.
2530              
2531             =item C<< foo! >>
2532              
2533             Creates an attribute "foo" which will be required by the constructor.
2534              
2535             =back
2536              
2537             An attribute can have both a sigil and a suffix.
2538              
2539             The references in the optlist may be attribute specification hashrefs,
2540             type constraint objects, or builder coderefs.
2541              
2542             # These mean the same thing...
2543             "name!" => Str,
2544             "name" => { is => "ro", required => 1, isa => Str },
2545              
2546             # These mean the same thing...
2547             "age" => sub { return 0 },
2548             "age" => {
2549             is => "ro",
2550             lazy => 1,
2551             builder => sub { return 0 },
2552             clearer => "clear_age",
2553             },
2554              
2555             Type constraints can be any blessed object supported by the toolkit. For
2556             Moo, use L<Type::Tiny>. For Moose, use L<Type::Tiny>, L<MooseX::Types>,
2557             or L<Specio>. For Mouse, use L<Type::Tiny> or L<MouseX::Types>.
2558              
2559             Builder coderefs are automatically installed as methods like
2560             "YourPrefix::YourClass::_build_age()".
2561              
2562             For details of the hashrefs, see L</Attribute Specifications>.
2563              
2564             =item C<< can >> I<< (HashRef[CodeRef|HashRef]) >>
2565              
2566             A hashref of coderefs to install into the package.
2567              
2568             package MyApp;
2569             use MooX::Press (
2570             class => [
2571             'Foo' => {
2572             can => {
2573             'bar' => sub { print "in bar" },
2574             },
2575             },
2576             ],
2577             );
2578            
2579             package main;
2580             MyApp->new_foo()->bar();
2581              
2582             As an alternative, you can do this to prevent your import from getting
2583             cluttered with coderefs. Which you choose depends a lot on stylistic
2584             preference.
2585              
2586             package MyApp;
2587             use MooX::Press (
2588             class => ['Foo'],
2589             );
2590            
2591             package MyApp::Foo;
2592             sub bar { print "in bar" },
2593            
2594             package main;
2595             MyApp->new_foo()->bar();
2596              
2597             =item C<< multimethod >> I<< (ArrayRef) >>
2598              
2599             An arrayref of name-spec pairs suitable for passing to
2600             L<Sub::MultiMethod>.
2601              
2602             package MyApp;
2603             use MooX::Press (
2604             class => [
2605             'Foo' => {
2606             multimethod => [
2607             'bar' => {
2608             signature => [ 'HashRef' ],
2609             code => sub { my ($self, $hash) = @_; ... },
2610             },
2611             'bar' => {
2612             signature => [ 'ArrayRef' ],
2613             code => sub { my ($self, $array) = @_; ... },
2614             },
2615             ],
2616             },
2617             ],
2618             );
2619              
2620             =item C<< symmethod >> I<< (ArrayRef) >>
2621              
2622             An arrayref of name-spec pairs suitable for passing to
2623             L<Sub::SymMethod>.
2624              
2625             =item C<< multifactory >> I<< (ArrayRef) >>
2626              
2627             Similar to C<multimethod> but the methods are created in the factory
2628             package.
2629              
2630             package MyApp;
2631             use MooX::Press (
2632             class => [
2633             'Foo' => {
2634             multifactory => [
2635             'new_foo' => {
2636             signature => [ 'HashRef' ],
2637             code => sub { my ($factory, $class, $hash) = @_; ... },
2638             },
2639             'new_foo' => {
2640             signature => [ 'ArrayRef' ],
2641             code => sub { my ($factory, $class, $array) = @_; ... },
2642             },
2643             ],
2644             },
2645             ],
2646             );
2647            
2648             my $obj1 = 'MyApp'->new_foo( {} );
2649             my $obj2 = 'MyApp'->new_foo( [] );
2650              
2651             =item C<< constant >> I<< (HashRef[Item]) >>
2652              
2653             A hashref of scalar constants to define in the package.
2654              
2655             package MyApp;
2656             use MooX::Press (
2657             class => [
2658             'Foo' => {
2659             constant => {
2660             'BAR' => 42,
2661             },
2662             },
2663             ],
2664             );
2665            
2666             package main;
2667             print MyApp::Foo::BAR, "\n";
2668             print MyApp->new_foo->BAR, "\n";
2669              
2670             =item C<< around >> I<< (ArrayRef|HashRef) >>
2671              
2672             =item C<< before >> I<< (ArrayRef|HashRef) >>
2673              
2674             =item C<< after >> I<< (ArrayRef|HashRef) >>
2675              
2676             Installs method modifiers.
2677              
2678             package MyApp;
2679             use MooX::Press (
2680             role => [
2681             'Loud' => {
2682             around => [
2683             'greeting' => sub {
2684             my $orig = shift;
2685             my $self = shift;
2686             return uc( $self->$orig(@_) );
2687             },
2688             ],
2689             }
2690             ],
2691             class => [
2692             'Person' => {
2693             can => {
2694             'greeting' => sub { "hello" },
2695             }
2696             subclass => [
2697             'LoudPerson' => { with => 'Loud' },
2698             ],
2699             },
2700             ],
2701             );
2702            
2703             package main;
2704             print MyApp::LoudPerson->new->greeting, "\n"; # prints "HELLO"
2705              
2706             =item C<< coerce >> I<< (ArrayRef) >>
2707              
2708             When creating a class or role "Foo", MooX::Press will also create a
2709             L<Type::Tiny::Class> or L<Type::Tiny::Role> called "Foo". The C<coerce>
2710             option allows you to add coercions to that type constraint. Coercions
2711             are called as methods on the class or role. This is perhaps best
2712             explained with an example:
2713              
2714             package MyApp;
2715             use Types::Standard qw(Str);
2716             use MooX::Press (
2717             class => [
2718             'Person' => {
2719             has => [ 'name!' => Str ],
2720             can => {
2721             'from_name' => sub {
2722             my ($class, $name) = @_;
2723             return $class->new(name => $name);
2724             },
2725             },
2726             coerce => [
2727             Str, 'from_name',
2728             ],
2729             },
2730             'Company' => {
2731             has => [ 'name!' => Str, 'owner!' => { isa => 'Person' } ],
2732             },
2733             ],
2734             );
2735              
2736             This looks simple but it's like the swan, graceful above the surface of the
2737             water, legs paddling frantically below.
2738              
2739             It creates a class called "MyApp::Person" with a "name" attribute, so you can
2740             do this kind of thing:
2741              
2742             my $bob = MyApp::Person->new(name => "Bob");
2743             my $bob = MyApp->new_person(name => "Bob");
2744              
2745             As you can see from the C<can> option, it also creates a method "from_name"
2746             which can be used like this:
2747              
2748             my $bob = MyApp::Person->from_name("Bob");
2749              
2750             But here's where coercions come in. It also creates a type constraint
2751             called "Person" in "MyApp::Types" and adds a coercion from the C<Str> type.
2752             The coercion will just call the "from_name" method.
2753              
2754             Then when the "MyApp::Company" class is created and the "owner" attribute
2755             is being set up, MooX::Press knows about the coercion from Str, and will
2756             set up coercion for that attribute.
2757              
2758             # So this should just work...
2759             my $acme = MyApp->new_company(name => "Acme Inc", owner => "Bob");
2760             print $acme->owner->name, "\n";
2761              
2762             Now that's out of the way, the exact structure for the arrayref of coercions
2763             can be explained. It is essentially a list of type-method pairs.
2764              
2765             The type may be either a blessed type constraint object (L<Type::Tiny>, etc)
2766             or it may be a string type name for something that your type library knows
2767             about.
2768              
2769             The method is a string containing the method name to perform the coercion.
2770              
2771             This may optionally be followed by coderef to install as the method. The
2772             following two examples are equivalent:
2773              
2774             use MooX::Press (
2775             class => [
2776             'Person' => {
2777             has => [ 'name!' => Str ],
2778             can => {
2779             'from_name' => sub {
2780             my ($class, $name) = @_;
2781             return $class->new(name => $name);
2782             },
2783             },
2784             coerce => [
2785             Str, 'from_name',
2786             ],
2787             },
2788             ],
2789             );
2790              
2791             use MooX::Press (
2792             class => [
2793             'Person' => {
2794             has => [ 'name!' => Str ],
2795             coerce => [
2796             Str, 'from_name' => sub {
2797             my ($class, $name) = @_;
2798             return $class->new(name => $name);
2799             },
2800             ],
2801             },
2802             ],
2803             );
2804              
2805             In the second example, you can see the C<can> option to install the "from_name"
2806             method has been dropped and the coderef put into C<coerce> instead.
2807              
2808             In case it's not obvious, I suppose it's worth explicitly stating that it's
2809             possible to have coercions from many different types.
2810              
2811             use MooX::Press (
2812             class => [
2813             'Foo::Bar' => {
2814             coerce => [
2815             Str, 'from_string', sub { ... },
2816             ArrayRef, 'from_array', sub { ... },
2817             HashRef, 'from_hash', sub { ... },
2818             'FBaz', 'from_foobaz', sub { ... },
2819             ],
2820             },
2821             'Foo::Baz' => {
2822             type_name => 'FBaz',
2823             },
2824             ],
2825             );
2826              
2827             You should generally order the coercions from most specific to least
2828             specific. If you list "Num" before "Int", "Int" will never be used
2829             because all integers are numbers.
2830              
2831             There is no automatic inheritance for coercions because that does not make
2832             sense. If C<< Mammal->from_string($str) >> is a coercion returning a
2833             "Mammal" object, and "Person" is a subclass of "Mammal", then there's
2834             no way for MooX::Press to ensure that when C<< Person->from_string($str) >>
2835             is called, it will return a "Person" object and not some other kind of
2836             mammal. If you want "Person" to have a coercion, define the coercion in the
2837             "Person" class and don't rely on it being inherited from "Mammal".
2838              
2839             Coercions can also be specified using the attribute 'coerce' or 'coercion'
2840             for methods/multimethods/factory methods, if they only take a single typed
2841             positional argument.
2842              
2843             =item C<< subclass >> I<< (OptList) >>
2844              
2845             Set up subclasses of this class. This accepts an optlist like the class list.
2846             It allows subclasses to be nested as deep as you like:
2847              
2848             package MyApp;
2849             use MooX::Press (
2850             class => [
2851             'Animal' => {
2852             has => ['name!'],
2853             subclass => [
2854             'Fish',
2855             'Bird',
2856             'Mammal' => {
2857             can => { 'lactate' => sub { ... } },
2858             subclass => [
2859             'Cat',
2860             'Dog',
2861             'Primate' => {
2862             subclass => ['Monkey', 'Gorilla', 'Human'],
2863             },
2864             ],
2865             },
2866             ],
2867             },
2868             ];
2869             );
2870            
2871             package main;
2872             my $uncle = MyApp->new_human(name => "Bob");
2873             $uncle->isa('MyApp::Human'); # true
2874             $uncle->isa('MyApp::Primate'); # true
2875             $uncle->isa('MyApp::Mammal'); # true
2876             $uncle->isa('MyApp::Animal'); # true
2877             $uncle->isa('MyApp::Bird'); # false
2878             $uncle->can('lactate'); # eww, but true
2879              
2880             We just defined a nested heirarchy with ten classes there!
2881              
2882             Subclasses can be named with a leading "+" to tell them to use their parent
2883             class name as a prefix. So, in the example above, if you'd called your
2884             subclasses "+Mammal", "+Dog", etc, you'd end up with packages like
2885             "MyApp::Animal::Mammal::Dog". (In cases of multiple inheritance, it uses
2886             C<< $ISA[0] >>.)
2887              
2888             =item C<< factory >> I<< (Str|ArrayRef|Undef) >>
2889              
2890             This is the name for the method installed into the factory package.
2891             So for class "Cat", it might be "new_cat".
2892              
2893             The default is the class name (excluding the prefix), lowercased,
2894             with double colons replaced by single underscores, and
2895             with "new_" added in front. To suppress the creation
2896             of this method, set C<factory> to an explicit undef.
2897              
2898             If set to an arrayref, it indicates you wish to create multiple
2899             methods in the factory package to make objects of this class.
2900              
2901             factory => [
2902             "grow_pig" => \"new_from_embryo",
2903             "new_pork", "new_bacon", "new_ham" => sub { ... },
2904             "new_pig", "new_swine",
2905             ],
2906              
2907             A scalarref indicates the name of a constructor and that the
2908             methods before are shortcuts for that constructor. So
2909             C<< MyApp->grow_pig(@args) >> is a shortcut for
2910             C<< MyApp::Pig->new_from_embryo(@args) >>.
2911              
2912             A coderef will have a custom method installed into the factory package
2913             so that C<< MyApp->new_pork(@args) >> will act as a shortcut for:
2914             C<< $coderef->("MyApp", "MyApp::Pig", @args) >>. Note that C<new_bacon>
2915             and C<new_ham> are just aliases for C<new_bacon>.
2916              
2917             The C<new_pig> and C<new_swine> method names are followed by
2918             neither a coderef nor a scalarref, so are treated as if they had
2919             been followed by C<< \"new" >>.
2920              
2921             =item C<< type_name >> I<< (Str) >>
2922              
2923             The name for the type being installed into the type library.
2924              
2925             The default is the class name (excluding the prefix), with
2926             double colons replaced by single underscores.
2927              
2928             This:
2929              
2930             use MooX::Press prefix => "ABC::XYZ", class => ["Foo::Bar"];
2931              
2932             Will create class "ABC::XYZ::Foo::Bar", a factory method
2933             C<< ABC::XYZ->new_foo_bar() >>, and a type constraint
2934             "Foo_Bar" in type library "ABC::XYZ::Types".
2935              
2936             =item C<< toolkit >> I<< (Str) >>
2937              
2938             Override toolkit choice for this class and any child classes.
2939              
2940             =item C<< version >> I<< (Num) >>
2941              
2942             Override version number for this class and any child classes.
2943              
2944             =item C<< authority >> I<< (Str) >>
2945              
2946             Override authority for this class and any child classes.
2947              
2948             See L</Import Options>.
2949              
2950             =item C<< prefix >> I<< (Str) >>
2951              
2952             Override namespace prefix for this class and any child classes.
2953              
2954             See L</Import Options>.
2955              
2956             =item C<< factory_package >> I<< (Str) >>
2957              
2958             Override factory_package for this class and any child classes.
2959              
2960             See L</Import Options>.
2961              
2962             =item C<< mutable >> I<< (Bool) >>
2963              
2964             Override mutability for this class and any child classes.
2965              
2966             See L</Import Options>.
2967              
2968             =item C<< default_is >> I<< (Str) >>
2969              
2970             Override default_is for this class and any child classes.
2971              
2972             See L</Import Options>.
2973              
2974             =item C<< end >> I<< (CodeRef|ArrayRef[CodeRef]) >>
2975              
2976             Override C<end> for this class and any child classes.
2977              
2978             See L</Import Options>.
2979              
2980             =item C<< begin >> I<< (CodeRef|ArrayRef[CodeRef]) >>
2981              
2982             Override C<begin> for this class and any child classes.
2983              
2984             use MooX::Press::Keywords qw( true false );
2985             use MooX::Press (
2986             prefix => 'Library',
2987             class => [
2988             'Book' => {
2989             begin => sub {
2990             my $classname = shift; # "Library::Book"
2991             my $registry = Type::Registry->for_class($classname);
2992             $registry->alias_type('ArrayRef[Str]' => 'StrList')
2993             },
2994             has => {
2995             'title' => { type => 'Str', required => true },
2996             'authors' => { type => 'StrList', required => true },
2997             },
2998             },
2999             ],
3000             );
3001              
3002             See L</Import Options>.
3003              
3004             =item C<< import >> I<< (OptList) >>
3005              
3006             Allows you to import packages into classes.
3007              
3008             use MooX::Press (
3009             prefix => 'Library',
3010             class => [
3011             toolkit => 'Moose',
3012             import => [ 'MooseX::StrictConstructor' ],
3013             ...,
3014             ],
3015             );
3016              
3017             Note that the coderefs you pass to MooX::Press are evaluated in the caller
3018             namespace, so this isn't very useful if you're looking to import functions.
3019             It can be useful for many MooX, MooseX, and MouseX extensions though.
3020              
3021             =item C<< overload >> I<< (HashRef) >>
3022              
3023             Options to pass to C<< use overload >>.
3024              
3025             =item C<< abstract >> I<< (Bool) >>
3026              
3027             Marks the class as abstract. Abstract classes cannot have factories or
3028             coercions, and do not have a constuctor. They may be inherited from though.
3029             It is usually better to use roles.
3030              
3031             =back
3032              
3033             =head3 Role Options
3034              
3035             Options for roles are largely the same as for classes with the following
3036             exceptions:
3037              
3038             =over
3039              
3040             =item C<< requires >> I<< (ArrayRef) >>
3041              
3042             A list of methods required by the role.
3043              
3044             package MyApp;
3045             use MooX::Press (
3046             role => [
3047             'Milkable' => {
3048             requires => ['get_udder'],
3049             ...,
3050             },
3051             ],
3052             );
3053              
3054             Each method can optionally be followed by a method-defining hashref like
3055             in C<can>:
3056              
3057             package MyApp;
3058             use MooX::Press (
3059             role => [
3060             'Milkable' => {
3061             requires => [
3062             'get_udder', { signature => [...], named => 0 },
3063             ],
3064             ...,
3065             },
3066             ],
3067             );
3068              
3069             These hashrefs are currently ignored, but may be useful for people reading
3070             your role declarations.
3071              
3072             =item C<< extends >> I<< (Any) >>
3073              
3074             This option is disallowed.
3075              
3076             =item C<< can >> I<< (HashRef[CodeRef|HashRef]) >>
3077              
3078             The alternative style for defining methods may cause problems with the order
3079             in which things happen. Because C<< use MooX::Press >> happens at compile time,
3080             the following might not do what you expect:
3081              
3082             package MyApp;
3083             use MooX::Press (
3084             role => ["MyRole"],
3085             class => ["MyClass" => { with => "MyRole" }],
3086             );
3087            
3088             package MyApp::MyRole;
3089             sub my_function { ... }
3090              
3091             The "my_function" will not be copied into "MyApp::MyClass" because at the
3092             time the class is constructed, "my_function" doesn't yet exist within the
3093             role "MyApp::MyRole".
3094              
3095             You can combat this by changing the order you define things in:
3096              
3097             package MyApp::MyRole;
3098             sub my_function { ... }
3099            
3100             package MyApp;
3101             use MooX::Press (
3102             role => ["MyRole"],
3103             class => ["MyClass" => { with => "MyRole" }],
3104             );
3105              
3106             If you don't like having method definitions "above" MooX::Press in your file,
3107             then you can move them out into a module.
3108              
3109             # MyApp/Methods.pm
3110             #
3111             package MyApp::MyRole;
3112             sub my_function { ... }
3113              
3114             # MyApp.pm
3115             #
3116             package MyApp;
3117             use MyApp::Methods (); # load extra methods
3118             use MooX::Press (
3119             role => ["MyRole"],
3120             class => ["MyClass" => { with => "MyRole" }],
3121             );
3122              
3123             Or force MooX::Press to happen at runtime instead of compile time.
3124              
3125             package MyApp;
3126             require MooX::Press;
3127             import MooX::Press (
3128             role => ["MyRole"],
3129             class => ["MyClass" => { with => "MyRole" }],
3130             );
3131            
3132             package MyApp::MyRole;
3133             sub my_function { ... }
3134            
3135             =item C<< subclass >> I<< (Any) >>
3136              
3137             This option is not allowed.
3138              
3139             =item C<< factory >> I<< (Any) >>
3140              
3141             This option is not allowed.
3142              
3143             =item C<< mutable >> I<< (Any) >>
3144              
3145             This option is silently ignored.
3146              
3147             =item C<< overload >> I<< (Any) >>
3148              
3149             This option is not allowed.
3150              
3151             =item C<< abstract >> I<< (Any) >>
3152              
3153             This option is not allowed.
3154              
3155             =item C<< interface >> I<< (Bool) >>
3156              
3157             An interface is a "light" role.
3158              
3159             If a role is marked as an interface, it must not have any C<can>, C<before>,
3160             C<after>, C<around>, C<has>, or C<multimethod> options. C<requires>,
3161             C<constant>, and C<type_name> are allowed. C<with> is allowed; you should
3162             only use C<with> to compose other interfaces (not full roles) though this
3163             is not currently enforced.
3164              
3165             =item C<< before_apply >> I<< (CodeRef|ArrayRef[CodeRef]) >>
3166              
3167             Coderef to pass to C<before_apply> from L<Role::Hooks>.
3168              
3169             =item C<< after_apply >> I<< (CodeRef|ArrayRef[CodeRef]) >>
3170              
3171             Coderef to pass to C<after_apply> from L<Role::Hooks>.
3172              
3173             =back
3174              
3175             =head3 Attribute Specifications
3176              
3177             Attribute specifications are mostly just passed to the OO toolkit unchanged,
3178             somewhat like:
3179              
3180             has $attribute_name => %attribute_spec;
3181              
3182             So whatever specifications (C<required>, C<trigger>, C<coerce>, etc) the
3183             underlying toolkit supports should be supported.
3184              
3185             The following are exceptions:
3186              
3187             =over
3188              
3189             =item C<< is >> I<< (Str) >>
3190              
3191             This is optional rather than being required, and defaults to "ro" (or
3192             to C<default_is> if you defined that).
3193              
3194             MooX::Press supports the Moo-specific values of "rwp" and "lazy", and
3195             will translate them if you're using Moose or Mouse.
3196              
3197             There is a special value C<< is => "private" >> to create private
3198             attributes. These attributes cannot be set by the constructor
3199             (they always have C<< init_arg => undef >>) and do not have accessor
3200             methods by default. They are stored inside-out, so cannot even be accessed
3201             using direct hashref access of the object. If you're thinking this makes
3202             them totally inaccessible, and therefore useless, think again.
3203              
3204             For private attributes, you can request an accessor as a coderef:
3205              
3206             my $my_attr; # pre-declare lexical!
3207             use MooX::Press (
3208             'class:Foo' => {
3209             has => {
3210             'my_attr' => { is => 'private', accessor => \$my_attr },
3211             },
3212             can => {
3213             'my_method' => sub {
3214             my $self = shift;
3215             $self->$my_attr(42); # writer
3216             return $self->$my_attr(); # reader
3217             },
3218             },
3219             },
3220             );
3221              
3222             Private attributes may have defaults and builders (but they are always
3223             lazy!) They may also have C<handles>. You may find you can do everything
3224             you need with the builders and delegations, so having an accessor is
3225             unnecessary.
3226              
3227             (As of version 0.050, setting C<reader>, C<writer>, C<accessor>, C<clearer>,
3228             or C<predicate> to a scalarref will also work for I<public> attributes
3229             too!)
3230              
3231             =item C<< isa >> I<< (Str|Object) >>
3232              
3233             When the type constraint is a string, it is B<always> assumed to be a class
3234             name and your application's namespace prefix is added. So
3235             C<< isa => "HashRef" >> doesn't mean what you think it means. It means
3236             an object blessed into the "YourApp::HashRef" class.
3237              
3238             That is a feature though, not a weakness.
3239              
3240             use MooX::Press (
3241             prefix => 'Nature',
3242             class => [
3243             'Leaf' => {},
3244             'Tree' => {
3245             has => {
3246             'nicest_leaf' => { isa => 'Leaf' },
3247             },
3248             },
3249             ],
3250             );
3251              
3252             The C<< Nature::Tree >> and C<< Nature::Leaf >> classes will be built, and
3253             MooX::Press knows that the C<nicest_leaf> is supposed to be a blessed
3254             C<< Nature::Leaf >> object.
3255              
3256             String type names can be prefixed with C<< @ >> or C<< % >> to indicate an
3257             arrayref or hashref of a type:
3258              
3259             use MooX::Press (
3260             prefix => 'Nature',
3261             class => [
3262             'Leaf' => {},
3263             'Tree' => {
3264             has => {
3265             'foliage' => { isa => '@Leaf' },
3266             },
3267             },
3268             ],
3269             );
3270              
3271             For more everything else, use blessed type constraint objects, such as those
3272             from L<Types::Standard>, or use C<type> as documented below.
3273              
3274             use Types::Standard qw( Str );
3275             use MooX::Press (
3276             prefix => 'Nature',
3277             class => [
3278             'Leaf' => {},
3279             'Tree' => {
3280             has => {
3281             'foliage' => { isa => '@Leaf' },
3282             'species' => { isa => Str },
3283             },
3284             },
3285             ],
3286             );
3287              
3288             =item C<< type >> I<< (Str) >>
3289              
3290             C<< type => "HashRef" >> does what you think C<< isa => "HashRef" >> should
3291             do. More specifically it searches (by name) your type library, along with
3292             L<Types::Standard>, L<Types::Common::Numeric>, and L<Types::Common::String>
3293             to find the type constraint it thinks you wanted. It's smart enough to deal
3294             with parameterized types, unions, intersections, and complements.
3295              
3296             use MooX::Press (
3297             prefix => 'Nature',
3298             class => [
3299             'Leaf' => {},
3300             'Tree' => {
3301             has => {
3302             'foliage' => { isa => '@Leaf' },
3303             'species' => { type => 'Str' },
3304             },
3305             },
3306             ],
3307             );
3308              
3309             C<< type => $blessed_type_object >> does still work.
3310              
3311             C<type> and C<isa> are basically the same as each other, but differ in
3312             how they'll interpret a string. C<isa> assumes it's a class name as applies
3313             the package prefix to it; C<type> assumes it's the name of a type constraint
3314             which has been defined in some type library somewhere.
3315              
3316             =item C<< does >> I<< (Str) >>
3317              
3318             Similarly to C<isa>, these will be given your namespace prefix.
3319              
3320             # These mean the same...
3321             does => 'SomeRole',
3322             type => Types::Standard::ConsumerOf['MyApp::SomeRole'],
3323              
3324             =item C<< enum >> I<< (ArrayRef[Str]) >>
3325              
3326             This is a cute shortcut for an enum type constraint.
3327              
3328             # These mean the same...
3329             enum => ['foo', 'bar'],
3330             type => Types::Standard::Enum['foo', 'bar'],
3331              
3332             If the type constraint is set to an enum and C<handles> is provided,
3333             then MooX::Press will automatically load L<MooX::Enumeration> or
3334             L<MooseX::Enumeration> as appropriate. (This is not supported for
3335             Mouse.)
3336              
3337             use MooX::Press (
3338             prefix => 'Nature',
3339             class => [
3340             'Leaf' => {
3341             has => {
3342             'colour' => {
3343             enum => ['green', 'red', 'brown'],
3344             handles => 2,
3345             default => 'green',
3346             },
3347             },
3348             },
3349             ],
3350             );
3351            
3352             my $leaf = Nature->new_leaf;
3353             if ( $leaf->colour_is_green ) {
3354             print "leaf is green!\n";
3355             }
3356              
3357             =item C<< handles_via >> I<< (Str|ArrayRef[Str]) >>
3358              
3359             If your attribute has a C<handles_via> option, MooX::Press will load
3360             L<Sub::HandlesVia> for you.
3361              
3362             =item C<< handles >> I<< (ArrayRef|HashRef|RoleName) >>
3363              
3364             C<handles> is effectively a mapping of methods in the package being
3365             defined to methods in a target package. If C<handles> is a hashref,
3366             then it is obvious how that works. If C<handles> is a role name, then
3367             the mapping includes all the methods that are part of the role's API,
3368             and they map to methods of the same name in the target package.
3369             (Only Moose and Mouse support C<handles> being a role name.)
3370              
3371             For attributes with an enum type constraint, the special values
3372             C<< handles => 1 >> and C<< handles => 2 >> described above also
3373             work.
3374              
3375             When C<handles> is an arrayref, then the different backend modules
3376             would interpret it differently:
3377              
3378             # Moo, Moose, Mouse, Sub::HandlesVia, Moo(se)X::Enumeration
3379             [ "value1", "value2", "value3", "value4" ]
3380            
3381             # Lexical::Accessor
3382             [ "key1" => "value1", "key2" => "value2" ]
3383              
3384             Since version 0.050, MooX::Press smooths over the differences between
3385             them by converting these arrayrefs to hashrefs. Rather surprisingly,
3386             I<< the Lexical::Accessor interpretation of arrayrefs is used >>. It
3387             is treated as a list of key-value pairs.
3388              
3389             This is because even though that's the minority interpretation, it's
3390             the more useful interpretation, allowing methods from the target
3391             package to be given a different name in the package being defined,
3392             or even assigned to lexical variables.
3393              
3394             has => [
3395             'ua' => {
3396             is => 'bare',
3397             default => sub { HTTP::Tiny->new },
3398             handles => [
3399             \$get => 'get',
3400             \$post => 'post',
3401             ],
3402             },
3403             ],
3404              
3405             Now C<< $get >> will be a coderef that you can call as a method:
3406              
3407             $self->$get($url); # same as $self->{ua}->get($url)
3408              
3409             If you use C<< handles => \%hash >>, you should get expected behaviour.
3410             If you use C<< handles => \@array >>, just be aware that your array is
3411             going to be interpreted like a hash from MooX::Press 0.050 onwards!
3412              
3413             =item C<< coerce >> I<< (Bool|CodeRef) >>
3414              
3415             MooX::Press automatically implies C<< coerce => 1 >> when you give a
3416             type constraint that has a coercion. If you don't want coercion then
3417             explicitly provide C<< coerce => 0 >>.
3418              
3419             C<< coerce => sub { ... } >> is supported even for Moose and Mouse.
3420              
3421             =item C<< builder >> I<< ("1"|Str|CodeRef) >>
3422              
3423             MooX::Press supports the Moo-specific C<< builder => 1 >> and
3424             C<< builder => sub { ... } >> and will translate them if you're using
3425             Moose or Mouse.
3426              
3427             =item C<< trigger >> I<< ("1"|Str|CodeRef) >>
3428              
3429             MooX::Press supports the Moo-specific C<< trigger => 1 >> and
3430             C<< trigger => $methodname >> and will translate them if you're using
3431             Moose or Mouse.
3432              
3433             =item C<< clearer >> I<< ("1"|Str) >>
3434              
3435             MooX::Press supports the Moo-specific C<< clearer => 1 >> and
3436             will translate it if you're using Moose or Mouse.
3437              
3438             =item C<< default >> I<< (CodeRef|~Ref|Overloaded|ScalarRef) >>
3439              
3440             Coderefs and non-reference values can be used as defaults the same
3441             as in Moo/Moose/Mouse.
3442              
3443             Blessed L<Ask::Question> objects are additionally supported as
3444             defaults. The C<type> of the attribute will automatically be injected
3445             as the target type of the question if the target type is missing.
3446              
3447             A scalarref is converted to an L<Ask::Question> object so:
3448              
3449             has age => ( is => 'ro', type => 'Int', default => \"Enter age" );
3450              
3451             Will require age to be an integer, and if it's not provided to the
3452             constructor, L<Ask> will prompt the user via STDIN/STDOUT, a GUI
3453             dialogue box, or whatever other method is available.
3454              
3455             =back
3456              
3457             =head3 Method Signatures
3458              
3459             Most places where a coderef is expected, MooX::Press will also accept a
3460             hashref of the form:
3461              
3462             {
3463             signature => [ ... ],
3464             named => 1,
3465             code => sub { ... },
3466             attributes => [ ... ],
3467             }
3468              
3469             The C<signature> is a specification to be passed to C<compile> or
3470             C<compile_named_oo> from L<Type::Params> (depending on whether C<named>
3471             is true or false).
3472              
3473             Unlike L<Type::Params>, these signatures allow type constraints to be
3474             given as strings, which will be looked up by name.
3475              
3476             This should work for C<can>, C<factory_can>, C<type_library_can>,
3477             C<factory>, C<builder> methods, and method modifiers. (Though if you
3478             are doing type checks in both the methods and method modifiers, this
3479             may result in unnecessary duplication of checks.)
3480              
3481             The invocant (C<< $self >>) is not included in the signature.
3482             (For C<around> method modifiers, the original coderef C<< $orig >> is
3483             logically a second invocant. For C<factory> methods installed in the
3484             factory package, the factory package name and class name are both
3485             considered invocants.)
3486              
3487             Example with named parameters:
3488              
3489             use MooX::Press (
3490             prefix => 'Wedding',
3491             class => [
3492             'Person' => { has => [qw( $name $spouse )] },
3493             'Officiant' => {
3494             can => {
3495             'marry' => {
3496             signature => [ bride => 'Person', groom => 'Person' ],
3497             named => 1,
3498             code => sub {
3499             my ($self, $args) = @_;
3500             $args->bride->spouse($args->groom);
3501             $args->groom->spouse($args->bride);
3502             printf("%s, you may kiss the bride\n", $args->groom->name);
3503             return $self;
3504             },
3505             },
3506             },
3507             },
3508             ],
3509             );
3510            
3511             my $alice = Wedding->new_person(name => 'Alice');
3512             my $bob = Wedding->new_person(name => 'Robert');
3513            
3514             my $carol = Wedding->new_officiant(name => 'Carol');
3515             $carol->marry(bride => $alice, groom => $bob);
3516              
3517             Example with positional parameters:
3518              
3519             use MooX::Press (
3520             prefix => 'Wedding',
3521             class => [
3522             'Person' => { has => [qw( $name $spouse )] },
3523             'Officiant' => {
3524             can => {
3525             'marry' => {
3526             signature => [ 'Person', 'Person' ],
3527             code => sub {
3528             my ($self, $bride, $groom) = @_;
3529             $bride->spouse($groom);
3530             $groom->spouse($bride);
3531             printf("%s, you may kiss the bride\n", $groom->name);
3532             return $self;
3533             },
3534             },
3535             },
3536             },
3537             ],
3538             );
3539            
3540             my $alice = Wedding->new_person(name => 'Alice');
3541             my $bob = Wedding->new_person(name => 'Robert');
3542            
3543             my $carol = Wedding->new_officiant(name => 'Carol');
3544             $carol->marry($alice, $bob);
3545              
3546             Methods with a mixture of named and positional parameters are not supported.
3547             If you really want such a method, don't provide a signature; just provide a
3548             coderef and manually unpack C<< @_ >>.
3549              
3550             B<< Advanced features: >>
3551              
3552             C<signature> may be a coderef, which is passed C<< @_ >> (minus invocants)
3553             and is expected to return a new C<< @_ >> in list context after checking
3554             and optionally coercing parameters.
3555              
3556             Setting C<< optimize => 1 >> tells MooX::Press to attempt to perform
3557             additional compile-time optimizations on the signature to make it slightly
3558             faster at runtime. (Sometimes it will find it's unable to optimize anything,
3559             so you've just wasted time at compile time.)
3560              
3561             C<code> can be a string of Perl code like C<< sub { ... } >> instead of
3562             a real coderef. This doesn't let you close over any variables, but if
3563             you can provide code this way, it might be slightly faster.
3564              
3565             =head2 Optimization Features
3566              
3567             MooX::Press will automatically load and apply L<MooX::XSConstructor> if it's
3568             installed, which will optmimize constructors for some very basic classes.
3569             Again, this is only for Moo classes.
3570              
3571             MooX::Press will automatically load L<MooseX::XSAccessor> if it's installed,
3572             which speeds up some Moose accessors. This is only used for Moose classes.
3573              
3574             =head2 Subclassing MooX::Press
3575              
3576             All the internals of MooX::Press are called as methods, which should make
3577             subclassing it possible.
3578              
3579             package MyX::Press;
3580             use parent 'MooX::Press';
3581             use Class::Method::Modifiers;
3582            
3583             around make_class => sub {
3584             my $orig = shift;
3585             my $self = shift;
3586             my ($name, %opts) = @_;
3587             ## Alter %opts here
3588             my $qname = $self->$orig($name, %opts);
3589             ## Maybe do something to the returned class
3590             return $qname;
3591             };
3592              
3593             It is beyond the scope of this documentation to fully describe all the methods
3594             you could potentially override, but here is a quick summary of some that may
3595             be useful.
3596              
3597             =over
3598              
3599             =item C<< import(%opts|\%opts) >>
3600              
3601             =item C<< qualify_name($name, $prefix) >>
3602              
3603             =item C<< croak($error) >>
3604              
3605             =item C<< prepare_type_library($qualified_name) >>
3606              
3607             =item C<< make_type_for_role($name, %opts) >>
3608              
3609             =item C<< make_type_for_class($name, %opts) >>
3610              
3611             =item C<< make_role($name, %opts) >>
3612              
3613             =item C<< make_class($name, %opts) >>
3614              
3615             =item C<< install_methods($qualified_name, \%methods) >>
3616              
3617             =item C<< install_constants($qualified_name, \%values) >>
3618              
3619             =back
3620              
3621             =head1 FAQ
3622              
3623             This is a new module so I haven't had any questions about it yet, let alone
3624             any frequently asked ones, but I will anticipate some.
3625              
3626             =head2 Why doesn't MooX::Press automatically import strict and warnings for me?
3627              
3628             Your MooX::Press import will typically contain a lot of strings, maybe some
3629             as barewords, some coderefs, etc. You should manually import strict and
3630             warnings B<before> importing MooX::Press to ensure all of that is covered
3631             by strictures.
3632              
3633             =head2 Why all the factory stuff?
3634              
3635             Factories are big and cool and they put lots of smoke into our atmosphere.
3636              
3637             Also, if you do something like:
3638              
3639             use constant APP => 'MyGarden';
3640             use MooX::Press (
3641             prefix => APP,
3642             role => [
3643             'LeafGrower' => {
3644             has => [ '@leafs' => sub { [] } ],
3645             can => {
3646             'grow_leaf' => sub {
3647             my $self = shift;
3648             my $leaf = $self->FACTORY->new_leaf;
3649             push @{ $self->leafs }, $leaf;
3650             return $leaf;
3651             },
3652             },
3653             },
3654             ],
3655             class => [
3656             'Leaf',
3657             'Tree' => { with => ['LeafGrower'] },
3658             ],
3659             );
3660            
3661             my $tree = APP->new_tree;
3662             my $leaf = $tree->grow_leaf;
3663              
3664             And you will notice that the string "MyGarden" doesn't appear anywhere in
3665             the definitions for any of the classes and roles. The prefix could be
3666             changed to something else entirely and all the classes and roles, all the
3667             methods within them, would continue to work.
3668              
3669             Whole collections of classes and roles now have portable namespaces. The same
3670             classes and roles could be used with different prefixes in different scripts.
3671             You could load two different versions of your API in the same script with
3672             different prefixes. The possibilities are interesting.
3673              
3674             Factory methods are also exportable.
3675              
3676             use MyGarden 'new_tree';
3677            
3678             my $maple = new_tree(); # called as a function, not a method
3679              
3680             Exported functions can be renamed (see L<Exporter::Tiny>).
3681              
3682             use MyGarden 'new_tree' => { -as => 'germinate' };
3683            
3684             my $maple = germinate();
3685              
3686             =head2 Why doesn't C<< $object->isa("Leaf") >> work?
3687              
3688             In the previous question, C<< $object->isa("Leaf") >> won't work to check
3689             if an object is a Leaf. This is because the full name of the class is
3690             "MyGarden::Leaf".
3691              
3692             You can of course check C<< $object->isa("MyGarden::Leaf") >> but this
3693             means you're starting to hard-code class names and prefixes again, which
3694             is one of the things MooX::Press aims to reduce.
3695              
3696             The "correct" way to check something is a leaf is:
3697              
3698             use MyGarden::Types qw( is_Leaf );
3699            
3700             if ( is_Leaf($object) ) {
3701             ...;
3702             }
3703              
3704             Or if you really want to use C<isa>:
3705              
3706             use MyGarden::Types qw( Leaf );
3707            
3708             if ( $object->isa(Leaf->class) ) {
3709             ...;
3710             }
3711              
3712             However, the type library is only available I<after> you've used MooX::Press.
3713             This can make it tricky to refer to types within your methods.
3714              
3715             use constant APP => 'MyGarden';
3716             use MooX::Press (
3717             prefix => APP,
3718             class => [
3719             'Leaf',
3720             'Tree' => {
3721             can => {
3722             'add_leaf' => sub {
3723             my ($self, $leaf) = @_;
3724            
3725             # How to check is_Leaf() here?
3726             # It's kind of tricky!
3727            
3728             my $t = $self->FACTORY->type_library->get_type('Leaf');
3729             if ($t->check($leaf)) {
3730             ...;
3731             }
3732             },
3733             },
3734             },
3735             ],
3736             );
3737              
3738             As of version 0.019, MooX::Press has method signatures, so you're less
3739             likely to need to check types within your methods; you can just do it in
3740             the signature. This won't cover every case you need to check types, but
3741             it will cover the common ones.
3742              
3743             use constant APP => 'MyGarden';
3744             use MooX::Press (
3745             prefix => APP,
3746             class => [
3747             'Leaf',
3748             'Tree' => {
3749             can => {
3750             'add_leaf' => {
3751             signature => ['Leaf'],
3752             code => sub {
3753             my ($self, $leaf) = @_;
3754             ...;
3755             },
3756             },
3757             },
3758             },
3759             ],
3760             );
3761              
3762             This also makes your code more declarative and less imperative, and that
3763             is a Good Thing, design-wise.
3764              
3765             =head2 The plural of "leaf" is "leaves", right?
3766              
3767             Yeah, but that sounds like something is leaving.
3768              
3769             =head2 How do generators work?
3770              
3771             A class generator is like a class of classes.
3772              
3773             A role generator is like a class of roles.
3774              
3775             use MooX::Press (
3776             prefix => 'MyApp',
3777             class => [
3778             'Animal' => {
3779             has => ['$name'],
3780             },
3781             ],
3782             class_generator => [
3783             'Species' => sub {
3784             my ($gen, $binomial) = @_;
3785             return {
3786             extends => ['Animal'],
3787             constant => { binomial => $binomial },
3788             };
3789             },
3790             ],
3791             );
3792              
3793             This generates MyApp::Animal as a class, as you might expect, but also
3794             creates a class generator called MyApp::Species.
3795              
3796             MyApp::Species is not itself a class but it can make classes. Calling
3797             either C<< MyApp::Species->generate_package >> or
3798             C<< MyApp->generate_species >> will compile a new class
3799             and return the class name as a string.
3800              
3801             my $Human = MyApp->generate_species('Homo sapiens');
3802             my $Dog = MyApp->generate_species('Canis familiaris');
3803            
3804             my $alice = $Human->new(name => 'Alice');
3805             say $alice->name; # Alice
3806             say $alice->binomial; # Homo sapiens
3807            
3808             my $fido = $Dog->new(name => 'Fido');
3809             $fido->isa($Dog); # true
3810             $fido->isa($Human); # false
3811             $fido->isa('MyApp::Animal'); # true
3812             $fido->isa('MyApp::Species'); # false!!!
3813            
3814             use Types::Standard -types;
3815             use MyApp::Types -types;
3816            
3817             is_ClassName($fido) # false
3818             is_Object($fido) # true
3819             is_Animal($fido); # true
3820             is_SpeciesInstance($fido); # true
3821             is_SpeciesClass($fido); # false
3822             is_ClassName($Dog) # true
3823             is_Object($Dog) # false
3824             is_Animal($Dog); # false
3825             is_SpeciesInstance($Dog); # false
3826             is_SpeciesClass($Dog); # true
3827              
3828             Note that there is no B<Species> type created, but instead a pair of types
3829             is created: B<SpeciesClass> and B<SpeciesInstance>.
3830              
3831             It is also possible to inherit from generated classes.
3832              
3833             use MooX::Press (
3834             prefix => 'MyApp',
3835             class => [
3836             'Animal' => {
3837             has => ['$name'],
3838             },
3839             'Dog' => {
3840             extends => [ 'Species' => ['Canis familiaris'] ]
3841             },
3842             ],
3843             class_generator => [
3844             'Species' => sub {
3845             my ($gen, $binomial) = @_;
3846             return {
3847             extends => ['Animal'],
3848             constant => { binomial => $binomial },
3849             };
3850             },
3851             ],
3852             );
3853            
3854             my $fido = MyApp->new_dog(name => 'Fido');
3855              
3856             The inheritance heirarchy for C<< $fido >> is something like:
3857              
3858             Moo::Object
3859             -> MyApp::Animal
3860             -> MyApp::Species::__GEN000001__
3861             -> MyApp::Dog
3862              
3863             Note that MyApp::Species itself isn't in that heirarchy!
3864              
3865             Generated roles work pretty much the same, but C<role_generator> instead
3866             of C<class_generator>, C<does> instead of C<isa>, and C<with> instead of
3867             C<extends>.
3868              
3869             No type constraints are automatically created for generated roles.
3870              
3871             =head2 Are you insane?
3872              
3873             Quite possibly.
3874              
3875             =head1 BUGS
3876              
3877             Please report any bugs to
3878             L<http://rt.cpan.org/Dist/Display.html?Queue=MooX-Press>.
3879              
3880             =head1 SEE ALSO
3881              
3882             L<Zydeco::Lite>, L<Zydeco>.
3883              
3884             L<Moo>, L<MooX::Struct>, L<Types::Standard>.
3885              
3886             L<portable::loader>.
3887              
3888             =head1 AUTHOR
3889              
3890             Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
3891              
3892             =head1 COPYRIGHT AND LICENCE
3893              
3894             This software is copyright (c) 2019-2020 by Toby Inkster.
3895              
3896             This is free software; you can redistribute it and/or modify it under
3897             the same terms as the Perl 5 programming language system itself.
3898              
3899             =head1 DISCLAIMER OF WARRANTIES
3900              
3901             THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
3902             WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
3903             MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
3904