File Coverage

blib/lib/WebService/ProfitBricks/Class.pm
Criterion Covered Total %
statement 54 179 30.1
branch 0 40 0.0
condition 0 12 0.0
subroutine 18 35 51.4
pod 7 8 87.5
total 79 274 28.8


line stmt bran cond sub pod time code
1             #
2             # (c) Jan Gehring
3             #
4             # vim: set ts=3 sw=3 tw=0:
5             # vim: set expandtab:
6              
7             =head1 NAME
8              
9             WebService::ProfitBricks::Class - Class helper functions
10              
11             =head1 DESCRIPTION
12              
13             This is a module exporting some helper functions to ease the creation of objects.
14              
15             =head1 SYNOPSIS
16              
17             package My::Pkg;
18             use WebService::ProfitBricks::Class;
19            
20             has_many foo => "My::Foo";
21             belongs_to file => "My::File";
22            
23             # the constructor, to extend the provided constructor.
24             sub construct {
25             my ($self, @data) = @_;
26             }
27            
28            
29             =head1 EXPORTED FUNCTIONS
30              
31             =over 4
32              
33             =cut
34            
35             package WebService::ProfitBricks::Class;
36              
37 1     1   7 use strict;
  1         2  
  1         44  
38 1     1   6 use warnings;
  1         3  
  1         37  
39              
40 1     1   5 use Data::Dumper;
  1         2  
  1         60  
41             require Exporter;
42 1     1   6 use base qw(Exporter);
  1         2  
  1         103  
43 1     1   6 use vars qw(@EXPORT);
  1         2  
  1         560  
