File Coverage

blib/lib/Business/cXML/Object.pm
Criterion Covered Total %
statement 77 77 100.0
branch 24 24 100.0
condition 3 3 100.0
subroutine 15 15 100.0
pod 4 4 100.0
total 123 123 100.0


line stmt bran cond sub pod time code
1             =encoding utf-8
2              
3             =head1 NAME
4              
5             Business::cXML::Object - Generic cXML object
6              
7             =head1 SYNOPSIS
8              
9             package Business::cXML::YourPackage;
10             use base qw(Business::cXML::Object);
11              
12             use constant NODENAME => 'XMLNodeName';
13              
14             use constant PROPERTIES => (
15             first_name => '',
16             last_name => undef,
17             emails => [],
18             phone => undef,
19             );
20             # new(), first_name(), last_name() and emails() get/set methods will be provided automatically
21              
22             # Optionally: an e-mail is actually a Something::Email object
23             # Even more optional: a phone is actually a Something::Number with "Phone" argument
24             use constant OBJ_PROPERTIES => (
25             emails => 'Something::Email',
26             phone => [ 'Something::Number', 'Phone' ],
27             );
28              
29             =head1 DESCRIPTION
30              
31             Base class for cXML objects which represent useful data (pretty much every
32             module except L<Business::cXML> and L<Business::cXML::Transmission>).
33              
34             Declarations in I<C<PROPERTIES>> represent property names to create in new
35             instances along with their default value. A default value of C<undef> is
36             acceptable: every possible property must be explicitly declared. A default
37             value of C<[]> indicates that the property is a list instead of a single
38             value. C<can()> will behave as expected, recognizing your methods and
39             automatic property methods.
40              
41             Declare those properties which should be objects (or lists of objects) of a
42             specific class in optional I<C<OBJ_PROPERTIES>> (in addition to
43             I<C<PROPERTIES>>) to specify which class (see example in L</SYNOPSIS>). If
44             the class is actually an arrayref, the first element will be considered the
45             class name and all other elements will be passed as arguments to the class'
46             C<new()> after the value hashref argument.
47              
48             I<C<NODENAME>> will be used in cases where C<_nodeName> cannot be
49             inferred from context.
50              
51             =cut
52              
53 13     13   148945 use 5.014;
  13         45  
54 13     13   60 use strict;
  13         20  
  13         403  
55              
56              
57             use Carp;
58 13     13   81 use Clone qw(clone);
  13         26  
  13         737  
59 13     13   3637  
  13         21800  
  13         672  
60             use constant PROPERTIES => ();
61 13     13   90 use constant OBJ_PROPERTIES => ();
  13         25  
  13         755  
62 13     13   69 use constant NODENAME => 'GenericNode';
  13         21  
  13         482  
63 13     13   66  
  13         23  
  13         9742  
