File Coverage

blib/lib/PGObject/Util/DBMethod.pm
Criterion Covered Total %
statement 57 57 100.0
branch 20 24 83.3
condition 2 3 66.6
subroutine 9 9 100.0
pod 1 1 100.0
total 89 94 94.6


line stmt bran cond sub pod time code
1             package PGObject::Util::DBMethod;
2              
3 3     3   15100 use 5.008;
  3         12  
4 3     3   17 use strict;
  3         7  
  3         58  
5 3     3   15 use warnings;
  3         13  
  3         80  
6 3     3   16 use Exporter 'import';
  3         6  
  3         1059  
7              
8             =head1 NAME
9              
10             PGObject::Util::DBMethod - Declarative stored procedure <-> object mappings for
11             the PGObject Framework
12              
13             =head1 VERSION
14              
15             Version 1.00.002
16              
17             =cut
18              
19             our $VERSION = '1.00.002';
20              
21              
22             =head1 SYNOPSIS
23              
24             Without PGObject::Util::DBobject, you would:
25              
26             sub mymethod {
27             my ($self) = @_;
28             return $self->call_dbmethod(funcname => 'foo');
29             }
30              
31             With this you'd do this instead:
32              
33             dbmethod mymethod => (funcname => 'foo');
34              
35             =head1 EXPORT
36              
37             This exports only dbmethod, which it always exports.
38              
39             =cut
40              
41             our @EXPORT = qw(dbmethod);
42              
43             =head1 SUBROUTINES/METHODS
44              
45             =head2 dbmethod
46              
47             use as dbmethod (name => (default_arghash))
48              
49             For example:
50              
51             package MyObject;
52             use PGObject::Utils::DBMethod;
53              
54             dbmethod save => (
55             strict_args => 0,
56             funcname => 'save_user',
57             funcschema => 'public',
58             args => { admin => 0 },
59             );
60             $MyObject->save(args => {username => 'foo', password => 'bar'});
61              
62             Special arguments are:
63              
64             =over
65              
66             =item arg_lit
67              
68             It set must point to a hashref. Used to allow mapping of function arguments
69             to arg hash elements. If this is set then funcname, funcschema, etc, cannot be
70             overwritten on the call.
71              
72             =item strict_args
73              
74             If true, args override args provided by user.
75              
76             =item returns_objects
77              
78             If true, bless returned hashrefs before returning them.
79              
80             =item merge_back
81              
82             If true, merges the first record back to the $self at the end before returning,
83             and returns $self. Note this is a copy only one layer deep which is fine for
84             the use case of merging return values from the database into the current
85             object.
86              
87             =back
88              
89             =cut
90              
91             sub dbmethod {
92 10     10 1 60 my $name = shift;
93 10         30 my %defaultargs = @_;
94 10         27 my ($target) = caller;
95              
96             my $coderef = sub {
97 11     11   2450 my $self = shift @_;
98 11         23 my %args;
99 11 100       24 if ($defaultargs{arg_list}){
100 1         5 %args = ( args => _process_args($defaultargs{arg_list}, @_) );
101             } else {
102 10         40 %args = @_;
103             }
104 11         19 for my $key (keys %{$defaultargs{args}}){
  11         41  
105             $args{args}->{$key} = $defaultargs{args}->{$key}
106 6 50 66     20 unless $args{args}->{$key} or $defaultargs{strict_args};
107             $args{args}->{$key} = $defaultargs{args}->{$key}
108 6 100       18 if $defaultargs{strict_args};
109             }
110 11         34 for my $key(keys %defaultargs){
111 39 100       417 next if grep(/^$key$/, qw(strict_args args returns_objects));
112 24 50       76 $args{$key} = $defaultargs{$key} if $defaultargs{$key};
113             }
114 11         47 my @results = $self->call_dbmethod(%args);
115 11 100       113 if ($defaultargs{returns_objects}){
116 1         3 for my $ref(@results){
117 1         6 $ref = "$target"->new(%$ref);
118             }
119             }
120 11 100       40 if ($defaultargs{merge_back}){
121 5         13 _merge($self, shift @results);
122 5         37 return $self;
123             }
124 6 100       16 return shift @results unless wantarray;
125 5         24 return @results;
126 10         38 };
127 3     3   21 no strict 'refs';
  3         8  
  3         675  
128 10         16 *{"${target}::${name}"} = $coderef;
  10         47  
129             }
130              
131             # private function _merge($dest, $src)
132             # used to merge incoming db rows to a hash ref.
133             # hash table entries in $src overwrite those in $dest.
134             # Since this is an incoming row, we can generally assume we are not having to
135             # do a deep copy.
136              
137             sub _merge {
138 5     5   12 my ($dest, $src) = @_;
139 5 100       11 if (eval {$dest->can('has') and $dest->can('extends')}){
  5 100       47  
140             # Moo or Moose. Use accessors, though better would be to just return
141             # objects in this case.
142 4         10 for my $att (keys %$src){
143 7 50       46 $dest->can($att)->($dest, $src->{$att}) if $dest->can($att);
144             }
145             } else {
146 1         6 $dest->{$_} = $src->{$_} for (keys %$src);
147             }
148             }
149              
150             # private method _process_args.
151             # first arg $arrayref of argnames
152             # after that we just pass in @_ from the function call
153             # then we return a hash with the args as specified.
154              
155             sub _process_args {
156 1     1   3 my $arglist = shift @_;
157 1         2 my @args = @_;
158              
159 1         3 my $arghref = {};
160              
161 1         2 my $maxlen = scalar @_;
162 1         2 my $it = 1;
163 1         3 for my $argname (@$arglist){
164 1 50       4 last if $it > $maxlen;
165 1         2 $arghref->{$argname} = shift @args;
166 1         3 ++$it;
167             }
168 1         3 return $arghref;
169             }
170              
171             =head1 AUTHOR
172              
173             Chris Travers, C<< >>
174              
175             =head1 BUGS
176              
177             Please report any bugs or feature requests to C, or through
178             the web interface at L. I will be notified, and then you'll
179             automatically be notified of progress on your bug as I make changes.
180              
181              
182              
183              
184             =head1 SUPPORT
185              
186             You can find documentation for this module with the perldoc command.
187              
188             perldoc PGObject::Util::DBMethod
189              
190              
191             You can also look for information at:
192              
193             =over 4
194              
195             =item * RT: CPAN's request tracker (report bugs here)
196              
197             L
198              
199             =item * AnnoCPAN: Annotated CPAN documentation
200              
201             L
202              
203             =item * CPAN Ratings
204              
205             L
206              
207             =item * Search CPAN
208              
209             L
210              
211             =back
212              
213              
214             =head1 ACKNOWLEDGEMENTS
215              
216              
217             =head1 LICENSE AND COPYRIGHT
218              
219             Copyright 2014 Chris Travers.
220              
221             This program is released under the following license: BSD
222              
223              
224             =cut
225              
226             1; # End of PGObject::Util::DBMethod