File Coverage

blib/lib/GitInsight/Obj.pm
Criterion Covered Total %
statement 28 55 50.9
branch 7 32 21.8
condition 0 15 0.0
subroutine 6 11 54.5
pod 0 3 0.0
total 41 116 35.3


line stmt bran cond sub pod time code
1             package GitInsight::Obj;
2              
3 4     4   22 use strict;
  4         13  
  4         165  
4 4     4   27 use warnings;
  4         7  
  4         128  
5 4     4   2765 use utf8;
  4         35  
  4         17  
6              
7             #use feature ();
8              
9             our $feature = eval {
10             require feature;
11             feature->import();
12             1;
13             };
14              
15              
16             # Only Perl 5.14+ requires it on demand
17 4     4   2650 use IO::Handle ();
  4         24916  
  4         698  
18              
19             # Protect subclasses using AUTOLOAD
20 0     0   0 sub DESTROY { }
21              
22             sub import {
23 4     4   8 my $class = shift;
24 4 50       18 return unless my $flag = shift;
25              
26             # Base
27 4 100 0     40 if ( $flag eq '-base' ) { $flag = $class }
  2 50       13  
    0          
28              
29             # Strict
30 2         5 elsif ( $flag eq '-strict' ) { $flag = undef }
31              
32             # Module
33             elsif ( ( my $file = $flag ) && !$flag->can('new') ) {
34 0         0 $file =~ s!::|'!/!g;
35 0         0 require "$file.pm";
36             }
37              
38             # ISA
39 4 100       12 if ($flag) {
40 2         5 my $caller = caller;
41 4     4   33 no strict 'refs';
  4         6  
  4         2180  
42 2         2 push @{"${caller}::ISA"}, $flag;
  2         21  
43 2     0   15 *{"${caller}::has"} = sub { attr( $caller, @_ ) };
  2         9  
  0         0  
44             }
45              
46             # Mojo modules are strict!
47 4         100 $_->import for qw(strict warnings utf8);
48 4 50       138 if ($feature) {
49 0           feature->import(':5.10');
50             }
51             }
52              
53             sub attr {
54 0     0 0   my ( $self, $attrs, $default ) = @_;
55 0 0 0       return unless ( my $class = ref $self || $self ) && $attrs;
      0        
56              
57 0 0 0       die 'Default has to be a code reference or constant value'
58             if ref $default && ref $default ne 'CODE';
59              
60 0 0         for my $attr ( @{ ref $attrs eq 'ARRAY' ? $attrs : [$attrs] } ) {
  0            
61 0 0         die qq{Attribute "$attr" invalid}
62             unless $attr =~ /^[a-zA-Z_]\w*$/;
63              
64             # Header (check arguments)
65 0           my $code = "package $class;\nsub $attr {\n if (\@_ == 1) {\n";
66              
67             # No default value (return value)
68 0 0         unless ( defined $default ) { $code .= " return \$_[0]{'$attr'};" }
  0            
69              
70             # Default value
71             else {
72              
73             # Return value
74 0           $code
75             .= " return \$_[0]{'$attr'} if exists \$_[0]{'$attr'};\n";
76              
77             # Return default value
78 0           $code .= " return \$_[0]{'$attr'} = ";
79 0 0         $code .=
80             ref $default eq 'CODE'
81             ? '$default->($_[0]);'
82             : '$default;';
83             }
84              
85             # Store value
86 0           $code .= "\n }\n \$_[0]{'$attr'} = \$_[1];\n";
87              
88             # Footer (return invocant)
89 0           $code .= " \$_[0];\n}";
90              
91 0 0         warn "-- Attribute $attr in $class\n$code\n\n"
92             if $ENV{GitInsight_OBJ_DEBUG};
93 0 0         die "GitInsight::Obj error: $@" unless eval "$code;1";
94             }
95             }
96              
97             sub new {
98 0     0 0   my $class = shift;
99 0 0 0       bless @_ ? @_ > 1 ? {@_} : { %{ $_[0] } } : {}, ref $class || $class;
  0 0          
100             }
101              
102             sub tap {
103 0     0 0   my ( $self, $cb ) = @_;
104 0           $_->$cb for $self;
105 0           return $self;
106             }
107              
108             1;
109             __END__
110              
111             =encoding utf8
112              
113             =head1 NAME
114              
115             GitInsight::Obj - Minimal base class for GitInsight
116              
117             =head1 SYNOPSIS
118              
119             package Cat;
120             use GitInsight::Obj -base;
121              
122             has name => 'Nyan';
123             has [qw(birds mice)] => 2;
124              
125             package Tiger;
126             use GitInsight::Obj 'Cat';
127              
128             has friend => sub { Cat->new };
129             has stripes => 42;
130              
131             package main;
132             use GitInsight::Obj -strict;
133              
134             my $mew = Cat->new(name => 'Longcat');
135             say $mew->mice;
136             say $mew->mice(3)->birds(4)->mice;
137              
138             my $rawr = Tiger->new(stripes => 23, mice => 0);
139             say $rawr->tap(sub { $_->friend->name('Tacgnol') })->mice;
140              
141             =head1 DESCRIPTION
142              
143             L is a simple base class for L, a fork of L.
144              
145             # Automatically enables "strict", "warnings", "utf8" and Perl 5.10 features
146             use GitInsight::Obj -strict;
147             use GitInsight::Obj -base;
148             use GitInsight::Obj 'SomeBaseClass';
149              
150             All three forms save a lot of typing.
151              
152             # use GitInsight::Obj -strict;
153             use strict;
154             use warnings;
155             use utf8;
156             use feature ':5.10';
157             use IO::Handle ();
158              
159             # use GitInsight::Obj -base;
160             use strict;
161             use warnings;
162             use utf8;
163             use feature ':5.10';
164             use IO::Handle ();
165             use GitInsight::Obj;
166             push @ISA, 'GitInsight::Obj';
167             sub has { GitInsight::Obj::attr(__PACKAGE__, @_) }
168              
169             # use GitInsight::Obj 'SomeBaseClass';
170             use strict;
171             use warnings;
172             use utf8;
173             use feature ':5.10';
174             use IO::Handle ();
175             require SomeBaseClass;
176             push @ISA, 'SomeBaseClass';
177             use GitInsight::Obj;
178             sub has { GitInsight::Obj::attr(__PACKAGE__, @_) }
179              
180             =head1 FUNCTIONS
181              
182             L implements the following functions like L, which can be imported with
183             the C<-base> flag or by setting a base class.
184              
185             =head2 has
186              
187             has 'name';
188             has [qw(name1 name2 name3)];
189             has name => 'foo';
190             has name => sub {...};
191             has [qw(name1 name2 name3)] => 'foo';
192             has [qw(name1 name2 name3)] => sub {...};
193              
194             Create attributes for hash-based objects, just like the L method.
195              
196             =head1 METHODS
197              
198             L implements the following methods.
199              
200             =head2 attr
201              
202             $object->attr('name');
203             BaseSubClass->attr('name');
204             BaseSubClass->attr([qw(name1 name2 name3)]);
205             BaseSubClass->attr(name => 'foo');
206             BaseSubClass->attr(name => sub {...});
207             BaseSubClass->attr([qw(name1 name2 name3)] => 'foo');
208             BaseSubClass->attr([qw(name1 name2 name3)] => sub {...});
209              
210             Create attribute accessor for hash-based objects, an array reference can be
211             used to create more than one at a time. Pass an optional second argument to
212             set a default value, it should be a constant or a callback. The callback will
213             be executed at accessor read time if there's no set value. Accessors can be
214             chained, that means they return their invocant when they are called with an
215             argument.
216              
217             =head2 new
218              
219             my $object = BaseSubClass->new;
220             my $object = BaseSubClass->new(name => 'value');
221             my $object = BaseSubClass->new({name => 'value'});
222              
223             This base class provides a basic constructor for hash-based objects. You can
224             pass it either a hash or a hash reference with attribute values.
225              
226             =head2 tap
227              
228             $object = $object->tap(sub {...});
229              
230             K combinator, tap into a method chain to perform operations on an object
231             within the chain. The object will be the first argument passed to the callback
232             and is also available as C<$_>.
233              
234             =head1 DEBUGGING
235              
236             You can set the C environment variable to get some advanced
237             diagnostics information printed to C.
238              
239             GitInsight_OBJ_DEBUG=1
240              
241             =head1 SEE ALSO
242              
243             L, L.
244              
245             =cut