File Coverage

blib/lib/MooseX/RelatedClasses.pm
Criterion Covered Total %
statement 72 83 86.7
branch 4 4 100.0
condition n/a
subroutine 33 46 71.7
pod n/a
total 109 133 81.9


line stmt bran cond sub pod time code
1             #
2             # This file is part of MooseX-RelatedClasses
3             #
4             # This software is Copyright (c) 2017, 2015, 2014, 2013, 2012 by Chris Weyl.
5             #
6             # This is free software, licensed under:
7             #
8             # The GNU Lesser General Public License, Version 2.1, February 1999
9             #
10             package MooseX::RelatedClasses;
11             our $AUTHORITY = 'cpan:RSRCHBOY';
12             # git description: 0.011-2-g61ae6c8
13             $MooseX::RelatedClasses::VERSION = '0.012';
14              
15             # ABSTRACT: Parameterized role for related class attributes
16              
17 7     19   1392486 use MooseX::Role::Parameterized;
  7         544642  
  7         29  
18 7     19   239719 use namespace::autoclean;
  7         16  
  7         66  
19 7     7   3090 use autobox::Core;
  7         78869  
  7         66  
20 7     7   7341 use autobox::Camelize;
  7         2851  
  7         42  
21 7     7   6318 use MooseX::AttributeShortcuts 0.020;
  7         1711668  
  7         43  
22 7     7   1117364 use MooseX::Types::Common::String ':all';
  7         18  
  7         73  
23 7     7   38192 use MooseX::Types::LoadableClass ':all';
  7         397953  
  7         63  
24 7     7   22811 use MooseX::Types::Perl ':all';
  7         299518  
  7         105  
25 7     7   29538 use MooseX::Types::Moose ':all';
  7         20  
  7         132  
26 7     7   68975 use MooseX::Util 'with_traits', 'find_meta';
  7         262889  
  7         73  
27              
28 7     7   3835 use Module::Find 'findallmod';
  7         8865  
  7         493  
29              
30 7     7   57 use Class::Load 'load_class';
  7         20  
  7         366  
31 7     7   1826 use String::RewritePrefix;
  7         6706  
  7         32  
32              
33 7     7   1340 use Moose::Exporter;
  7         16  
  7         63  