44              
45             @EXPORT = qw(new attrs attr does has_many belongs_to serializer pluralize);
46              
47             my %FUNC_MAP;
48              
49             $FUNC_MAP{list} = sub {
50             my ($self, $caller_pkg, $option) = @_;
51              
52             if(! exists $option->{through}) {
53             die("list: you have to define ,,through''.");
54             }
55              
56             map { $_ = $caller_pkg->new(%{ $_ }) } $self->connection->call($option->{through});
57             };
58              
59             $FUNC_MAP{find} = sub {
60             my ($self, $caller_pkg, $option, $search) = @_;
61             my $lookup_key = $option->{through};
62              
63             if(wantarray) {
64             grep { $_->$lookup_key eq $search } $self->list;
65             }
66             else {
67             [ grep { $_->$lookup_key eq $search } $self->list ]->[0];
68             }
69              
70             };
71              
72             =item new(%data)
73              
74             A common constructor. It accepts an hash (key, values pairs) and stores this hash. If you need to do more, you can create a function I.
75              
76             =cut
77             sub new {
78 0     0 1   my $that = shift;
79 0   0       my $proto = ref($that) || $that;
80              
81 0 0         my $self = ref($that) ? $that : {};
82              
83              
84 0           eval {
85 0 0         if($proto->SUPER) {
86 0           $self = $proto->SUPER::new(@_);
87             }
88             };
89              
90 0           bless($self, $proto);
91              
92 0           $self->set_data({ @_ });
93              
94 0           eval {
95 0           $self->construct(@_);
96             };
97              
98 0           return $self;
99             }
100              
101             =item has_many($what, $class, $options)
102              
103             Create a relations to $class over $what.
104              
105             =cut
106             sub has_many {
107 0     0 1   my ($what, $pkg_class, $options) = @_;
108              
109             # disable warnings
110 1     1   7 no warnings;
  1         2  
  1         141  
111              
112 0           my $what_pl = pluralize($what);
113              
114 0           my ($caller_pkg) = caller;
115 0   0       my $through = $options->{through} || $what;
116              
117 0           eval "use $pkg_class";
118 0 0         if($@) {
119 0           die("has_many: no available class: $pkg_class found.\n$@");
120             }
121              
122 1     1   6 no strict 'refs';
  1         3  
  1         610  
123              
124 0           my @old_relations = $caller_pkg->get_relations();
125              
126 0           *{ $caller_pkg . "::get_relations" } = sub {
127 0     0     my ($self) = @_;
128 0           return ({name => $what, through => $through}, @old_relations);
129 0           };
130              
131             # function to get related objects
132 0           *{ $caller_pkg . "::" . $what_pl } = sub {
133 0     0     my ($self) = @_;
134              
135 0           my $current_data = $self->get_data;
136              
137 0           my @data;
138             #print Dumper($self);
139 0 0         if(ref($through) eq "CODE") {
140 0           @data = &{ $through }($self);
  0            
141             }
142             else {
143             # if only one element is in the relation, it will be not a arrayRef...
144 0 0         if(ref($current_data->{$through}) eq "HASH") {
145 0           $current_data->{$through} = [ $current_data->{$through} ];
146             }
147              
148 0 0         @data = @{ $current_data->{$through} || [] };
  0            
149             }
150              
151             # only create a new object if $_ is a hashref
152 0 0         return map { if(ref($_) eq "HASH") { $_ = $pkg_class->new(%{ $_ }) } else { $_ } } @data;
  0            
  0            
  0            
  0            
153 0           };
154              
155             # function to add related objects
156 0           *{ $caller_pkg . "::" . $what } = sub {
157 0     0     my ($self) = @_;
158              
159 0           my ($pkg_name) = [ split(/::/, ref($self)) ]->[-1];
160 0           my $get_data_func_key = lcfirst($pkg_name) . "Id";
161              
162 0           my $obj = $pkg_class->new($get_data_func_key => $self->$get_data_func_key);
163              
164 0 0         if(ref($self->{__data__}->{$through}) eq "HASH") {
165 0           $self->{__data__}->{$through} = [ $self->{__data__}->{$through} ];
166             }
167              
168 0           push(@{ $self->{__data__}->{$through} }, $obj);
  0            
169 0           return $obj;
170 0           };
171              
172 1     1   8 use strict;
  1         2  
  1         161  
173             }
174              
175             =item belongs_to($what, $class, $options)
176              
177             Creates a backward relaion to $class.
178              
179             =cut
180             sub belongs_to {
181 0     0 1   my ($what, $pkg_class, $options) = @_;
182              
183 0           my ($caller_pkg) = caller;
184 0   0       my $through = $options->{through} || $what;
185              
186 0           eval "use $pkg_class";
187 0 0         if($@) {
188 0           die("belongs_to: no available class: $pkg_class found.\n$@");
189             }
190              
191 1     1   6 no strict 'refs';
  1         2  
  1         98  
192              
193 0           *{ $caller_pkg . "::" . $what } = sub {
194 0     0     my ($self) = @_;
195 0           return $pkg_class->new()->find_by_id($self->{__data__}->{$through});
196 0           };
197              
198 1     1   5 use strict;
  1         2  
  1         90  
199            
200             }
201              
202             =item does($what, $option)
203              
204             =cut
205             sub does {
206 0     0 1   my ($what, $option) = @_;
207              
208 0           my ($caller_pkg) = caller;
209              
210 1     1   6 no strict 'refs';
  1         1  
  1         140  
211              
212 0           my $code = $FUNC_MAP{$what};
213              
214 0 0         if(! $code) {
215 0           die("does: $what not valid.");
216             }
217              
218 0           *{ $caller_pkg . "::" . $what } = sub {
219 0     0     my ($self, @data) = @_;
220              
221 0 0         if(exists $option->{code}) {
222 0           $code = $option->{code};
223 0           return &$code($self, @data);
224             }
225              
226 0           return &$code($self, $caller_pkg, $option, @data);
227 0           };
228              
229 1     1   5 use strict;
  1         2  
  1         78  
230             }
231              
232             =item attr($attr, $option)
233              
234             Create a class attribute $attr.
235              
236             =cut
237             sub attr {
238 0     0 1   my ($attr, $option) = @_;
239 0           my ($caller_pkg) = caller;
240              
241 1     1   5 no strict 'refs';
  1         2  
  1         397  
242              
243 0           *{ $caller_pkg . "::" . $attr } = sub {
244 0     0     my ($self, $set) = @_;
245 0 0         if(defined $set) {
246 0           $self->{__data__}->{$attr} = $set;
247             }
248              
249 0           return $self->{__data__}->{$attr};
250 0           };
251              
252 0 0 0       if(exists $option->{searchable} && $option->{searchable}) {
253 0           my ($pkg_name) = [ split(/::/, $caller_pkg) ]->[-1];
254 0           my $find_key = lcfirst($pkg_name) . "Name";
255              
256 0 0         if(exists $option->{find_by}) {
257 0           $find_key = $option->{find_by};
258             }
259              
260 0           *{ $caller_pkg . "::find_by_" . $find_key } = sub {
261 0     0     my ($self, $find) = @_;
262              
263 0 0         if(exists $option->{through}) {
264 0           my $through = $option->{through};
265 0           my $pl = pluralize(lcfirst($pkg_name));
266 0           my @data = $self->$through->$pl();
267              
268 0 0         if(wantarray) {
269 0           return grep { $_->$find_key eq $find } @data;
  0            
270             }
271             else {
272 0           return [ grep { $_->$attr eq $find } @data ]->[0];
  0            
273             }
274             }
275             #$self->connection->call();
276 0           };
277             }
278              
279 1     1   6 use strict;
  1         1  
  1         76  
280              
281             }
282              
283             =item attrs(@attributes)
284              
285             Create multiple attributes for the class.
286              
287             =cut
288             sub attrs {
289 0     0 1   my (@has) = @_;
290 0           my ($caller_pkg) = caller;
291              
292 1     1   5 no strict 'refs';
  1         3  
  1         105  
293              
294 0           for my $attr (@has) {
295 0           *{ $caller_pkg . "::" . $attr } = sub {
296 0     0     my ($self, $set) = @_;
297 0 0         if(defined $set) {
298 0           $self->{__data__}->{$attr} = $set;
299             }
300              
301 0           return $self->{__data__}->{$attr};
302 0           };
303             }
304              
305 1     1   6 use strict;
  1         2  
  1         135  
306             }
307              
308             =item serializer($type, $options)
309              
310             Sets a serializer for the class.
311              
312             This will create a method $class->to_$type([%data]).
313              
314             =cut
315             sub serializer {
316 0     0 1   my ($type, $options) = @_;
317              
318 0           my ($caller_pkg) = caller;
319              
320 0           my $pkg_class = "WebService::ProfitBricks::Serializer::$type";
321 0           eval "use $pkg_class";
322 0 0         if($@) {
323 0           die("serializer: unknown class $pkg_class.\n$@");
324             }
325              
326 1     1   5 no strict 'refs';
  1         2  
  1         122  
327 0           *{ $caller_pkg . "::to_" . $type } = sub {
328 0     0     my ($self, %data) = @_;
329 0           my $serializer = $pkg_class->new(%{ $options });
  0            
330 0 0         if(keys %data) {
331 0           return $serializer->serialize({ %data });
332             } else
333             {
334 0           return $serializer->serialize($self->get_data);
335             }
336 0           };
337 1     1   5 use strict;
  1         2  
  1         727  
338             }
339              
340             # simple pluralize
341             sub pluralize {
342 0     0 0   my ($name) = @_;
343              
344 0 0         if($name =~ m/s$/) {
345 0           $name .= "es";
346             }
347             else {
348 0           $name .= "s";
349             }
350             }
351              
352             =back
353              
354             =cut
355              
356             "Use me, if you want to shoot your feet!";