PGObject-Util-DBMethod-1.00.002/0000755000175000017500000000000013104711646017011 5ustar ehuelsmannehuelsmannPGObject-Util-DBMethod-1.00.002/lib/0000755000175000017500000000000013104711646017557 5ustar ehuelsmannehuelsmannPGObject-Util-DBMethod-1.00.002/lib/PGObject/0000755000175000017500000000000013104711646021214 5ustar ehuelsmannehuelsmannPGObject-Util-DBMethod-1.00.002/lib/PGObject/Util/0000755000175000017500000000000013104711646022131 5ustar ehuelsmannehuelsmannPGObject-Util-DBMethod-1.00.002/lib/PGObject/Util/DBMethod.pm0000644000175000017500000001222313104711554024113 0ustar ehuelsmannehuelsmannpackage PGObject::Util::DBMethod; use 5.008; use strict; use warnings; use Exporter 'import'; =head1 NAME PGObject::Util::DBMethod - Declarative stored procedure <-> object mappings for the PGObject Framework =head1 VERSION Version 1.00.002 =cut our $VERSION = '1.00.002'; =head1 SYNOPSIS Without PGObject::Util::DBobject, you would: sub mymethod { my ($self) = @_; return $self->call_dbmethod(funcname => 'foo'); } With this you'd do this instead: dbmethod mymethod => (funcname => 'foo'); =head1 EXPORT This exports only dbmethod, which it always exports. =cut our @EXPORT = qw(dbmethod); =head1 SUBROUTINES/METHODS =head2 dbmethod use as dbmethod (name => (default_arghash)) For example: package MyObject; use PGObject::Utils::DBMethod; dbmethod save => ( strict_args => 0, funcname => 'save_user', funcschema => 'public', args => { admin => 0 }, ); $MyObject->save(args => {username => 'foo', password => 'bar'}); Special arguments are: =over =item arg_lit It set must point to a hashref. Used to allow mapping of function arguments to arg hash elements. If this is set then funcname, funcschema, etc, cannot be overwritten on the call. =item strict_args If true, args override args provided by user. =item returns_objects If true, bless returned hashrefs before returning them. =item merge_back If true, merges the first record back to the $self at the end before returning, and returns $self. Note this is a copy only one layer deep which is fine for the use case of merging return values from the database into the current object. =back =cut sub dbmethod { my $name = shift; my %defaultargs = @_; my ($target) = caller; my $coderef = sub { my $self = shift @_; my %args; if ($defaultargs{arg_list}){ %args = ( args => _process_args($defaultargs{arg_list}, @_) ); } else { %args = @_; } for my $key (keys %{$defaultargs{args}}){ $args{args}->{$key} = $defaultargs{args}->{$key} unless $args{args}->{$key} or $defaultargs{strict_args}; $args{args}->{$key} = $defaultargs{args}->{$key} if $defaultargs{strict_args}; } for my $key(keys %defaultargs){ next if grep(/^$key$/, qw(strict_args args returns_objects)); $args{$key} = $defaultargs{$key} if $defaultargs{$key}; } my @results = $self->call_dbmethod(%args); if ($defaultargs{returns_objects}){ for my $ref(@results){ $ref = "$target"->new(%$ref); } } if ($defaultargs{merge_back}){ _merge($self, shift @results); return $self; } return shift @results unless wantarray; return @results; }; no strict 'refs'; *{"${target}::${name}"} = $coderef; } # private function _merge($dest, $src) # used to merge incoming db rows to a hash ref. # hash table entries in $src overwrite those in $dest. # Since this is an incoming row, we can generally assume we are not having to # do a deep copy. sub _merge { my ($dest, $src) = @_; if (eval {$dest->can('has') and $dest->can('extends')}){ # Moo or Moose. Use accessors, though better would be to just return # objects in this case. for my $att (keys %$src){ $dest->can($att)->($dest, $src->{$att}) if $dest->can($att); } } else { $dest->{$_} = $src->{$_} for (keys %$src); } } # private method _process_args. # first arg $arrayref of argnames # after that we just pass in @_ from the function call # then we return a hash with the args as specified. sub _process_args { my $arglist = shift @_; my @args = @_; my $arghref = {}; my $maxlen = scalar @_; my $it = 1; for my $argname (@$arglist){ last if $it > $maxlen; $arghref->{$argname} = shift @args; ++$it; } return $arghref; } =head1 AUTHOR Chris Travers, C<< >> =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc PGObject::Util::DBMethod You can also look for information at: =over 4 =item * RT: CPAN's request tracker (report bugs here) L =item * AnnoCPAN: Annotated CPAN documentation L =item * CPAN Ratings L =item * Search CPAN L =back =head1 ACKNOWLEDGEMENTS =head1 LICENSE AND COPYRIGHT Copyright 2014 Chris Travers. This program is released under the following license: BSD =cut 1; # End of PGObject::Util::DBMethod PGObject-Util-DBMethod-1.00.002/Makefile.PL0000644000175000017500000000125113104711417020756 0ustar ehuelsmannehuelsmannuse 5.008; use strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( NAME => 'PGObject::Util::DBMethod', AUTHOR => q{Chris Travers }, VERSION_FROM => 'lib/PGObject/Util/DBMethod.pm', ABSTRACT_FROM => 'lib/PGObject/Util/DBMethod.pm', ($ExtUtils::MakeMaker::VERSION >= 6.3002 ? ('LICENSE'=> 'BSD') : ()), PL_FILES => {}, BUILD_REQUIRES => { 'Test::More' => 0, }, MIN_PERL_VERSION => '5.008001', dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => 'PGObject-Util-DBMethod-*' }, ); PGObject-Util-DBMethod-1.00.002/MYMETA.json0000644000175000017500000000164613104711644020705 0ustar ehuelsmannehuelsmann{ "abstract" : "Declarative stored procedure <-> object mappings for the PGObject Framework", "author" : [ "Chris Travers " ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 6.98, CPAN::Meta::Converter version 2.142690", "license" : [ "bsd" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "PGObject-Util-DBMethod", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "Test::More" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "perl" : "5.008001" } } }, "release_status" : "stable", "version" : "v1.00.002" } PGObject-Util-DBMethod-1.00.002/LICENSE0000644000175000017500000000241313104711417020012 0ustar ehuelsmannehuelsmannCopyright (c) 2014, LedgerSMB All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.PGObject-Util-DBMethod-1.00.002/README0000644000175000017500000000221513104711417017665 0ustar ehuelsmannehuelsmannPGObject-Util-DBMethod This package provides syntactic sugar which allows for declarative mapping of stored procedures to supported PGObject paradigms. It is designed to work initially with PGObject::Simple, but will almost certainly be supported with PGObject::CompositeType when this is released. Please see the POD/Man page for detailed information. INSTALLATION To install this module, run the following commands: perl Makefile.PL make make test make install SUPPORT AND DOCUMENTATION After installing, you can find documentation for this module with the perldoc command. perldoc PGObject::Util::DBMethod You can also look for information at: RT, CPAN's request tracker (report bugs here) http://rt.cpan.org/NoAuth/Bugs.html?Dist=PGObject-Util-DBMethod AnnoCPAN, Annotated CPAN documentation http://annocpan.org/dist/PGObject-Util-DBMethod CPAN Ratings http://cpanratings.perl.org/d/PGObject-Util-DBMethod Search CPAN http://search.cpan.org/dist/PGObject-Util-DBMethod/ LICENSE AND COPYRIGHT Copyright (C) 2014 Chris Travers This program is released under the following license: BSD PGObject-Util-DBMethod-1.00.002/README.md0000644000175000017500000000017413104711417020266 0ustar ehuelsmannehuelsmannPGObject-Util-DBMethod ====================== Declarative syntax for database-based object methods for PGObject Framework. PGObject-Util-DBMethod-1.00.002/Changes0000644000175000017500000000122713104711524020301 0ustar ehuelsmannehuelsmannRevision history for PGObject-Util-DBMethod 1.00.002 2017-05-10 Remove MYMETA.json from distribution archive 1.00.001 2014-02-24 Bumped up required Perl version from 5.6 to 5.8 1.00 2014-02-22 Added arg_list argument to dbmethod to allow ordered lists of args to be read from the generated method's argument list. Added merge_back argument to dbmethod, to allow the method to return $self, after merging $self with the first record found. Minor tuning of Makefile.PL 0.02 2014-02-17 Added scalar return handling, so $ref = $self->mymethod returns the first row found. 0.01 2014-02-15 First version, released on an unsuspecting world. PGObject-Util-DBMethod-1.00.002/META.json0000644000175000017500000000164613104711646020441 0ustar ehuelsmannehuelsmann{ "abstract" : "Declarative stored procedure <-> object mappings for the PGObject Framework", "author" : [ "Chris Travers " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.98, CPAN::Meta::Converter version 2.142690", "license" : [ "bsd" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "PGObject-Util-DBMethod", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "Test::More" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "perl" : "5.008001" } } }, "release_status" : "stable", "version" : "v1.00.002" } PGObject-Util-DBMethod-1.00.002/TODO0000644000175000017500000000003013104711417017466 0ustar ehuelsmannehuelsmannTODO: None, at present PGObject-Util-DBMethod-1.00.002/MANIFEST0000644000175000017500000000062513104711646020145 0ustar ehuelsmannehuelsmannChanges ignore.txt lib/PGObject/Util/DBMethod.pm LICENSE Makefile.PL MANIFEST This list of files MYMETA.json README README.md t/00-load.t t/01-dbmethod.t t/02-merge-accessor.t t/boilerplate.t t/manifest.t t/pod-coverage.t t/pod.t TODO META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) PGObject-Util-DBMethod-1.00.002/ignore.txt0000644000175000017500000000020413104711417021025 0ustar ehuelsmannehuelsmannblib* Makefile Makefile.old Build Build.bat _build* pm_to_blib* *.tar.gz .lwpcookies cover_db pod2htm*.tmp PGObject-Util-DBMethod-* PGObject-Util-DBMethod-1.00.002/META.yml0000644000175000017500000000105413104711646020262 0ustar ehuelsmannehuelsmann--- abstract: 'Declarative stored procedure <-> object mappings for the PGObject Framework' author: - 'Chris Travers ' build_requires: Test::More: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.98, CPAN::Meta::Converter version 2.142690' license: bsd meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: PGObject-Util-DBMethod no_index: directory: - t - inc requires: perl: '5.008001' version: v1.00.002 PGObject-Util-DBMethod-1.00.002/t/0000755000175000017500000000000013104711646017254 5ustar ehuelsmannehuelsmannPGObject-Util-DBMethod-1.00.002/t/pod-coverage.t0000644000175000017500000000104713104711417022012 0ustar ehuelsmannehuelsmannuse strict; use warnings; use Test::More; # Ensure a recent version of Test::Pod::Coverage my $min_tpc = 1.08; eval "use Test::Pod::Coverage $min_tpc"; plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage" if $@; # Test::Pod::Coverage doesn't require a minimum Pod::Coverage version, # but older versions don't recognize some common documentation styles my $min_pc = 0.18; eval "use Pod::Coverage $min_pc"; plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" if $@; all_pod_coverage_ok(); PGObject-Util-DBMethod-1.00.002/t/00-load.t0000644000175000017500000000032013104711417020564 0ustar ehuelsmannehuelsmann#!perl -T use Test::More tests => 1; BEGIN { use_ok( 'PGObject::Util::DBMethod' ) || print "Bail out!\n"; } diag( "Testing PGObject::Util::DBMethod $PGObject::Util::DBMethod::VERSION, Perl $], $^X" ); PGObject-Util-DBMethod-1.00.002/t/01-dbmethod.t0000644000175000017500000000741313104711417021446 0ustar ehuelsmannehuelsmannpackage PGOTest; use PGObject::Util::DBMethod; sub call_dbmethod { my $self = shift @_; %args = @_; my @retarray = (\%args); return @retarray; } sub new { my ($self) = shift @_; my %args = @_; $self = \%args if %args; $self ||= {}; bless $self; } dbmethod(strictargtest => strict_args => 1, funcname => 'foo', funcschema => 'foo2', args => {id => 1} ); dbmethod(strictundefargtest => strict_args => 1, funcname => 'foo', funcschema => 'foo2', args => {id => undef} ); dbmethod nostrictargtest => ( funcname => 'foo', funcschema => 'foo2', args => {id => 1} ); dbmethod objectstest => ( returns_objects => 1, funcname => 'foo', funcschema => 'foo2', args => {id => 1} ); dbmethod mergetest => ( funcname => 'foo', funcschema => 'foo2', merge_back => 1, args => {id => 1} ); dbmethod arglisttest => ( funcname => 'foo', funcschema => 'foo', arg_list => ['id'] ); package main; use Test::More tests => 36; ok(my $test = PGOTest::new({}), 'Test object constructor success'); ok(my ($ref) = $test->strictargtest(args => {id => 2, foo => 1}), 'Strict Arg Test returned results.'); is($ref->{funcname}, 'foo', 'strict arg test, funcname correctly set'); is($ref->{funcschema}, 'foo2', 'strict arg test, funcschema correctly set'); is($ref->{args}->{id}, 1, 'strict arg test, id arg correctly set'); is($ref->{args}->{foo}, 1, 'strict arg test, foo arg correctly set'); ok(($ref) = $test->strictundefargtest(args => {id => 2, foo => 1}), 'Strict Arg Test returned results.'); is($ref->{funcname}, 'foo', 'strict arg test, funcname correctly set'); is($ref->{funcschema}, 'foo2', 'strict arg test, funcschema correctly set'); is($ref->{args}->{id}, undef, 'strict arg test, id arg correctly unset'); is($ref->{args}->{foo}, 1, 'strict arg test, foo arg correctly set'); ok($ref = $test->strictundefargtest(args => {id => 2, foo => 1}), 'Strict Arg Test returned results, scalar context.'); is($ref->{funcname}, 'foo', 'strict arg test (scalar), funcname correctly set'); is($ref->{funcschema}, 'foo2', 'strict arg test (scalar), funcschema correctly set'); is($ref->{args}->{id}, undef, 'strict arg test (scalar), id arg correctly unset'); is($ref->{args}->{foo}, 1, 'strict arg test (scalar), foo arg correctly set'); ok(($ref) = $test->nostrictargtest(args => {id => 2, foo => 1}), 'No Strict Arg Test returned results.'); is($ref->{funcname}, 'foo', 'no strict arg test, funcname correctly set'); is($ref->{funcschema}, 'foo2', 'no strict arg test, funcschema correctly set'); is($ref->{args}->{id}, 2, 'no strict arg test, id arg correctly set'); is($ref->{args}->{foo}, 1, 'no strict arg test, foo arg correctly set'); ok(($ref) = $test->objectstest(args => {id => 2, foo => 1}), 'Objects Test returned results.'); is($ref->{funcname}, 'foo', 'no strict arg test, funcname correctly set'); is($ref->{funcschema}, 'foo2', 'no strict arg test, funcschema correctly set'); is($ref->{args}->{id}, 2, 'no strict arg test, id arg correctly set'); is($ref->{args}->{foo}, 1, 'no strict arg test, foo arg correctly set'); isa_ok($ref, 'PGOTest', 'Return reference is blessed'); ok $ref = $test->mergetest(args => {id2 => 1}), 'merge test successfully returned'; is $test->{funcname}, 'foo', 'merge test merged funcname'; is $test->{funcschema}, 'foo2', 'merge test merged funcschema'; is $test->{args}->{id2}, 1, 'Merged args id2'; is $test->{args}->{id}, 1, 'Merged args id from arg'; ok(($ref) = $test->arglisttest(1), 'Arg List Test returned results.'); is($ref->{funcname}, 'foo', 'no strict arg test, funcname correctly set'); is($ref->{funcschema}, 'foo', 'no strict arg test, funcschema correctly set'); is($ref->{args}->{id}, 1, 'no strict arg test, id arg correctly set'); PGObject-Util-DBMethod-1.00.002/t/boilerplate.t0000644000175000017500000000236613104711417021746 0ustar ehuelsmannehuelsmann#!perl -T use 5.006; use strict; use warnings; use Test::More tests => 3; sub not_in_file_ok { my ($filename, %regex) = @_; open( my $fh, '<', $filename ) or die "couldn't open $filename for reading: $!"; my %violated; while (my $line = <$fh>) { while (my ($desc, $regex) = each %regex) { if ($line =~ $regex) { push @{$violated{$desc}||=[]}, $.; } } } if (%violated) { fail("$filename contains boilerplate text"); diag "$_ appears on lines @{$violated{$_}}" for keys %violated; } else { pass("$filename contains no boilerplate text"); } } sub module_boilerplate_ok { my ($module) = @_; not_in_file_ok($module => 'the great new $MODULENAME' => qr/ - The great new /, 'boilerplate description' => qr/Quick summary of what the module/, 'stub function definition' => qr/function[12]/, ); } not_in_file_ok(README => "The README is used..." => qr/The README is used/, "'version information here'" => qr/to provide version information/, ); not_in_file_ok(Changes => "placeholder date/time" => qr(Date/time) ); module_boilerplate_ok('lib/PGObject/Util/DBMethod.pm'); PGObject-Util-DBMethod-1.00.002/t/manifest.t0000644000175000017500000000042013104711417021237 0ustar ehuelsmannehuelsmann#!perl -T use strict; use warnings; use Test::More; unless ( $ENV{RELEASE_TESTING} ) { plan( skip_all => "Author tests not required for installation" ); } eval "use Test::CheckManifest 0.9"; plan skip_all => "Test::CheckManifest 0.9 required" if $@; ok_manifest(); PGObject-Util-DBMethod-1.00.002/t/pod.t0000644000175000017500000000035013104711417020215 0ustar ehuelsmannehuelsmann#!perl -T use strict; use warnings; use Test::More; # Ensure a recent version of Test::Pod my $min_tp = 1.22; eval "use Test::Pod $min_tp"; plan skip_all => "Test::Pod $min_tp required for testing POD" if $@; all_pod_files_ok(); PGObject-Util-DBMethod-1.00.002/t/02-merge-accessor.t0000644000175000017500000000275613104711417022565 0ustar ehuelsmannehuelsmannpackage FakeMoo; use PGObject::Util::DBMethod; sub new { return bless { myobjtype => 'FakeMoo' }; } sub has { return 1; } sub extends { return 1; } sub id { my ($self, $id) = @_; $self->{id} = $id; } sub foo { my ($self, $foo) = @_; $self->{foo} = $foo; } my $funcreturns = { foo => { id => 1, foo => 2 }, bar => { id => 2, foo => 'foo123'}, baz => { id => 4 }, foobar => { id => 3, foo => undef }, }; sub call_dbmethod { my $self = shift; my %args = @_; return $funcreturns->{$args{funcname}}; } dbmethod fooz => (merge_back => 1, funcname => 'foo'); dbmethod bar => (merge_back => 1, funcname => 'bar'); dbmethod baz => (merge_back => 1, funcname => 'baz'); dbmethod foobar => (merge_back => 1, funcname => 'foobar'); package main; use Test::More tests => 16; ok $obj = FakeMoo->new, 'Fake Moo-like object created for accessor testing'; is $obj->{myobjtype}, 'FakeMoo', 'Object is expected type'; is $obj->{id}, undef, 'ID not yet set'; is $obj->{foo}, undef, 'foo not yet set'; ok $obj->fooz, 'Successfully ran fooz method'; is $obj->{id}, 1, 'ID now 1'; is $obj->{foo}, 2, 'foo now 2'; ok $obj->bar, 'Successfully ran bar method'; is $obj->{id}, 2, 'ID now 2'; is $obj->{foo}, 'foo123', 'foo now 123'; ok $obj->baz, 'Successfully ran baz method'; is $obj->{id}, 4, 'ID now 4'; is $obj->{foo}, 'foo123', 'foo unchanged'; ok $obj->foobar, 'Successfully ran foobar method'; is $obj->{id}, 3, 'ID now 3'; is $obj->{foo}, undef, 'foo now undef again';