[libpgobject-simple-role-perl] 01/03: Imported Upstream version 1.01
Robert James Clay
jame at rocasa.us
Tue Apr 15 02:29:36 UTC 2014
This is an automated email from the git hooks/post-receive script.
jame-guest pushed a commit to branch master
in repository libpgobject-simple-role-perl.
commit b437b8a253e9e4c4dad0625710a8ed3eb06ea71b
Author: Robert James Clay <jame at rocasa.us>
Date: Mon Apr 14 22:22:54 2014 -0400
Imported Upstream version 1.01
---
Changes | 32 +++++++++
LICENSE | 23 ++++++
MANIFEST | 5 ++
MANIFEST.SKIP | 45 ++++++++++++
META.json | 4 +-
META.yml | 4 +-
META.json => MYMETA.json | 6 +-
Makefile.PL | 0
README | 38 +++++++---
README.md | 73 +++++++++++++++++++
TODO | 3 +
ignore.txt | 0
lib/PGObject/Simple/Role.pm | 169 ++++++++++++++++++++++++++++++++++++++------
t/01-basic-constructor.t | 4 +-
t/02-dbtests.t | 60 ++++++++++++++--
15 files changed, 422 insertions(+), 44 deletions(-)
diff --git a/Changes b/Changes
old mode 100644
new mode 100755
index 62aff82..b8590a9
--- a/Changes
+++ b/Changes
@@ -1,5 +1,37 @@
Revision history for PGObject-Simple-Role
+1.01 2014-02-25
+ Handling of per-class default schemas
+
+1.00 2014-02-18
+ Correct handling of lazy attributes
+ Removed dbmethod() and documented why
+ Contextual return of results so scalars return first row.
+
+0.71 2014-02-15
+ Fixed Makefile.PL to ensure proper dependencies
+
+0.70 2014-02-15
+ dbmethod() refactored so it is usable by libraries other than this one,
+ is better tested, and more general. Use of the export here is now
+ deprecated.
+
+0.52 2014-01-14
+ Fixed funcprefix handling with call_procedure
+
+0.51 2013-11-20
+ Fixed inability to push funcprefix through to PGObject::Simple
+
+0.50 2013-11-13
+ Refactored to centralize logic in PGObject::Simple
+ Added dbmethod() for declaratively defining database methods.
+
+0.13 2013-11-06
+ Fixed test cases requiring Carp::Always, which was not in makefile.
+
+0.12 2013-11-05
+ call_procedure can now be called on subclasses by package name if
+ desired.
0.11 2013-05-31
Fixed an issue with the Makefile not reporting Moo::Role as a dependency
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..5de41ee
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,23 @@
+Copyright (c) 2013, Chris Travers
+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.
\ No newline at end of file
diff --git a/MANIFEST b/MANIFEST
index a7e94a5..9d66730 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -1,9 +1,13 @@
Changes
ignore.txt
lib/PGObject/Simple/Role.pm
+LICENSE
Makefile.PL
MANIFEST This list of files
+MANIFEST.SKIP
+MYMETA.json
README
+README.md
t/00-load.t
t/01-basic-constructor.t
t/02-dbtests.t
@@ -11,5 +15,6 @@ 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)
diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP
new file mode 100644
index 0000000..4da46a8
--- /dev/null
+++ b/MANIFEST.SKIP
@@ -0,0 +1,45 @@
+
+#!start included /usr/lib/perl5/5.10/ExtUtils/MANIFEST.SKIP
+# Avoid version control files.
+\B\.svn\b
+\B\.hg\b
+\B\.git\b
+\B\.gitignore\b
+
+# Avoid Makemaker generated and utility files.
+\bMANIFEST\.bak
+\bMakefile$
+\bblib/
+\bMakeMaker-\d
+\bpm_to_blib\.ts$
+\bpm_to_blib$
+\bblibdirs\.ts$ # 6.18 through 6.25 generated this
+
+# Avoid Module::Build generated and utility files.
+\bBuild$
+\b_build/
+
+# Avoid temp and backup files.
+~$
+\.old$
+\#$
+\b\.#
+\.bak$
+
+# Avoid Devel::Cover files.
+\bcover_db\b
+#!end included /usr/lib/perl5/5.10/ExtUtils/MANIFEST.SKIP
+
+^extlib
+^Su-.+\.tar\.gz$
+^work
+^tmp
+\bTAGS$
+^MYMETA.yml$
+
+\bSu-[\d\.\_]+
+
+\bt_util/
+
+Debian_CPANTS.txt
+\blib/Su/Procs/
diff --git a/META.json b/META.json
index f92f704..686dda9 100644
--- a/META.json
+++ b/META.json
@@ -4,7 +4,7 @@
"Chris Travers, <chris.travers at gmail.com>"
],
"dynamic_config" : 1,
- "generated_by" : "ExtUtils::MakeMaker version 6.62, CPAN::Meta::Converter version 2.120921",
+ "generated_by" : "ExtUtils::MakeMaker version 6.6302, CPAN::Meta::Converter version 2.120921",
"license" : [
"perl_5"
],
@@ -39,5 +39,5 @@
}
},
"release_status" : "stable",
- "version" : "0.11"
+ "version" : "1.01"
}
diff --git a/META.yml b/META.yml
index c3b6bf4..840f138 100644
--- a/META.yml
+++ b/META.yml
@@ -7,7 +7,7 @@ build_requires:
configure_requires:
ExtUtils::MakeMaker: 0
dynamic_config: 1
-generated_by: 'ExtUtils::MakeMaker version 6.62, CPAN::Meta::Converter version 2.120921'
+generated_by: 'ExtUtils::MakeMaker version 6.6302, CPAN::Meta::Converter version 2.120921'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
@@ -21,4 +21,4 @@ requires:
Moo::Role: 0
PGObject::Simple: 0
Test::More: 0
-version: 0.11
+version: 1.01
diff --git a/META.json b/MYMETA.json
similarity index 85%
copy from META.json
copy to MYMETA.json
index f92f704..bc3c33f 100644
--- a/META.json
+++ b/MYMETA.json
@@ -3,8 +3,8 @@
"author" : [
"Chris Travers, <chris.travers at gmail.com>"
],
- "dynamic_config" : 1,
- "generated_by" : "ExtUtils::MakeMaker version 6.62, CPAN::Meta::Converter version 2.120921",
+ "dynamic_config" : 0,
+ "generated_by" : "ExtUtils::MakeMaker version 6.6302, CPAN::Meta::Converter version 2.120921",
"license" : [
"perl_5"
],
@@ -39,5 +39,5 @@
}
},
"release_status" : "stable",
- "version" : "0.11"
+ "version" : "1.01"
}
diff --git a/Makefile.PL b/Makefile.PL
old mode 100644
new mode 100755
diff --git a/README b/README
old mode 100644
new mode 100755
index fb24b0c..e959a9d
--- a/README
+++ b/README
@@ -1,7 +1,9 @@
PGObject-Simple-Role
-PGObject::Simple::Role is a role implementation of the PGObject::Simple
-functionality aimed at cases where the quick and dirty approach is not idea.
+PGObject::Simple::Role is a Moo/Moose mapper for minimalist PGObject framework
+(embodied in PGObject::Simple). Basically it provides a way to easily map
+stored procedures using the conventions of PGObject::Simple for Moo/Moose
+environments.
PGObject::Simple::Role is a Moo role which allows you to use this functionality
in Moo and Moose environments. The role itself makes no assumptions about
@@ -45,11 +47,27 @@ You can also look for information at:
LICENSE AND COPYRIGHT
-Copyright (C) 2013 Chris Travers,
-
-This program is free software; you can redistribute it and/or modify it
-under the terms of either: the GNU General Public License as published
-by the Free Software Foundation; or the Artistic License.
-
-See http://dev.perl.org/licenses/ for more information.
-
+Copyright (C) 2013 Chris Travers
+
+Redistribution and use in source and compiled forms with or without
+modification, are permitted provided that the following conditions are met:
+
+* Redistributions of source code (Perl) must retain the above
+ copyright notice, this list of conditions and the following disclaimer as the
+ first lines of this file unmodified.
+
+* Redistributions in compiled form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ source code, documentation, and/or other materials provided with the
+ distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE AUTHOR(S) "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 AUTHOR(S) 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.
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..e959a9d
--- /dev/null
+++ b/README.md
@@ -0,0 +1,73 @@
+PGObject-Simple-Role
+
+PGObject::Simple::Role is a Moo/Moose mapper for minimalist PGObject framework
+(embodied in PGObject::Simple). Basically it provides a way to easily map
+stored procedures using the conventions of PGObject::Simple for Moo/Moose
+environments.
+
+PGObject::Simple::Role is a Moo role which allows you to use this functionality
+in Moo and Moose environments. The role itself makes no assumptions about
+database state, but provides hooks for classes to use to retrieve or create
+database handles for their use.
+
+This module is suited to quick and easy integration of PostgreSQL stored
+procedures with Moo and Moose object models. It is quite powerful and it makes
+developing in such environments relatively easy.
+
+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::Simple::Role
+
+You can also look for information at:
+
+ RT, CPAN's request tracker (report bugs here)
+ http://rt.cpan.org/NoAuth/Bugs.html?Dist=PGObject-Simple-Role
+
+ AnnoCPAN, Annotated CPAN documentation
+ http://annocpan.org/dist/PGObject-Simple-Role
+
+ CPAN Ratings
+ http://cpanratings.perl.org/d/PGObject-Simple-Role
+
+ Search CPAN
+ http://search.cpan.org/dist/PGObject-Simple-Role/
+
+
+LICENSE AND COPYRIGHT
+
+Copyright (C) 2013 Chris Travers
+
+Redistribution and use in source and compiled forms with or without
+modification, are permitted provided that the following conditions are met:
+
+* Redistributions of source code (Perl) must retain the above
+ copyright notice, this list of conditions and the following disclaimer as the
+ first lines of this file unmodified.
+
+* Redistributions in compiled form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ source code, documentation, and/or other materials provided with the
+ distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE AUTHOR(S) "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 AUTHOR(S) 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.
diff --git a/TODO b/TODO
new file mode 100755
index 0000000..9b10477
--- /dev/null
+++ b/TODO
@@ -0,0 +1,3 @@
+TODO for 1.0:
+
+Done, just need more test cases
diff --git a/ignore.txt b/ignore.txt
old mode 100644
new mode 100755
diff --git a/lib/PGObject/Simple/Role.pm b/lib/PGObject/Simple/Role.pm
index 20b371c..e4e41d2 100644
--- a/lib/PGObject/Simple/Role.pm
+++ b/lib/PGObject/Simple/Role.pm
@@ -13,11 +13,11 @@ PGObject::Simple::Role - Moo/Moose mappers for minimalist PGObject framework
=head1 VERSION
-Version 0.11
+Version 1.01
=cut
-our $VERSION = '0.11';
+our $VERSION = '1.01';
=head1 SYNOPSIS
@@ -25,6 +25,7 @@ our $VERSION = '0.11';
Take the following (Moose) class:
package MyAPP::Foo;
+ use PGObject::Util::DBMethod;
use Moose;
with 'PGObject::Simple::Role';
@@ -36,6 +37,8 @@ Take the following (Moose) class:
sub get_dbh {
return DBI->connect('dbi:Pg:dbname=foobar');
}
+ # PGObject::Util::DBMethod exports this
+ dbmethod int => (funcname => 'foo_to_int');
And a stored procedure:
@@ -51,8 +54,13 @@ Then the following Perl code would work to invoke it:
my $foobar = MyApp->foo(id => 3, foo => 'foo', bar => 'baz', baz => 33);
$foobar->call_dbmethod(funcname => 'foo_to_int');
+The following will also work since you have the dbmethod call above:
+
+ my $int = $foobar->int;
+
The full interface of call_dbmethod and call_procedure from PGObject::Simple are
-supported.
+supported, and call_dbmethod is effectively wrapped by dbmethod(), allowing a
+declarative mapping.
=head1 DESCRIPTION
@@ -64,7 +72,7 @@ supported.
# Private attribute for database handle, not intended to be directly set.
-has _PGObject_DBH => (
+has _DBH => (
is => 'lazy',
isa => sub {
croak "Expected a database handle. Got $_[0] instead"
@@ -72,21 +80,54 @@ has _PGObject_DBH => (
},
);
-sub _build__PGObject_DBH {
+sub _build__DBH {
my ($self) = @_;
return $self->_get_dbh;
}
-has _PGObject_FuncPrefix => (is => 'lazy');
+has _Registry => (is => 'lazy');
+
+sub _build__Registry {
+ return _get_registry();
+}
+
+=head2 _get_registry
+
+This is a method the consuming classes can override in order to set the
+registry of the calls for type mapping purposes.
+
+=cut
+
+sub _get_registry{
+ return undef;
+}
+
+has _funcschema => (is => 'lazy');
+
+=head2 _get_schema
+
+Returns the default schema associated with the object.
+
+=cut
+
+sub _build__funcschema {
+ return $_[0]->_get_schema;
+}
+
+sub _get_schema {
+ return undef;
+}
-=head1 _get_prefix
+has _funcprefix => (is => 'lazy');
+
+=head2 _get_prefix
Returns string, default is an empty string, used to set a prefix for mapping
stored prcedures to an object class.
=cut
-sub _build__PGObject_FuncPrefix {
+sub _build__funcprefix {
return $_[0]->_get_prefix;
}
@@ -99,7 +140,19 @@ has _PGObject_Simple => (
);
sub _build__PGObject_Simple {
- return PGObject::Simple->new();
+ my ($self) = @_;
+ return PGObject::Simple->new() unless ref $self;
+ $self->_DBH;
+ $self->_funcprefix;
+ my $obj = PGObject::Simple->new(%$self);
+ $obj->_set_registry($self->_registry);
+ return $obj;
+}
+
+has _registry => ( is => 'lazy' );
+
+sub _build__registry {
+ return _get_registry();
}
=head2 _get_dbh
@@ -116,36 +169,110 @@ sub _get_dbh {
=head2 call_procedure
-Identical interface to PGObject::Simple->call_procedure
+Identical interface to PGObject::Simple->call_procedure.
+
+This can be used on objects or on the packages themselves. I.e.
+mypackage->call_procedure() and $myobject->call_procedure() both work.
=cut
sub call_procedure {
my $self = shift @_;
my %args = @_;
- $args{dbh} ||= $self->_PGObject_DBH;
- $args{funcprefix} = $self->_PGObject_FuncPrefix
- if not defined $args{funcprefix};
- return $self->_PGObject_Simple->call_procedure(%args);
+ my $obj = _build__PGObject_Simple($self);
+ $obj->{_DBH} = $self->_DBH if ref $self and !$args{dbh};
+ $obj->{_DBH} = "$self"->_get_dbh unless ref $self or $args{dbh};
+ if (ref $self){
+ $args{funcprefix} = $self->_funcprefix
+ unless defined $args{funcprefix} or !ref $self;
+ $args{funcschema} = $self->_funcschema
+ unless defined $args{funcschema} or !ref $self;
+ } else {
+ $args{funcprefix} = "$self"->_get_prefix
+ unless defined $args{funcprefix} or ref $self;
+ $args{funcschema} = "$self"->_get_schema
+ unless defined $args{funcschema} or ref $self;
+ }
+ my @rows = $obj->call_procedure(%args);
+ return @rows if wantarray;
+ return shift @rows;
}
=head2 call_dbmethod
Identical interface to PGObject::Simple->call_dbmethod
+This can be used on objects or on the packages themselves. I.e.
+mypackage->call_dbmethod() and $myobject->call_dbmethod() both work.
+
=cut
sub call_dbmethod {
my $self = shift @_;
my %args = @_;
- $args{dbh} ||= $self->_PGObject_DBH;
- $args{funcprefix} = $self->_PGObject_FuncPrefix
- if not defined $args{funcprefix};
- for my $key(keys %$self){
- $args{args}->{$key} = $self->{$key} unless defined $args{args}->{$key};
+ croak 'No function name provided' unless $args{funcname};
+
+ $args{dbh} = $self->_DBH if ref $self and !$args{dbh};
+ $args{dbh} = "$self"->_get_dbh() unless $args{dbh};
+ if (ref $self){
+ $args{funcprefix} = $self->_funcprefix unless defined $args{funcprefix};
+ $args{funcschema} = $self->_funcschema unless $args{funcschema};
+ } else {
+ $args{funcprefix} = "$self"->_get_prefix
+ unless defined $args{funcprefix};
+ $args{funcschema} = "$self"->_get_schema unless $args{funcschema};
}
- return $self->_PGObject_Simple->call_dbmethod(%args);
-}
+ $args{funcprefix} ||= '';
+
+ my $info = PGObject->function_info(%args);
+
+ my $dbargs = [];
+ for my $arg (@{$info->{args}}){
+ $arg->{name} =~ s/^in_//;
+ my $db_arg;
+ eval { $db_arg = $self->can($arg->{name})->($self) } if ref $self;
+ if ($args{args}->{$arg->{name}}){
+ $db_arg = $args{args}->{$arg->{name}};
+ }
+ if (eval {$db_arg->can('to_db')}){
+ $db_arg = $db_arg->to_db;
+ }
+ if ($arg->{type} eq 'bytea'){
+ $db_arg = { type => 'bytea', value => $db_arg};
+ }
+ push @$dbargs, $db_arg;
+ }
+ $args{args} = $dbargs;
+ my @rows;
+ if (ref $self){
+ @rows = $self->call_procedure(%args);
+ } else {
+ @rows = "$self"->call_procedure(%args);
+ }
+ return @rows if wantarray;
+ return shift @rows;
+}
+
+=head1 REMOVED METHODS
+
+These methods were once part of this package but have been removed due to
+the philosophy of not adding framework dependencies when an application
+dependency can work just as well.
+
+=head2 dbmethod
+
+Included in versions 0.50 - 0.71.
+
+Instead of using this directly, use:
+
+ use PGObject::Util::DBMethod;
+
+instead. Ideally this should be done in your actual class since that will
+allow you to dispense with the extra parentheses. However, if you need a
+backwards-compatible and central solution, since PGObject::Simple::Role
+generally assumes sub-roles will be created for managing db connections etc.
+you can put the use statement there and it will have the same impact as it did
+here when it was removed with the benefit of better testing.
=head1 AUTHOR
diff --git a/t/01-basic-constructor.t b/t/01-basic-constructor.t
index 34bf6f3..cde134f 100644
--- a/t/01-basic-constructor.t
+++ b/t/01-basic-constructor.t
@@ -45,9 +45,9 @@ is($obj->foo, 'test1', 'attribute foo passed');
is($obj->bar, 'test2', 'attribute bar passed');
is($obj->baz, 33, 'attribute baz passed');
ok(!defined($obj->can('biz')), 'No dbh method exists');
-throws_ok {$obj->_build__PGObject_DBH(1)} qr/Subclasses MUST set/,
+throws_ok {$obj->_build__DBH(1)} qr/Subclasses MUST set/,
'Threw exception, "Subclasses MUST set"';
lives_ok {$obj = test2->new(%args)} 'created new object without crashing';
-throws_ok {$obj->_PGObject_DBH} qr/Expected a database handle/,
+throws_ok {$obj->_DBH} qr/Expected a database handle/,
'Threw exception, "Expected a database handle"';
diff --git a/t/02-dbtests.t b/t/02-dbtests.t
index 2a1170d..1313e9a 100644
--- a/t/02-dbtests.t
+++ b/t/02-dbtests.t
@@ -7,11 +7,17 @@ has id => (is => 'ro');
has foo => (is => 'ro');
has bar => (is => 'ro');
has baz => (is => 'ro');
+has id2 => (is => 'lazy');
+
+sub _build_id2 {
+ return 10;
+}
sub _get_dbh {
return $main::dbh;
}
+
package test2;
use Moo;
@@ -36,8 +42,9 @@ package main;
use Test::More;
use Test::Exception;
use DBI;
+use PGObject::Simple;
-
+plan skip_all => 'DB_TESTING not set' unless $ENV{DB_TESTING};
# Initial setup
my $dbh1 = DBI->connect('dbi:Pg:', 'postgres');
@@ -47,11 +54,10 @@ plan skip_all => 'Needs superuser connection for this test script' unless $dbh1;
$dbh1->do('CREATE DATABASE pgobject_test_db');
-
our $dbh = DBI->connect('dbi:Pg:dbname=pgobject_test_db', 'postgres');
plan skip_all => 'No db connection' unless $dbh;
-plan tests => 8;
+plan tests => 17;
$dbh->do('
CREATE FUNCTION public.foobar (in_foo text, in_bar text, in_baz int, in_id int)
@@ -59,14 +65,50 @@ $dbh->do('
SELECT char_length($1) + char_length($2) + $3 * $4;
$$;
') ;
+$dbh->do('CREATE SCHEMA TEST');
+$dbh->do('
+ CREATE FUNCTION test.foobar (in_foo text, in_bar text, in_baz int, in_id int)
+ RETURNS int language sql as $$
+ SELECT 2*(char_length($1) + char_length($2) + $3 * $4);
+ $$;
+') ;
+$dbh->do('
+ CREATE FUNCTION public.lazy_foobar (in_foo text, in_bar text, in_baz int, in_id2 int)
+ RETURNS int language sql as $$
+ SELECT char_length($1) + char_length($2) + $3 * $4;
+ $$;
+') ;
+my ($result) = test->call_dbmethod(
+ funcname => 'foobar',
+ args => {id => 3, foo => 'test1', bar => 'test2', baz => 33},
+);
+is($result->{foobar}, 109, 'Correct Result, direct package call to call_dbmethod');
my $obj = test->new(id => 3, foo => 'test1', bar => 'test2', baz => 33);
-my ($result) = $obj->call_dbmethod(funcname => 'foobar');
+($result) = $obj->call_dbmethod(funcname => 'foobar');
is($result->{foobar}, 109, 'Correct Result, no argument overrides');
+$result = $obj->call_dbmethod(funcname => 'lazy_foobar');
+is($result->{lazy_foobar}, 340, 'Correct handling of lazy attributes');
($result) = $obj->call_procedure(funcname => 'foobar',
args => ['test1', 'testing', '3', '33']);
is($result->{foobar}, 111, 'Correct result, call_procedure');
+($result) = $obj->call_procedure(funcname => 'foobar',
+ funcschema => 'test',
+ args => ['test1', 'testing', '3', '33']);
+is($result->{foobar}, 222, 'Correct result, call_procedure');
+($result) = test->call_procedure(funcname => 'foobar',
+ args => ['test1', 'testing', '3', '33']);
+is($result->{foobar}, 111, 'Correct result, direct package call to call_procedure');
+
+$result = $obj->call_dbmethod(funcname => 'foobar');
+is(ref $result, ref {}, 'Correct result type, scalar return, no arg overrides');
+is($result->{foobar}, 109, 'Correct Result, no argument overrides, scalar return');
+$result = test->call_procedure(funcname => 'foobar',
+ args => ['test1', 'testing', '3', '33']);
+is($result->{foobar}, 111, 'Correct result, direct package call to call_procedure, scalar return');
+
+
($result) = $obj->call_dbmethod(funcname => 'foobar', args=> {baz => 1});
is($result->{foobar}, 13, 'Correct result, argument overrides');
@@ -83,6 +125,16 @@ is($result->{foobar}, 111, 'Correct result, call_procedure');
($result) = $obj->call_dbmethod(funcname => 'bar', args=> {baz => 1});
is($result->{foobar}, 13, 'Correct result, argument overrides');
+
+$obj->{_funcschema} = 'test';
+($result) = $obj->call_procedure(funcname => 'bar',
+ args => ['test1', 'testing', '3', '33']);
+
+is($result->{foobar}, 222, 'Correct result, call_procedure, set schema');
+
+($result) = $obj->call_dbmethod(funcname => 'bar', args=> {baz => 1});
+is($result->{foobar}, 26, 'Correct result, argument overrides');
+
throws_ok{$obj->call_dbmethod(funcname => 'bar', dbh => $dbh1)} qr/No such function/, 'No such function thrown using wrong db';
# Teardown connections
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libpgobject-simple-role-perl.git
More information about the Pkg-perl-cvs-commits
mailing list