64             =head1 COMMON METHODS
65              
66             The following methods are automatically available in all objects which inherit
67             from this one.
68              
69             =over
70              
71             =item C<B<new>( [I<$nodename>], [I<$node>], [I<$properties>] )>
72              
73             In some cases, specifying I<$nodename> is necessary, such as when creating a
74             new multi-name object like L<Business::cXML::Amount> without a source
75             I<$node>. This sets property C<_nodeName>. Alternatively, I<C<$properties>>
76             can also contain a C<_nodeName>, which is writeable during object creation.
77              
78             L<XML::LibXML::Element> I<C<$node>> is passed to L</from_node()>.
79              
80             Hashref I<C<$properties>> is passed to L</set()>.
81              
82             =cut
83              
84             my $class = shift;
85              
86 413     413 1 437795 # Create instance
87             my $self = {
88             _nodeName => undef,
89 413         897 };
90             bless $self, $class; # $self->isa() true for 'Business::cXML::Object' and your own class, magically
91              
92 413         718 # Populate with declared default values
93             $self->{_nodeName} = clone($self->NODENAME); # First in case PROPERTIES overrides it
94             my %fields = $self->PROPERTIES;
95 413         2876 $self->{$_} = clone($fields{$_}) foreach keys %fields;
96 413         2536  
97 413         6363 # Process arguments
98             foreach (@_) {
99             if (ref($_) eq 'HASH') {
100 413         1000 $self->set(%{ $_ });
101 414 100       1224 } elsif (ref($_)) {
    100          
102 35         91 $self->{_nodeName} = $_->nodeName;
  35         187  
103             $self->from_node($_);
104 280         1367 } else {
105 280         1195 $self->{_nodeName} = $_;
106             };
107 99         189 };
108              
109             return $self;
110             }
111 413         10927  
112             =item C<B<set>( I<%properties> )>
113              
114             Batch sets all known read-write properties, safely ignoring any unknown keys.
115              
116             =cut
117              
118             my ($self, %props) = @_;
119             $self->_getset($_, $props{$_}) foreach keys %props;
120             }
121 57     57 1 26063  
122 57         236 =item C<B<copy>( I<$object> )>
123              
124             Copy data from another cXML object into our own, only considering known
125             properties. It is thus theoretically safe to copy from an object of a
126             different class. Deep structures (hashes, arrays, other objects) are cloned
127             into new copies.
128              
129             =cut
130              
131             my ($self, $other) = @_;
132             my %fields = $self->PROPERTIES;
133             foreach (keys %fields) {
134             $self->{$_} = clone($other->{$_}) if exists $other->{$_};
135 46     46 1 2431 };
136 46         203 }
137 46         148  
138 364 100       1327 =back
139              
140             The following methods are required to be provided by classes which inherit
141             from this one.
142              
143             =over
144              
145             =item C<B<from_node>( I<$node> )>
146              
147             Overwrite our internal data from what is found by traversing I<C<$node>>, a
148             L<XML::LibXML::Element>.
149              
150             =item C<B<to_node>( I<$doc> )>
151              
152             Returns an L<XML::LibXML::Element> constructed from our internal data.
153             I<C<$doc>> can be any existing L<XML::LibXML::Element> so that this method can
154             return a new detached element within the same existing document.
155              
156             =item C<B<can>( I<$methodname> )>
157              
158             L<UNIVERSAL::can()> is properly overloaded according to L</PROPERTIES> so it
159             can still safely be used.
160              
161             =cut
162              
163             my ($self, $method) = @_;
164             my $universal = UNIVERSAL::can($self, $method);
165             unless (defined $universal) {
166             my %fields = $self->PROPERTIES;
167             $universal = \&AUTOLOAD if exists $self->{$method};
168 4503     4503 1 168365 };
169 4503         11984 return $universal;
170 4503 100       7896 }
171 4502         13576  
172 4502 100       12660 =back
173              
174 4503         8645 =head1 PROPERTY METHODS
175              
176             Each property declared in I<C<PROPERTIES>> of classes which inherit from this
177             one, can be read from and written to by invoking a method of the same name.
178              
179             Calling with no arguments (perhaps not even parenthesis) returns the current
180             value.
181              
182             Calling with an argument overwrites the property and returns the new value.
183             For arrayref properties (documented with a C<[]> suffix), setting a new value
184             actually pushes a new one into the list. For properties which are objects of
185             a specific class, passing a hashref argument automatically creates a new
186             object of that class with that hashref.
187              
188             B<Example:>
189              
190             my $addr = new Business::cXML::Contact;
191              
192             $addr->name('John Smith');
193             print $addr->name; # Prints: John Smith
194              
195             $addr->emails('john1@');
196             $addr->emails('john2@');
197             print join(' ', @{ $addr->emails }); # Prints: john1@ john2@
198              
199             The following properties are automatically available in all objects which
200             inherit from this one:
201              
202             =over
203              
204             =item C<B<_nodeName>>
205              
206             Read-only name of the current cXML node.
207              
208             =back
209              
210             =cut
211              
212              
213             my ($self, $name, $val) = @_;
214              
215             return unless exists $self->{$name};
216             my %obj_fields = $self->OBJ_PROPERTIES;
217 3     3   1214  
218             if (exists($obj_fields{$name}) && ref($val) eq 'HASH') {
219             my @args;
220 1273     1273   2860 my $class;
221             if (ref($obj_fields{$name}) eq 'ARRAY') {
222 1273 100       2876 @args = @{ $obj_fields{$name} };
223 1272         3450 $class = shift(@args);
224             } else {
225 1272 100 100     3403 $class = $obj_fields{$name};
226 23         37 };
227              
228 23 100       55 unshift(@args, $val);
229 9         16 my $file = $class;
  9         27  
230 9         15 $file =~ s|::|/|g;
231             require "$file.pm";
232 14         23 $val = $class->new(@args);
233             };
234              
235 23         42 if (@_ > 2) {
236 23         33 if (ref($self->{$name}) eq 'ARRAY') {
237 23         100 push @{ $self->{$name} }, $val;
238 23         1009 } else {
239 23         128 $self->{$name} = $val;
240             };
241             };
242 1272 100       2543  
243 1187 100       2692 return $self->{$name};
244 119         196 }
  119         309  
245              
246 1068         2162 my $self = shift; # We need a clean @_ to be passed to _getset() later
247              
248             our $AUTOLOAD;
249             my $field = $AUTOLOAD;
250 1272         4989 $field =~ s/.*:://;
251             croak "Unknown method $field" unless ref $self;
252              
253             if (exists $self->{$field}) {
254 1159     1159   29037 return $self->_getset($field, @_);
255             } else {
256 1159         1467 croak qq'Can\'t locate object method "$field" via package "@{[ ref $self ]}"';
257 1159         1689 };
258 1159         4797 }
259 1159 100       2666  
260             =head1 AUTHOR
261 1158 100       2391  
262 1157         2475 Stéphane Lavergne L<https://github.com/vphantom>
263              
264 1         7 =head1 ACKNOWLEDGEMENTS
  1         98  
265              
266             Graph X Design Inc. L<https://www.gxd.ca/> sponsored this project.
267       1      
268             =head1 COPYRIGHT & LICENSE
269              
270             Copyright (c) 2017-2018 Stéphane Lavergne L<https://github.com/vphantom>
271              
272             Permission is hereby granted, free of charge, to any person obtaining a copy
273             of this software and associated documentation files (the "Software"), to deal
274             in the Software without restriction, including without limitation the rights
275             to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
276             copies of the Software, and to permit persons to whom the Software is
277             furnished to do so, subject to the following conditions:
278              
279             The above copyright notice and this permission notice shall be included in all
280             copies or substantial portions of the Software.
281              
282             THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
283             IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
284             FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
285             AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
286             LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
287             OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
288             SOFTWARE.
289             =cut
290              
291             1;