PGObject-2.000002/000755 000765 000024 00000000000 13150035024 015245 5ustar00christraversstaff000000 000000 PGObject-2.000002/Changes000644 000765 000024 00000005666 13150034643 016563 0ustar00christraversstaff000000 000000 Revision history for PGObject 2.0.2 2017-08-25 Code cleanup Test case improvements Reduced warnings in test cases in some cases 2.0.1 2017-05-24 Fixing undeclared dependency in makefile 2.0.0 2017-05-19 Min Perl version is now 5.10 Broke the deserialization API off to PGObject::Type::Registry (included) Can now specify PGObject new registries on import Registries are now fully private and cannot be changed from outside Moved column deserialization function Redesigned type registration interface Old type registration routines deprecated Old column deserialization function removed 1.403.2 2016-11-21 Fixing matching of 'asc|desc' sort order specifiers 1.403.1 2016-11-20 Fixing issue #11: Mapper hints from helpers discarded Fix call_procedure() 'orderby' syntax errors 1.402.9 2016-02-13 Fixing warning in map 1.402.8 2015-10-10 Fixing array ref handling, and tightening up ref handling 1.402.7 2015-09-09 local $@ to hide eval failures from bleeding up 1.402.6 2014-10-09 Better exception handling 1.402.5 2014-09-07 Fixed test numbering that caused build failures 1.402.4 2014-09-05 Fixed to_db and pgobject_to_db serialization functions (+added tests) 1.402.3 2014-09-04 Supporting both the old pgobject_to_db and the new to_db methods. More code cleanup 1.402.2 2014-09-01 Code cleanup 1.402.1 2014-08-21 Better documentation of memoization uses and misuses. 1.402.0 2014-08-20 Added optional memoization of database catalog lookups. 1.4.1 2014-03-03 Fixed type instantiation bug when calling from externally with a named registry 1.4 2014-02-24 1. Added support for arrays and registered types. Note that this does not parse the array from text format and only handles an array passed to it. This paves the way for array-handling composite types, however. 2. DB_TESTING environment variable now used to control database tests, consistent with other PGObject modules. 3. MANIFEST.SKIP amended to support Mercurial 1.3 2013-11-14 1. Added get_registered() for composite type decoding 1.11 2013-06-05 1. Some additional safety checks in the database tests 1.10 2013-05-30 1. Added type registration system. 2. Added function prefixes for object types. 3. Added documentation of namespace layout. 1.01 2013-05-25 1. Minor changes to test cases to let them finish cleanly when the db is not available. 2. Minor documentation changes. 1.00 2013-05-24 First version, released on an unsuspecting world. Differences from LedgerSMB's interface include: 1. Function information is modularized into its own api 2. windowed aggs with rows unbounded preceding are supported 3. Database handle management outside scope of this module PGObject-2.000002/ignore.txt000644 000765 000024 00000000174 13130532773 017306 0ustar00christraversstaff000000 000000 blib* Makefile Makefile.old Build Build.bat _build* pm_to_blib* *.tar.gz .lwpcookies cover_db pod2htm*.tmp PGObject-* *.bak PGObject-2.000002/lib/000755 000765 000024 00000000000 13150035024 016013 5ustar00christraversstaff000000 000000 PGObject-2.000002/LICENSE000644 000765 000024 00000002417 13130532773 016271 0ustar00christraversstaff000000 000000 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.PGObject-2.000002/Makefile.PL000644 000765 000024 00000002160 13146566032 017233 0ustar00christraversstaff000000 000000 use 5.010; use strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( NAME => 'PGObject', AUTHOR => q{Chris Travers }, VERSION_FROM => 'lib/PGObject.pm', ABSTRACT_FROM => 'lib/PGObject.pm', PL_FILES => {}, ($ExtUtils::MakeMaker::VERSION >= 6.3002 ? ('LICENSE'=> 'bsd') : ()), PREREQ_PM => { 'DBD::Pg' => 2.0, 'Test::More' => 0, 'Try::Tiny' => 0, 'Test::Exception' => 0, 'Memoize' => 0, }, dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => 'PGObject-*' }, META_MERGE => { 'meta-spec' => { version => 2 }, resources => { repository => { type => 'git', url => 'https://github.com/ledgersmb/PGObject.git', web => 'https://github.com/ledgersmb/PGObject', }, }, }, ); PGObject-2.000002/MANIFEST000644 000765 000024 00000000722 13150035024 016377 0ustar00christraversstaff000000 000000 Changes ignore.txt lib/PGObject.pm lib/PGObject/Type/Registry.pm LICENSE Makefile.PL MANIFEST This list of files README README.md t/00-load.t t/01-basic_dbtests.t t/02-ordering.t t/03-legacy_registry.t t/03-registry.t t/04-registered_types.t t/boilerplate.t t/manifest.t t/pod-coverage.t t/pod.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) PGObject-2.000002/META.json000644 000765 000024 00000001515 13150035024 016670 0ustar00christraversstaff000000 000000 { "abstract" : "A toolkit integrating intelligent PostgreSQL dbs into Perl objects", "author" : [ "Chris Travers " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.150010", "license" : [ "bsd" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "PGObject", "no_index" : { "directory" : [ "t", "inc" ] }, "release_status" : "stable", "resources" : { "repository" : { "type" : "git", "url" : "https://github.com/ledgersmb/PGObject.git", "web" : "https://github.com/ledgersmb/PGObject" } }, "version" : 2.000002, "x_serialization_backend" : "JSON::PP version 2.94" } PGObject-2.000002/META.yml000644 000765 000024 00000001070 13150035024 016514 0ustar00christraversstaff000000 000000 --- abstract: 'A toolkit integrating intelligent PostgreSQL dbs into Perl objects' author: - 'Chris Travers ' build_requires: {} dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.150010' license: bsd meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: PGObject no_index: directory: - t - inc resources: repository: https://github.com/ledgersmb/PGObject.git version: '2.000002' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' PGObject-2.000002/README000644 000765 000024 00000010426 13130532773 016143 0ustar00christraversstaff000000 000000 PGObject PGObject is a module intended to be a base for object class frameworks which map PostgreSQL stored procedures to object methods in a relatively loosely coupled way. PGObject provides the bare-bones infrastructure required to make it happen. This module is primarily of interest to individuals writing such frameworks, and very little in here is likely to be used directly outside of such frameworks. The initial release, 1.0.0 is based on our six years of experience using essentially the same approach in LedgerSMB (starting with the beginnings of the 1.3 codebase in 2007). This release is largely based on the code I wrote for LedgerSMB but it cleans up and refactors such work based on the lessons learned. 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 You can also look for information at: RT, CPAN's request tracker (report bugs here) http://rt.cpan.org/NoAuth/Bugs.html?Dist=PGObject AnnoCPAN, Annotated CPAN documentation http://annocpan.org/dist/PGObject CPAN Ratings http://cpanratings.perl.org/d/PGObject Search CPAN http://search.cpan.org/dist/PGObject/ WRITING PGOBJECT-AWARE PERL CLASSES One of the powerful features of PGObject is the ability to declare methods in types which can be dynamically detected and used to serialize data for query purposes. Objects which contain a pgobject_to_db(), that method will be called and the return value used in place of the object. This can allow arbitrary types to serialize themselves in arbitrary ways. For example a date object could be set up with such a method which would export a string in yyyy-mm-dd format. An object could look up its own definition and return something like : { cast => 'dbtypename', value => '("A","List","Of","Properties")'} If a scalar is returned that is used as the serialized value. If a hashref is returned, it must follow the type format: type => variable binding type, cast => db cast type value => literal representation of type, as intelligible by DBD::Pg WRITING TOP-HALF OBJECT FRAMEWORKS FOR PGOBJECT PGObject is intended to be the database-facing side of a framework for objects. The intended structure is for three tiers of logic: 1. Database facing, low-level API's 2. Object management modules 3. Application handlers with things like database connection management. By top half, we are referring to the second tier. The third tier exists in the client application. The PGObject module provides only low-level API's in that first tier. The job of this module is to provide database function information to the upper level modules. We do not supply type information, If your top-level module needs this, please check out https://code.google.com/p/typeutils/ which could then be used via our function mapping APIs here. 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. PGObject-2.000002/README.md000644 000765 000024 00000010426 13130532773 016542 0ustar00christraversstaff000000 000000 PGObject PGObject is a module intended to be a base for object class frameworks which map PostgreSQL stored procedures to object methods in a relatively loosely coupled way. PGObject provides the bare-bones infrastructure required to make it happen. This module is primarily of interest to individuals writing such frameworks, and very little in here is likely to be used directly outside of such frameworks. The initial release, 1.0.0 is based on our six years of experience using essentially the same approach in LedgerSMB (starting with the beginnings of the 1.3 codebase in 2007). This release is largely based on the code I wrote for LedgerSMB but it cleans up and refactors such work based on the lessons learned. 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 You can also look for information at: RT, CPAN's request tracker (report bugs here) http://rt.cpan.org/NoAuth/Bugs.html?Dist=PGObject AnnoCPAN, Annotated CPAN documentation http://annocpan.org/dist/PGObject CPAN Ratings http://cpanratings.perl.org/d/PGObject Search CPAN http://search.cpan.org/dist/PGObject/ WRITING PGOBJECT-AWARE PERL CLASSES One of the powerful features of PGObject is the ability to declare methods in types which can be dynamically detected and used to serialize data for query purposes. Objects which contain a pgobject_to_db(), that method will be called and the return value used in place of the object. This can allow arbitrary types to serialize themselves in arbitrary ways. For example a date object could be set up with such a method which would export a string in yyyy-mm-dd format. An object could look up its own definition and return something like : { cast => 'dbtypename', value => '("A","List","Of","Properties")'} If a scalar is returned that is used as the serialized value. If a hashref is returned, it must follow the type format: type => variable binding type, cast => db cast type value => literal representation of type, as intelligible by DBD::Pg WRITING TOP-HALF OBJECT FRAMEWORKS FOR PGOBJECT PGObject is intended to be the database-facing side of a framework for objects. The intended structure is for three tiers of logic: 1. Database facing, low-level API's 2. Object management modules 3. Application handlers with things like database connection management. By top half, we are referring to the second tier. The third tier exists in the client application. The PGObject module provides only low-level API's in that first tier. The job of this module is to provide database function information to the upper level modules. We do not supply type information, If your top-level module needs this, please check out https://code.google.com/p/typeutils/ which could then be used via our function mapping APIs here. 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. PGObject-2.000002/t/000755 000765 000024 00000000000 13150035024 015510 5ustar00christraversstaff000000 000000 PGObject-2.000002/t/00-load.t000644 000765 000024 00000000272 13146566032 017047 0ustar00christraversstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 1; BEGIN { use_ok( 'PGObject' ) || print "Bail out!\n"; } diag( "Testing PGObject $PGObject::VERSION, Perl $], $^X" ); PGObject-2.000002/t/01-basic_dbtests.t000644 000765 000024 00000011564 13130532773 020746 0ustar00christraversstaff000000 000000 use Test::More; use DBI; use PGObject; plan skip_all => 'Not set up for db tests' unless $ENV{DB_TESTING}; # Initial setup my $dbh1 = DBI->connect('dbi:Pg:', 'postgres') ; plan skip_all => 'Needs superuser connection for this test script' unless $dbh1; plan tests => 35; $dbh1->do('CREATE DATABASE pgobject_test_db'); my $dbh = DBI->connect('dbi:Pg:dbname=pgobject_test_db', 'postgres'); $dbh->{pg_server_prepare} = 0; # Function to test. $dbh->do(' CREATE FUNCTION public.pg_object_test (in_test1 int, in_test2 text, in_test3 date) RETURNS BOOL LANGUAGE SQL AS $$ SELECT TRUE $$ '); $dbh->do('CREATE DOMAIN public.posint AS int'); $dbh->do(' CREATE FUNCTION public.pg_object_test2 (in_test1 posint, in_test2 text, in_test3 date) RETURNS BOOL LANGUAGE SQL AS $$ SELECT TRUE $$ '); # Testing function_info() my $function_info = PGObject->function_info( dbh => $dbh, funcname => 'pg_object_test' ); my $function_info2 = PGObject->function_info( dbh => $dbh, funcname => 'pg_object_test', funcschema => 'public', ); my $function_info3 = PGObject->function_info( dbh => $dbh, funcname => 'pg_object_test', funcschema => 'public', argtype1 => 'int4', argschema => 'pg_catalog', ); ok(defined $function_info, 'Got function info with default schema'); ok(defined $function_info2, 'Got function info with specified schema'); ok(defined $function_info3, 'Got function info with specified schema, first arg type'); is($function_info->{args}->[0]->{name}, 'in_test1', 'default schema, arg1 name'); is($function_info->{args}->[1]->{name}, 'in_test2', 'default schema, arg2 name'); is($function_info->{args}->[2]->{name}, 'in_test3', 'default schema, arg3 name'); is($function_info2->{args}->[0]->{name}, 'in_test1', 'specified schema, arg1 name'); is($function_info2->{args}->[1]->{name}, 'in_test2', 'specified schema, arg2 name'); is($function_info2->{args}->[2]->{name}, 'in_test3', 'specified schema, arg1 name'); is($function_info3->{args}->[0]->{name}, 'in_test1', 'specified schema and arg type, arg1 name'); is($function_info3->{args}->[1]->{name}, 'in_test2', 'specified schema and arg type, arg2 name'); is($function_info3->{args}->[2]->{name}, 'in_test3', 'specified schema and arg type, arg1 name'); is($function_info->{args}->[0]->{type}, 'integer', 'default schema, arg1 type'); is($function_info->{args}->[1]->{type}, 'text', 'default schema, arg2 type'); is($function_info->{args}->[2]->{type}, 'date', 'default schema, arg3 type'); is($function_info2->{args}->[0]->{type}, 'integer', 'specified schema, arg1 type'); is($function_info2->{args}->[1]->{type}, 'text', 'specified schema, arg2 type'); is($function_info2->{args}->[2]->{type}, 'date', 'specified schema, arg1 type'); is($function_info3->{args}->[0]->{type}, 'integer', 'specified schema/arg type, arg1 type'); is($function_info3->{args}->[1]->{type}, 'text', 'specified schema/arg type, arg2 type'); is($function_info3->{args}->[2]->{type}, 'date', 'specified schema/arg type, arg1 type'); is($function_info->{num_args}, 3, 'Number of args, default schema'); is($function_info2->{num_args}, 3, 'Number of args, specified schema'); is($function_info->{name}, 'pg_object_test', 'Func. Name, default schema'); is($function_info2->{name}, 'pg_object_test', 'Func name, specified schema'); # Testing call_procedure() my ($result1) = PGObject->call_procedure( funcname => 'pg_object_test', args => [1, 'test', '2001-01-01'], dbh => $dbh, ); my ($result2) = PGObject->call_procedure( funcname => 'pg_object_test', funcschema => 'public', args => [1, 'test', '2001-01-01'], dbh => $dbh, ); my ($result3) = PGObject->call_procedure( funcname => 'pg_object_test', args => [1, 'test', '2001-01-01'], dbh => $dbh, running_funcs => [{agg => 'count(*)', alias => 'lines'}] ); my ($result4) = PGObject->call_procedure( funcname => 'test', funcprefix => 'pg_object_', args => [1, 'test', '2001-01-01'], dbh => $dbh, ); ok(defined $result1, 'Basic call returned results, default schema'); ok(defined $result2, 'Basic call returned results, specified schema'); ok(defined $result3, 'Call returned results, default schema, windowed aggs'); ok(defined $result4, 'Prefixed call returned results, default schema'); ok($result1->{pg_object_test}, 'Correct value returned for proc result1'); ok($result2->{pg_object_test}, 'Correct value returned for proc result2'); ok($result3->{pg_object_test}, 'Correct value returned for proc result3'); ok($result4->{pg_object_test}, 'Correct value returned for proc result4'); is($result3->{lines}, 1, 'Correct running agg returned for proc result3'); ok(!$@, 'No eval failures bleeding up') or diag ("eval error bled up: $@"); $dbh->disconnect; $dbh1->do('DROP DATABASE pgobject_test_db'); $dbh1->disconnect; PGObject-2.000002/t/02-ordering.t000644 000765 000024 00000004217 13130532773 017744 0ustar00christraversstaff000000 000000 use Test::More; use DBI; use PGObject; plan skip_all => 'Not set up for db tests' unless $ENV{DB_TESTING}; # Initial setup my $dbh1 = DBI->connect('dbi:Pg:', 'postgres'); plan skip_all => 'Needs superuser connection for this test script' unless $dbh1; plan tests => 17; $dbh1->do('CREATE DATABASE pgobject_test_db'); my $dbh = DBI->connect('dbi:Pg:dbname=pgobject_test_db', 'postgres'); # Function to test: $dbh->do(q| CREATE OR REPLACE FUNCTION pgobject_order_test() RETURNS TABLE(col1 int, col2 text, col3 int) language sql as $$ SELECT 1, 'group1', 1 union select 2, 'group2', 2 union select 3, 'group1', 2 union select 4, 'group2', 1 $$; |); my @resultset = PGObject->call_procedure( # no order funcname => 'pgobject_order_test', dbh => $dbh, ); is(scalar @resultset, 4, 'Unordered call successful, returned 4 rows'); @resultset = PGObject->call_procedure( # ordered by col1 funcname => 'pgobject_order_test', dbh => $dbh, orderby => ['col1'], ); for my $num (1 .. 4){ is($resultset[$num - 1]->{col1}, $num, "simple ordering, correct result for item $num"); } @resultset = PGObject->call_procedure( # ordered by col1 funcname => 'pgobject_order_test', dbh => $dbh, orderby => ['col1 asc'], ); for my $num (1 .. 4){ is($resultset[$num - 1]->{col1}, $num, "simple explicit ordering, correct result for item $num"); } @resultset = PGObject->call_procedure( # Reverse simple order funcname => 'pgobject_order_test', dbh => $dbh, orderby => ['col1 desc'], ); for my $num (0 .. 3){ is($resultset[$num]->{col1}, 4 - $num, "simple reverse ordering, correct result for item $num"); } @resultset = PGObject->call_procedure( # Compound, complex ordering funcname => 'pgobject_order_test', dbh => $dbh, orderby => ['col2 desc', 'col3 asc'], ); my @expected = (4, 2, 1, 3); for my $num (0 .. 3){ is($resultset[$num]->{col1}, $expected[$num], "simple reverse ordering, correct result for item $num"); } # Teardown connections $dbh->disconnect; $dbh1->do('DROP DATABASE pgobject_test_db'); $dbh1->disconnect; PGObject-2.000002/t/03-legacy_registry.t000644 000765 000024 00000004345 13146566570 021343 0ustar00christraversstaff000000 000000 package Foo; sub from_db { }; # needs to exist to be a valid class for registration package Foo2; sub from_db { }; # needs to exist to be a valid class for registration package main; use Test::More tests => 14; use PGObject; use Test::Exception; lives_ok(sub {PGObject->register_type(pg_type => 'foo', perl_class => 'Foo') }, "Basic type registration"); lives_ok(sub {PGObject->register_type(pg_type => 'foo', perl_class => 'Foo')}, "Repeat type registration, same type"); throws_ok(sub {PGObject->register_type(pg_type => 'foo', perl_class => 'main')}, qr/different target/, "Repeat type registration, different type, fails"); throws_ok(sub {PGObject->register_type(pg_type => 'foo2', perl_class => 'Foobar123')}, qr/not yet loaded/, "Cannot register undefined type"); throws_ok{PGObject->register_type( pg_type => 'foo', perl_class => 'Foo2', registry => 'bar') } qr/Registry.*exist/, 'Correction exception thrown, reregistering in nonexistent registry.'; ok(PGObject->unregister_type(pg_type => 'foo'), 'Unregister type, try 1'); dies_ok(sub {PGObject->unregister_type(pg_type => 'foo')}, 'Unregister type, try 2'); is(PGObject->register_type(pg_type => 'foo', perl_class => 'Foo2'), 1, "Repeat type registration, different type, succeeds now"); throws_ok{PGObject->unregister_type( pg_type => 'foo', registry => 'bar') } qr/Registry.*exist/, 'Correction exception thrown, unregistering in nonexisting registry.'; lives_ok(sub {PGObject->new_registry('bar') }, 'new registry succeeds first try'); lives_ok(sub {PGObject->new_registry('bar') }, 'new registry already exists, lives'); is(PGObject->register_type( pg_type => 'foo', perl_class => 'Foo', registry => 'bar' ), 1, "Basic type registration"); is(PGObject->register_type( pg_type => 'foo', perl_class => 'Foo', registry => 'bar' ), 1, "Repeat type registration, same type"); dies_ok( sub {PGObject->register_type( pg_type => 'foo', perl_class => 'Foo2', registry => 'bar' ) }, "Repeat type registration, different type, fails"); my $test_registry = { default => { foo => 'Foo2', }, bar => { foo => 'Foo', }, }; PGObject-2.000002/t/03-registry.t000644 000765 000024 00000003715 13146566411 020011 0ustar00christraversstaff000000 000000 package Serializer; sub from_db { my ($pkg, $dbstring, $dbtype) = @_; return 4 unless $dbtype; return $dbtype; } package main; use Test::More tests => 11; use PGObject::Type::Registry; use Test::Exception; lives_ok {PGObject::Type::Registry->register_type( registry => 'default', dbtype => 'foo', apptype => 'Serializer') }, "Basic type registration"; lives_ok {PGObject::Type::Registry->register_type( registry => 'default', dbtype => 'foo', apptype => 'Serializer') }, "Repeat type registration"; throws_ok { PGObject::Type::Registry->register_type( registry => 'default', dbtype => 'foo', apptype => 'main') } qr/different target/, "Repeat type registration, different type, fails"; throws_ok {PGObject::Type::Registry->register_type( registry => 'default', dbtype => 'foo2', apptype => 'Foobar') } qr/not yet loaded/, "Cannot register undefined type"; throws_ok{PGObject::Type::Registry->register_type( registry => 'foo', dbtype => 'foo', apptype => 'PGObject') } qr/Registry.*exist/, 'Correction exception thrown, reregistering in nonexistent registry.'; lives_ok { PGObject::Type::Registry->new_registry('foo') }, 'Created registry'; is (PGObject::Type::Registry->deserialize( registry => 'foo', 'dbtype' => 'test', 'dbstring' => '10000'), 10000, 'Deserialization of unregisterd type returns input straight'); lives_ok { PGObject::Type::Registry->register_type( registry => 'foo', dbtype => 'test', apptype => 'Serializer') }, 'registering serializer'; is (PGObject::Type::Registry->deserialize( registry => 'foo', 'dbtype' => 'test', 'dbstring' => '10000'), 'test', 'Deserialization of registerd type returns from_db'); is_deeply([sort {$a cmp $b} qw(foo default)], [sort {$a cmp $b} PGObject::Type::Registry->list()], 'Registry as expected'); is(PGObject::Type::Registry->inspect('foo')->{test}, 'Serializer', "Correct inspection behavior"); PGObject-2.000002/t/04-registered_types.t000644 000765 000024 00000006742 13130532773 021523 0ustar00christraversstaff000000 000000 use Test::More tests => 18; use Test::Exception; use DBI; use PGObject 'test1', 'test2'; ok(PGObject::Type::Registry->inspect('test1'), 'test1 registry exists'); ok(PGObject::Type::Registry->inspect('test2'), 'test2 registry exists'); lives_ok {PGObject->new_registry('test1') } 'New registry 1 recreation lives'; lives_ok {PGObject->new_registry('blank') } 'New registry blank created'; lives_ok {PGObject->new_registry('test2') } 'New registry 2 recreation lives'; is(PGObject->register_type(pg_type => 'int4', perl_class => 'test1'), 1, "Basic type registration"); is(PGObject->register_type( pg_type => 'int4', perl_class => 'test2', registry => 'test1'), 1, "Basic type registration"); SKIP: { skip 'No database connection', 11 unless $ENV{DB_TESTING}; # Initial db setup my $dbh1 = DBI->connect('dbi:Pg:', 'postgres') ; $dbh1->do('CREATE DATABASE pgobject_test_db') if $dbh1; my $dbh = DBI->connect('dbi:Pg:dbname=pgobject_test_db', 'postgres') if $dbh1; $dbh->{pg_server_prepare} = 0 if $dbh; # Functions to test. $dbh->do(' CREATE OR REPLACE FUNCTION test_serialarray(int[]) returns int[] language sql as $$ SELECT $1; $$') if $dbh; $dbh->do(' CREATE OR REPLACE FUNCTION test_serialization(int) returns int language sql as $$ SELECT $1; $$') if $dbh; $dbh->do(' CREATE OR REPLACE FUNCTION test_int() returns int language sql as $$ SELECT 1000; $$') if $dbh; $dbh->do(' CREATE OR REPLACE FUNCTION test_ints() returns int[] language sql as $$ SELECT array[1000::int, 100, 10]; $$') if $dbh; my ($result) = PGObject->call_procedure( funcname => 'test_int', args => [], dbh => $dbh, ); is($result->{test_int}, 4, 'Correct handling of override, default registry'); ($result) = PGObject->call_procedure( funcname => 'test_int', args => [], dbh => $dbh, registry => 'test1', ); is($result->{test_int}, 8, 'Correct handling of override, named registry'); ok(($result) = PGObject->call_procedure( funcname => 'test_ints', args => [], dbh => $dbh, )); for (0 .. 2) { is $result->{test_ints}->[$_], 4, "Array element $_ handled by registered type"; } ($result) = PGObject->call_procedure( funcname => 'test_int', args => [], dbh => $dbh, registry => 'test2', ); is($result->{test_int}, 1000, 'Correct handling of override, named registry with no override'); my $test = bless {}, 'test1'; ok(($result) = PGObject->call_procedure( funcname => 'test_serialization', dbh => $dbh, args => [$test], registry => 'blank', ), 'called test_serialization correctly'); is($result->{test_serialization}, 8, 'serialized to db correctly'); ok(($result) = PGObject->call_procedure( funcname => 'test_serialarray', dbh => $dbh, args => [[$test]], registry => 'blank', ), 'called test_serialization correctly'); is($result->{test_serialarray}->[0], 8, 'serialized to db correctly'); $dbh->disconnect if $dbh; $dbh1->do('DROP DATABASE pgobject_test_db') if $dbh1; $dbh1->disconnect if $dbh1; } package test1; sub from_db { my ($string, $type) = @_; return 4; } sub to_db { return 8 } package test2; sub from_db { return 8 } PGObject-2.000002/t/boilerplate.t000644 000765 000024 00000002353 13130532773 020215 0ustar00christraversstaff000000 000000 #!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.pm'); PGObject-2.000002/t/manifest.t000644 000765 000024 00000000420 13130532773 017512 0ustar00christraversstaff000000 000000 #!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-2.000002/t/pod-coverage.t000644 000765 000024 00000001047 13130532773 020265 0ustar00christraversstaff000000 000000 use 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-2.000002/t/pod.t000644 000765 000024 00000000350 13130532773 016470 0ustar00christraversstaff000000 000000 #!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-2.000002/lib/PGObject/000755 000765 000024 00000000000 13150035024 017450 5ustar00christraversstaff000000 000000 PGObject-2.000002/lib/PGObject.pm000644 000765 000024 00000051251 13150034424 020015 0ustar00christraversstaff000000 000000 =head1 NAME PGObject - A toolkit integrating intelligent PostgreSQL dbs into Perl objects =cut package PGObject; use strict; use warnings; use Carp; use Memoize; use PGObject::Type::Registry; =head1 VERSION Version 2.0.2 =cut our $VERSION = 2.000002; =head1 SYNPOSIS To use without caching: use PGObject; To use with caching: use PGObject ':cache'; To get basic info from a function my $f_info = PGObject->function_info( dbh => $dbh, funcname => $funcname, funcschema => 'public', ); To get info about a function, filtered by first argument type my $f_info = PGObject->function_info( dbh => $dbh, funcname => $funcname, funcschema => 'public', funcprefix => 'test__', objtype => 'invoice', objschema => 'public', ); To call a function with enumerated arguments my @results = PGObject->call_procedure( dbh => $dbh, funcname => $funcname, funcprefix => 'test__', funcschema => $funcname, args => [$arg1, $arg2, $arg3], ); To do the same with a running total my @results = PGObject->call_procedure( dbh => $dbh, funcname => $funcname, funcschema => $funcname, args => [$arg1, $arg2, $arg3], running_funcs => [{agg => 'sum(amount)', alias => 'running_total'}], ); =cut sub import { my @directives = @_; memoize 'function_info' if grep { $_ eq ':cache' } @directives; PGObject::Type::Registry->new_registry($_) for grep { $_ !~ /^\:/; } @directives; } =head1 DESCRIPTION PGObject contains the base routines for object management using discoverable stored procedures in PostgreSQL databases. This module contains only common functionality and support structures, and low-level API's. Most developers will want to use more functional modules which add to these functions. The overall approach here is to provide the basics for a toolkit that other modules can extend. This is thus intended to be a component for building integration between PostgreSQL user defined functions and Perl objects. Because decisions such as state handling are largely outside of the scope of this module, this module itself does not do any significant state handling. Database handles (using DBD::Pg 2.0 or later) must be passed in on every call. This decision was made in order to allow for diversity in this area, with the idea that wrapper classes would be written to implement this. =head1 FUNCTIONS =head2 clear_info_cache This function clears the info cache if this was loaded with caching enabled. The cache is also automatically cleared when a function that was run could not be found (this could be caused by updating the db). =cut sub clear_info_cache { local ($@); eval { Memoize::flush_cache('function_info') }; } =head2 function_info(%args) Arguments: =over =item dbh (required) Database handle =item funcname (required) function name =item funcschema (optional, default 'public') function schema =item funcprefix (optiona, default '') Prefix for the function. This can be useful for separating functions by class. =item argtype1 (optional) Name of first argument type. If not provided, does not filter on this criteria. =item argschema (optional) Name of first argument type's schema. If not provided defaults to 'public' =back This function looks up basic mapping information for a function. If more than one function is found, an exception is raised. This function is primarily intended to be used by packages which extend this one, in order to accomplish stored procedure to object mapping. Return data is a hashref containing the following elements: =over =item args This is an arrayref of hashrefs, each of which contains 'name' and 'type' =item name The name of the function =item num_args The number of arguments =back =cut sub function_info { my ( $self, %args ) = @_; $args{funcschema} ||= 'public'; $args{funcprefix} ||= ''; $args{funcname} = $args{funcprefix} . $args{funcname}; $args{argschema} ||= 'public'; my $dbh = $args{dbh} || croak 'No dbh provided'; my $query = qq| SELECT proname, pronargs, proargnames, string_to_array(array_to_string(proargtypes::regtype[], ' '), ' ') as argtypes FROM pg_proc JOIN pg_namespace pgn ON pgn.oid = pronamespace WHERE proname = ? AND nspname = ? |; my @queryargs = ( $args{funcname}, $args{funcschema} ); if ( $args{argtype1} ) { $query .= qq| AND (proargtypes::int[])[0] IN (select t.oid from pg_type t join pg_namespace n ON n.oid = typnamespace where typname = ? AND n.nspname = ? )|; push @queryargs, $args{argtype1}; push @queryargs, $args{argschema}; } my $sth = $dbh->prepare($query) || die $!; $sth->execute(@queryargs) || die $dbh->errstr . ": " . $query; my $ref = $sth->fetchrow_hashref('NAME_lc'); croak "transaction already aborted" if $dbh->state eq '25P02'; croak "No such function" if !$ref; croak 'Ambiguous discovery criteria' if $sth->fetchrow_hashref('NAME_lc'); my $f_args; for my $n ( @{ $ref->{proargnames} } ) { push @$f_args, { name => $n, type => shift @{ $ref->{argtypes} } }; } return { name => $ref->{proname}, num_args => $ref->{pronargs}, args => $f_args, }; } =head2 call_procedure(%args) Arguments: =over =item funcname The function name =item funcschema The schema in which the function resides =item funcprefix (optiona, default '') Prefix for the function. This can be useful for separating functions by class. =item args This is an arrayref. Each item is either a literal value, an arrayref, or a hashref of extended information. In the hashref case, the type key specifies the string to use to cast the type in, and value is the value. =item orderby The list (arrayref) of columns on output for ordering. =item running_funcs An arrayref of running windowed aggregates. Each contains two keys, namely 'agg' for the aggregate and 'alias' for the function name. These are aggregates, each one has appended 'OVER (ROWS UNBOUNDED PRECEDING)' to it. =item registry This is the name of the registry used for type conversion. It can be omitted and defaults to 'default.' Note that use of a non-standard registry currently does *not* merge changes from the default registry, so you need to reregister types in non-default registries when you create them. Please note, these aggregates are not intended to be user-supplied. Please only allow whitelisted values here or construct in a tested framework elsewhere. Because of the syntax here, there is no sql injection prevention possible at the framework level for this parameter. =back =cut sub call_procedure { my ( $self, %args ) = @_; local $@; $args{funcschema} ||= 'public'; $args{funcprefix} ||= ''; $args{funcname} = $args{funcprefix} . $args{funcname}; $args{registry} ||= 'default'; my $dbh = $args{dbh}; croak "No database handle provided" unless $dbh; croak "dbh not a database handle" unless eval { $dbh->isa('DBI::db') }; my $wf_string = ''; $wf_string = join ', ', map { $_->{agg} . ' OVER (ROWS UNBOUNDED PRECEDING) AS ' . $_->{alias} } @{ $args{running_funcs} } if $args{running_funcs}; $wf_string = ', ' . $wf_string if $wf_string; my @qargs = map { my $arg = $_; local ($@); $arg = $arg->to_db if eval { $arg->can('to_db') }; $arg = $arg->pgobject_to_db if eval { $arg->can('pgobject_to_db') }; $arg; } @{ $args{args} }; my $argstr = join ', ', map { ( ref $_ and eval { $_->{cast} } ) ? "?::$_->{cast}" : '?'; } @{ $args{args} }; my $order = ''; if ( $args{orderby} ) { $order = join( ', ', map { my $dir = undef; if (s/\s+(ASC|DESC)\s*$//i) { $dir = $1; } defined $dir ? $dbh->quote_identifier($_) . " $dir" : $dbh->quote_identifier($_); } @{ $args{orderby} } ); } my $query = qq| SELECT * $wf_string FROM | . $dbh->quote_identifier( $args{funcschema} ) . '.' . $dbh->quote_identifier( $args{funcname} ) . qq|($argstr) |; if ($order) { $query .= qq| ORDER BY $order |; } my $sth = $dbh->prepare($query) || die $!; my $place = 1; foreach my $carg (@qargs) { if ( ref($carg) =~ /HASH/ ) { $sth->bind_param( $place, $carg->{value}, { pg_type => $carg->{type} } ); } else { # This is used to support arrays of db-aware types. Long-run # I think we should merge bytea support into this framework. --CT if ( ref($carg) =~ /ARRAY/ ) { local ($@); if ( eval { $carg->[0]->can('to_db') } ) { for my $ref (@$carg) { $ref = $ref->to_db; } } } $sth->bind_param( $place, $carg ); } ++$place; } $sth->execute() || die $dbh->errstr . ": " . $query; clear_info_cache() if $dbh->state eq '42883'; # (No Such Function) my @rows = (); while ( my $row = $sth->fetchrow_hashref('NAME_lc') ) { my @types = @{ $sth->{pg_type} }; my @names = @{ $sth->{NAME_lc} }; my $i = 0; for my $type (@types) { $row->{ $names[$i] } = PGObject::Type::Registry->deserialize( registry => $args{registry}, dbtype => $type, dbstring => $row->{ $names[$i] } ); ++$i; } push @rows, $row; } return @rows; } =head2 new_registry($registry_name) Creates a new registry if it does not exist. This is useful when segments of an application must override existing type mappings. This is deprecated and throws a warning. Use PGObject::Type::Registry->new_registry($registry_name) instead. This no longer returns anything of significance. =cut sub new_registry { my ( $self, $registry_name ) = @_; carp "Deprecated use of PGObject->new_registry()"; PGObject::Type::Registry->new_registry($registry_name); } =head2 register_type(pgtype => $tname, registry => $regname, perl_class => $pm) DEPRECATED Registers a type as a class. This means that when an attribute of type $pg_type is returned, that PGObject will automatically return whatever $perl_class->from_db returns. This allows you to have a db-specific constructor for such types. The registry argument is optional and defaults to 'default' If the registry does not exist, an error is raised. if the pg_type is already registered to a different type, this returns 0. Returns 1 on success. Use PGObject::Type::Registry->register_type() instead. =cut sub register_type { carp 'Use of deprecated method register_type of PGObject module'; my ( $self, %args ) = @_; PGObject::Type::Registry->register_type( registry => $args{registry}, dbtype => $args{pg_type}, apptype => $args{perl_class} ); return 1; } =head2 unregister_type(pgtype => $tname, registry => $regname) Deprecated. Tries to unregister the type. If the type does not exist, returns 0, otherwise returns 1. This is mostly useful for when a specific type must make sure it has the slot. This is rarely desirable. It is usually better to use a subregistry instead. =cut sub unregister_type { carp 'Use of deprecated method unregister_type of PGObject'; my ( $self, %args ) = @_; $args{registry} ||= 'default'; PGObject::Type::Registry->unregister_type( registry => $args{registry}, dbtype => $args{pg_type} ); } =head1 WRITING PGOBJECT-AWARE HELPER CLASSES One of the powerful features of PGObject is the ability to declare methods in types which can be dynamically detected and used to serialize data for query purposes. Objects which contain a pgobject_to_db() or a to_db() method, that method will be called and the return value used in place of the object. This can allow arbitrary types to serialize themselves in arbitrary ways. For example a date object could be set up with such a method which would export a string in yyyy-mm-dd format. An object could look up its own definition and return something like : { cast => 'dbtypename', value => '("A","List","Of","Properties")'} If a scalar is returned that is used as the serialized value. If a hashref is returned, it must follow the type format: type => variable binding type, cast => db cast type value => literal representation of type, as intelligible by DBD::Pg =head2 REQUIRED INTERFACES Registered types MUST implement a $class->from_db function accepts the string from the database as its only argument, and returns the object of the desired type. Any type MAY present an $object->to_db() interface, requiring no arguments, and returning a valid value. These can be hashrefs as specified above, arrayrefs (converted to PostgreSQL arrays by DBD::Pg) or scalar text values. =head2 UNDERSTANDING THE REGISTRY SYSTEM Note that 2.0 moves the registry to a service module which handles both registry and deserialization of database types. This is intended to be both cleaner and more flexible than the embedded system in 1.x. The registry system allows Perl classes to "claim" PostgreSQL types within a certain domain. For example, if I want to ensure that all numeric types are turned into Math::BigFloat objects, I can build a wrapper class with appropriate interfaces, but PGObject won't know to convert numeric types to this new class, so this is what registration is for. By default, these mappings are fully global. Once a class claims a type, unless another type goes through the trouble of unregisterign the first type and making sure it gets the authoritative spot, all items of that type get turned into the appropriate Perl object types. While this is sufficient for the vast number of applications, however, there may be cases where names conflict across schemas or the like. To address this application components may create their own registries. Each registry is fully global, but application components can specify non-standard registries when calling procedures, and PGObject will use only those components registered on the non-standard registry when checking rows before output. =head3 Backwards Incompatibilities from 1.x Deserialization occurs in a context which specifies a registry. In 1.x there were no concerns about default mappings but now this triggers a warning. The most basic and frequently used portions of this have been kept but return values for registering types has changed. We no longer provide a return variable but throw an exception if the type cannot be safely registered. This follows a philosophy of throwing exceptions when guarantees cannot be met. We now throw warnings when the default registry is used. Longer-run, deserializers should use the PGObject::Type::Registry interface directly. =head1 WRITING TOP-HALF OBJECT FRAMEWORKS FOR PGOBJECT PGObject is intended to be the database-facing side of a framework for objects. The intended structure is for three tiers of logic: =over =item Database facing, low-level API's =item Object management modules =item Application handlers with things like database connection management. =back By top half, we are referring to the second tier. The third tier exists in the client application. The PGObject module provides only low-level API's in that first tier. The job of this module is to provide database function information to the upper level modules. We do not supply type information, If your top-level module needs this, please check out https://code.google.com/p/typeutils/ which could then be used via our function mapping APIs here. =head2 Safely Handling Memoization of Catalog Lookups It is important to remember, when writing PGObject top half frameworks that the catalog lookups may be memoized and may come back as a data structure. This means that changes to the structures returned from get_function_info() in this module and similar functions in other catalog-bound modules may not be safe to modify in arbitrary ways. Therefore we recommend that the return values from catalog-lookup functions are treated as immutable. Normalizing output is safe provided there are no conflicts between naming conventions. This is usually true since different naming conventions would interfere withmapping. However, there could be cases where it is not true, for example, where two different mapping modules agree on a subset of normalization conventions but differ on some details. The two might safely handle the same conventions but normalize differently resulting in conflicts of both were used. =head1 A BRIEF GUIDE TO THE NAMESPACE LAYOUT Most names underneath PGObject can be assumed to be top-half modules and modules under those can be generally assumed to be variants on those. There are, however, a few reserved names: =over =item ::Debug is reserved for debugging information. For example, functions which retrieve sources of functions, or grab diagnostics, or the like would go here. =item ::Test is reserved for test framework extensions applible only here =item ::Type is reserved for PG aware type classes. For example, one might have PGObject::Type::BigFloat for a Math::Bigfloat wrapper, or PGObject::Type::DateTime for a DateTime wrapper. =item ::Util is reserved for utility functions and classes. =back =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 You can also look for information at: =over =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 This code has been loosely based on code written for the LedgerSMB open source accounting and ERP project. While that software uses the GNU GPL v2 or later, this is my own reimplementation, based on my original contributions to that project alone, and it differs in significant ways. This being said, without LedgerSMB, this module wouldn't exist, and without the lessons learned there, and the great people who have helped make this possible, this framework would not be half of what it is today. =head1 SEE ALSO =over =item PGObject::Simple - Simple mapping of object properties to stored proc args =item PGObject::Simple::Role - Moose-enabled wrapper for PGObject::Simple =back =head1 COPYRIGHT COPYRIGHT (C) 2013-2014 Chris Travers COPYRIGHT (C) 2014-2017 The LedgerSMB Core Team Redistribution and use in source and compiled forms with or without modification, are permitted provided that the following conditions are met: =over =item Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer as the first lines of this file unmodified. =item 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. =back 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. =cut 1; PGObject-2.000002/lib/PGObject/Type/000755 000765 000024 00000000000 13150035024 020371 5ustar00christraversstaff000000 000000 PGObject-2.000002/lib/PGObject/Type/Registry.pm000644 000765 000024 00000015626 13146566032 022566 0ustar00christraversstaff000000 000000 =head1 NAME PGObject::Type::Registry - Registration of types for handing db types =head1 SYNOPSIS PGObject::Type::Registry->add_registry('myapp'); # required PGObject::Type::Registry->register_type( registry => 'myapp', dbtype => 'int4', apptype => 'PGObject::Type::BigFloat' ); # to get back a type: my $number = PGObject::Type::Registry->deserialize( registry => 'myapp', dbtype => 'int4', dbstring => '1023' ); # To get registry data: my %registry = PGObject::Type::Registry->inspect(registry => 'myapp'); =cut package PGObject::Type::Registry; use strict; use warnings; use Try::Tiny; use Carp; our $VERSION = 1.000000; my %registry = ( default => {} ); =head1 DESCRIPTION The PGObject type registry stores data for serialization and deserialization relating to the database. =head1 USE Generally we like to separate applications into their own registries so that different libraries can be used in a more harmonious way. =head1 CREATING A REGISTRY You must create a registry before using it. This is there to ensure that we make sure that subtle problems are avoided and strings returned when serialized types expected. This is idempotent and repeat calls are safe. There is no abiltiy to remove an existing registry though you can loop through and remove the existing registrations. =head2 new_registry(name) =cut sub new_registry { my ( $self, $name ) = @_; if ( not exists $registry{$name} ) { $registry{$name} = {}; } } =head1 REGISTERING A TYPE =head2 register_type Args: registry => 'default', #warning thrown if not specified dbtype => [required], #exception thrown if not specified apptype => [required], #exception thrown if not specified Use: This registers a type for use by PGObject. PGObject calls with the same registry key will serialize to this type, using the from_db method provided. from_db will be provided two arguments. The first is the string from the database and the second is the type provided. The second argument is optional and passed along for the db interface class's use. A warning is thrown if no =cut sub register_type { my ( $self, %args ) = @_; my %defaults = ( registry => 'default' ); carp 'Using default registry' unless $args{registry}; croak 'Must provide dbtype arg' unless $args{dbtype}; croak 'Must provide apptype arg' unless $args{apptype}; delete $args{registry} unless defined $args{registry}; %args = ( %defaults, %args ); croak 'Registry does not exist yet' unless exists $registry{ $args{registry} }; croak 'Type registered with different target' if exists $registry{ $args{registry} }->{ $args{dbtype} } and $registry{ $args{registry} }->{ $args{dbtype} } ne $args{apptype}; $args{apptype} =~ /^(.*)::(\w*)$/; my ( $parent, $final ) = ( $1, $2 ); $parent ||= ''; $final ||= $args{apptype}; { no strict 'refs'; $parent = "${parent}::" if $parent; croak "apptype not yet loaded ($args{apptype})" unless exists ${"::${parent}"}{"${final}::"}; croak 'apptype does not have from_db function' unless $args{apptype}->can('from_db'); } %args = ( %defaults, %args ); $registry{ $args{registry} }->{ $args{dbtype} } = $args{apptype}; } =head1 UNREGISTERING A TYPE To unregister a type, you provide the dbtype and registry information, both of which are required. Note that at that this is rarely needed. =head2 unregister_type =cut sub unregister_type { my ( $self, %args ) = @_; croak 'Must provide registry' unless $args{registry}; croak 'Must provide dbtype arg' unless $args{dbtype}; croak 'Registry does not exist yet' unless exists $registry{ $args{registry} }; croak 'Type not registered' unless $registry{ $args{registry} }->{ $args{dbtype} }; delete $registry{ $args{registry} }->{ $args{dbtype} }; } =head1 DESERIALIZING A VALUE =head2 deserialize This function deserializes a data from a db string. Mandatory args are dbtype and dbstring The registry arg should be provided but if not, a warning will be issued and 'default' will be used. This function returns the output of the from_db method. =cut sub deserialize { my ( $self, %args ) = @_; my %defaults = ( registry => 'default' ); carp 'No registry specified, using default' unless exists $args{registry}; croak "Must specify dbtype arg" unless $args{dbtype}; croak "Must specify dbstring arg" unless exists $args{dbstring}; %args = ( %defaults, %args ); my $arraytype = 0; if ( $args{dbtype} =~ /^_/ ) { $args{dbtype} =~ s/^_//; $arraytype = 1; } no strict 'refs'; return $args{dbstring} unless $registry{ $args{registry} }->{ $args{dbtype} }; return [ map { $self->deserialize( %args, dbstring => $_ ) } @{ $args{dbstring} } ] if $arraytype; return "$registry{$args{registry}}->{$args{dbtype}}"->can('from_db')->( $registry{ $args{registry} }->{ $args{dbtype} }, $args{dbstring}, $args{dbtype} ); } =head1 INSPECTING A REGISTRY Sometimes we need to see what types are registered. To do this, we can request a copy of the registry. =head2 inspect($name) $name is required. If it does not exist an exception is thrown. =cut sub inspect { my ( $self, $name ) = @_; croak 'Must specify a name' unless $name; croak 'Registry does not exist' unless exists $registry{$name}; return { %{ $registry{$name} } }; } =head2 list() Returns a list of existing registries. =cut sub list { return keys %registry; } =head1 COPYRIGHT AND LICENSE COPYRIGHT (C) 2017 The LedgerSMB Core Team Redistribution and use in source and compiled forms with or without modification, are permitted provided that the following conditions are met: =over =item Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer as the first lines of this file unmodified. =item 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. =back 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. =cut 1;