34              
35              
36             {
37             package MooseX::RelatedClasses::Exports;
38             our $AUTHORITY = 'cpan:RSRCHBOY';
39             # git description: 0.011-2-g61ae6c8
40             $MooseX::RelatedClasses::Exports::VERSION = '0.012';
41              
42             # This is a little awkward, but it resolves the unpleasantness of having
43             # these functions become part of the role (!!!)
44             #
45             # Here we simply create a "dummy" package using Moose exporter, then pull
46             # its imports in via an "also" in the main package. This resolves things
47             # nicely without having to do any meta-tinkering.
48             #
49             # Sadly.
50              
51 7     7   502 use strict;
  7         14  
  7         136  
52 7     7   33 use warnings;
  7         16  
  7         166  
53              
54 7     7   38 use MooseX::Util 'find_meta';
  7         13  
  7         43  
55 7     7   505 use Moose::Exporter;
  7         16  
  7         41  
56              
57             Moose::Exporter->setup_import_methods(
58             with_meta => [ qw{
59             related_class
60             related_classes
61             related_namespace
62             } ],
63             );
64              
65 6     6   6339 sub related_class { goto \&related_classes }
66              
67             sub related_classes {
68 6     6   16 my $meta = shift;
69              
70 6 100       38 if (@_ % 2 == 1) {
71 4 100       29 unshift @_, ref $_[0] ? 'names' : 'name';
72             }
73              
74 6         33 find_meta('MooseX::RelatedClasses')->apply($meta, @_);
75             }
76              
77             sub related_namespace {
78 0     0   0 my ($meta, $namespace) = (shift, shift);
79              
80 0         0 my %args = (
81             all_in_namespace => 1,
82             namespace => $namespace,
83             name => $namespace,
84             @_,
85             );
86              
87             ### %args
88 0         0 find_meta('MooseX::RelatedClasses')->apply($meta, %args);
89             }
90             }
91              
92             Moose::Exporter->setup_import_methods(
93             also => 'MooseX::RelatedClasses::Exports',
94             );
95              
96              
97             parameter name => (
98             traits => [Shortcuts],
99             is => 'ro',
100             isa => PackageName,
101             predicate => 1,
102             );
103              
104             parameter names => (
105             traits => [Shortcuts],
106             is => 'rwp',
107             predicate => 1,
108             lazy => 1,
109              
110             isa => HashRef[Identifier],
111             constraint => sub { do { is_PackageName($_) or die 'keys must be PackageName' } for $_->keys; 1 },
112             coerce => [
113             ArrayRef => sub { +{ map { $_ => $_->decamelize } @$_ } },
114             PackageName()->name() => sub { +{ $_ => $_->decamelize } },
115             ],
116              
117             default => sub { confess 'name parameter required!' unless $_[0]->has_name; $_[0]->name },
118             );
119              
120             parameter namespace => (
121             traits => [Shortcuts],
122             is => 'rwp',
123             isa => Maybe[PackageName],
124             predicate => 1,
125             );
126              
127             parameter all_in_namespace => (isa => Bool, default => 0);
128             parameter load_all => (isa => Bool, default => 0);
129             parameter private => (isa => Bool, default => 0);
130              
131             # TODO use rewrite prefix to look for traits in namespace
132              
133             role {
134             my ($p, %opts) = @_;
135              
136             confess 'Cannot specify both the "name" and "names" parameters!'
137             if $p->has_name && $p->has_names;
138              
139             # check namespace
140             if (not $p->has_namespace) {
141              
142             die 'Either a namespace or a consuming metaclass must be supplied!'
143             unless $opts{consumer};
144              
145             $p->_set_namespace($opts{consumer}->name);
146             }
147              
148             if ($p->all_in_namespace) {
149              
150             confess 'Cannot use an empty namespace and all_in_namespace!'
151             unless $p->has_namespace;
152              
153             my $ns = $p->namespace;
154              
155             ### finding for namespace: $ns
156             my %mod =
157             map { s/^${ns}:://; $_ => $_->decamelize }
158             map { load_class($_) if $p->load_all; $_ }
159             Module::Find::findallmod $ns
160             ;
161              
162             ### %mod
163             $p->_set_names(\%mod);
164             }
165              
166             for my $name ($p->names->keys->flatten) {
167             my $identifier = $p->names->{$name};
168              
169             my $full_name
170             = $p->namespace
171             ? $p->namespace . '::' . $name
172             : $name
173             ;
174              
175             my $pvt = $p->private ? '_' : q{};
176              
177             # SomeThing::More -> some_thing__more
178             my $local_name = "${identifier}_class";
179             my $original_local_name = "original_$local_name";
180             my $original_reader = "$pvt$original_local_name";
181             my $traitsfor_local_name = $local_name . '_traits';
182             my $traitsfor_reader = "$pvt$traitsfor_local_name";
183              
184             ### $full_name
185             has "$pvt$original_local_name" => (
186             traits => [Shortcuts],
187             is => 'lazy',
188             isa => LoadableClass,
189             constraint => sub { $_->isa($full_name) },
190             coerce => 1,
191             init_arg => "$pvt$local_name",
192 0     0   0 builder => sub { $full_name },
  16     0   443  
  2     16   95  
  0     18   0  
  2     40   66  
  2     0   45  
        0      
        2      
        2      
193             );
194              
195             has "$pvt$local_name" => (
196             traits => [Shortcuts],
197             is => 'lazy',
198             isa => LoadableClass,
199             constraint => sub { $_->isa($full_name) },
200             coerce => 1,
201             init_arg => undef,
202             builder => sub {
203 0     0   0 my $self = shift @_;
  26     0   84  
  2     38   6  
  0     58   0  
  2     20   7  
        0      
        0      
        2      
204              
205 0         0 return with_traits( $self->$original_reader() =>
  26         851  
  2         68  
  0         0  
  2         87  
206             $self->$traitsfor_reader()->flatten,
207             );
208             },
209             );
210              
211             # XXX do the same original/local init_arg swizzle here too?
212             has "$pvt$traitsfor_local_name" => (
213             traits => [Shortcuts, 'Array'],
214             is => 'lazy',
215             isa => ArrayRef[LoadableRole],
216 0     0   0 builder => sub { [ ] },
  26     0   693  
  2     62   61  
  0     64   0  
  2     2   85  
        0      
        0      
        2      
217             handles => {
218             "${pvt}has_$traitsfor_local_name" => 'count',
219             },
220             );
221             }
222              
223             return;
224             };
225              
226             !!42;
227              
228             __END__
229              
230             =pod
231              
232             =encoding UTF-8
233              
234             =for :stopwords Chris Weyl Kulag Parameterized Namespacing findable
235              
236             =head1 NAME
237              
238             MooseX::RelatedClasses - Parameterized role for related class attributes
239              
240             =head1 VERSION
241              
242             This document describes version 0.012 of MooseX::RelatedClasses - released August 13, 2017 as part of MooseX-RelatedClasses.
243              
244             =head1 SYNOPSIS
245              
246             # with this:
247             with 'MooseX::RelatedClasses' => {
248             name => 'Thinger', namespace => undef,
249             };
250              
251             # this:
252             use MooseX::RelatedClasses;
253             related_class name => 'Thinger', namespace => undef;
254              
255             # ...or this:
256             use MooseX::RelatedClasses;
257             related_class 'Thinger', namespace => undef;
258              
259             # ...we get three attributes:
260             #
261             # thinger_class
262             # thinger_class_traits
263             # original_thinger_class
264             #
265             # ...and they look like this:
266              
267             has thinger_class => (
268             traits => [ Shortcuts ], # MooseX::AttributeShortcuts
269             is => 'lazy', # MX::AttributeShortcuts
270             isa => LoadableClass, # MooseX::Types::LoadableClass
271             init_arg => undef,
272             constraint => sub { $_->isa('Thinger') }, # MX::AttributeShortcuts
273             builder => sub { ... compose original class and traits ... },
274             );
275              
276             has thinger_class_traits => (
277             traits => [ Shortcuts ],
278             is => 'lazy',
279             isa => ArrayRef[LoadableRole],
280             builder => sub { [ ] },
281             );
282              
283             has original_thinger_class => (
284             traits => [ Shortcuts ],
285             is => 'lazy',
286             isa => LoadableClass,
287             constraint => sub { $_->isa('Thinger') },
288             coerce => 1,
289             init_arg => 'thinger_class',
290             builder => sub { 'My::Framework::Thinger' },
291             );
292              
293             =head1 DESCRIPTION
294              
295             Have you ever built out a framework, or interface API of some sort, to
296             discover either that you were hardcoding your related class names (not very
297             extension-friendly) or writing the same code for the same type of attributes
298             to specify what related classes you're using?
299              
300             Alternatively, have you ever been using a framework, and wanted to tweak one
301             tiny bit of behaviour in a subclass, only to realize it was written in such a
302             way to make that difficult-to-impossible without a significant effort?
303              
304             This package aims to end that, by providing an easy, flexible way of defining
305             "related classes", their base class, and allowing traits to be specified.
306              
307             =head1 ROLE PARAMETERS
308              
309             Parameterized roles accept parameters that influence their construction. This role accepts the following parameters.
310              
311             =head2 name
312              
313             The name of a class, without the prefix, to consider related. e.g. if My::Foo
314             is our namespace and My::Foo::Bar is the related class:
315              
316             name => 'Bar'
317              
318             ...is the correct specification.
319              
320             This parameter is optional, so long as either the names or all_in_namespace
321             parameters are given.
322              
323             =head2 names [ ... ]
324              
325             One or more names that would be legal for the name parameter.
326              
327             =head2 all_in_namespace (Bool)
328              
329             True if all findable packages under the namespace should be used as related
330             classes. Defaults to false.
331              
332             =head2 namespace
333              
334             The namespace our related classes live in. If this is not given explicitly,
335             the name of the consuming class will be used as the namespace. If the
336             consuming class' metaclass is not available (e.g. the role is being
337             constructed by something other than a consumer), then this parameter is
338             mandatory.
339              
340             This parameter will also accept an explicit 'undef'. If this is the case,
341             then related classes must be specified by their full name and it is an error
342             to attempt to enable the all_in_namespace option.
343              
344             e.g.:
345              
346             with 'MooseX::RelatedClasses' => {
347             namespace => undef,
348             name => 'LWP::UserAgent',
349             };
350              
351             ...will provide the C<lwp__user_agent_class>, C<lwp__user_agent_traits> and
352             C<original_lwp__user_agent_class> attributes.
353              
354             =head2 load_all (Bool)
355              
356             If set to true, all related classes are loaded as we find them. Defaults to
357             false.
358              
359             =head2 private (Bool)
360              
361             If true, attributes, accessors and builders will all be named according to the
362             same rules L<MooseX::AttributeShortcuts> uses. (That is, in general prefixed
363             with an "_".)
364              
365             =head1 FUNCTIONS
366              
367             =head2 related_class()
368              
369             Synonym for L</related_classes()>.
370              
371             =head2 related_classes()
372              
373             Takes the same options that the role takes as parameters. That means that this:
374              
375             related_classes name => 'LWP::UserAgent', namespace => undef;
376              
377             ...is effectively the same as:
378              
379             with 'MooseX::RelatedClasses' => {
380             name => 'LWP::UserAgent',
381             namespace => undef,
382             };
383              
384             =head2 related_namespace()
385              
386             Given a namespace, declares that everything under that namespace is related.
387             That is,
388              
389             related_namespace 'Net::Amazon::EC2';
390              
391             ...is the same as:
392              
393             with 'MooseX::RelatedClasses' => {
394             namespace => 'Net::Amazon::EC2',
395             name => 'Net::Amazon::EC2',
396             all_in_namespace => 1,
397             };
398              
399             =head1 EXAMPLES
400              
401             =head2 Multiple Related Classes at Once
402              
403             Use the L</names> option with an array reference of classes, and attribute
404             sets will be built for all of them.
405              
406             related_classes [ qw{ Thinger Dinger Finger } ];
407              
408             # or longhand:
409             related_classes names => [ qw{ Thinger Dinger Finger } ];
410              
411             =head2 Namespaces / Namespacing
412              
413             Normally, related classes tend to be under the namespace of the class they
414             are related to. For example, let's say we have a class named C<TimeLords>.
415             Related to this class are C<TimeLords::SoftwareWritten::Git>,
416             C<TimeLords::Gallifrey> and C<TimeLords::Enemies::Daleks>.
417              
418             The C<TimeLords> package can start off like this, to include the proper
419             related classes:
420              
421             package TimeLords;
422              
423             use Moose;
424             use timeandspace::autoclean;
425             use MooseX::RelatedClasses;
426              
427             related_classes [ qw{ Gallifrey Enemies::Daleks SoftwareWritten::Git } ];
428              
429             And that will generate the expected related class attributes:
430              
431             # TimeLords::Gallifrey
432             gallifrey_class
433             gallifrey_class_traits
434             original_gallifrey_class
435             # TimeLords::Enemies::Daleks
436             enemies__daleks_class
437             enemies__daleks_class_traits
438             original_enemies__daleks_class
439             # TimeLords::SoftwareWritten::Git
440             software_written__git_class
441             software_written__git_class_traits
442             original_software_written__git_class
443              
444             =head2 Related classes outside the namespace
445              
446             Occasionally you'll want to use something like L<LWP::UserAgent>, which has
447             nothing to do with your class except that you use it, and would like to be
448             able to easily tweak it on the fly. This can be done with the C<undef>
449             namespace:
450              
451             related_class 'LWP::UserAgent', namespace => undef;
452              
453             This will cause the following related class attributes to be generated:
454              
455             lwp__user_agent_class
456             lwp__user_agent_class_traits
457             original_lwp__user_agent_class
458              
459             =head1 INSPIRATION / MADNESS
460              
461             The L<Class::MOP> / L<Moose> MOP show the beginnings of this: with attributes
462             or methods named a certain way (e.g. *_metaclass()) the class to be used for a
463             particular thing (e.g. attribute metaclass) is stored in a fashion such that a
464             subclass (or trait) may overwrite and provide a different class name to be
465             used.
466              
467             So too, here, we do this, but in a more flexible way: we track the original
468             related class, any additional traits that should be applied, and the new
469             (anonymous, typically) class name of the related class.
470              
471             Another example is the (very useful and usable) L<Net::Amazon::EC2>. It uses
472             L<Moose>, is nicely broken out into discrete classes, etc, but does not lend
473             itself to easy on-the-fly extension by developers with traits.
474              
475             =head1 ANONYMOUS CLASS NAMES
476              
477             Note that we use L<MooseX::Traitor> to compose anonymous classes, so the
478             "anonymous names" will look less like:
479              
480             Moose::Meta::Package::__ANON__::SERIAL::...
481              
482             And more like:
483              
484             My::Framework::Thinger::__ANON__::SERIAL::...
485              
486             Anonymous classes are only ever composed if traits for a related class are
487             supplied.
488              
489             =head1 BUGS
490              
491             Please report any bugs or feature requests on the bugtracker website
492             L<https://github.com/RsrchBoy/moosex-relatedclasses/issues>
493              
494             When submitting a bug or request, please include a test-file or a
495             patch to an existing test-file that illustrates the bug or desired
496             feature.
497              
498             =head1 AUTHOR
499              
500             Chris Weyl <cweyl@alumni.drew.edu>
501              
502             =head1 CONTRIBUTOR
503              
504             =for stopwords Kulag
505              
506             Kulag <g.kulag@gmail.com>
507              
508             =head1 COPYRIGHT AND LICENSE
509              
510             This software is Copyright (c) 2017, 2015, 2014, 2013, 2012 by Chris Weyl.
511              
512             This is free software, licensed under:
513              
514             The GNU Lesser General Public License, Version 2.1, February 1999
515              
516             =cut