[libpgobject-perl] 01/03: New upstream version 2.000001
Robert James Clay
jame at rocasa.us
Wed Jun 21 22:14:44 UTC 2017
This is an automated email from the git hooks/post-receive script.
jame-guest pushed a commit to branch master
in repository libpgobject-perl.
commit 9204111d8cbf50a197792d8f70aefb9d42d61cb9
Author: Robert James Clay <jame at rocasa.us>
Date: Wed Jun 21 18:02:12 2017 -0400
New upstream version 2.000001
---
Changes | 55 +++++++---
MANIFEST | 3 +-
META.json | 13 ++-
META.yml | 20 ++--
MYMETA.json | 46 --------
Makefile.PL | 3 +-
lib/PGObject.pm | 168 ++++++++++++------------------
lib/PGObject/Type/Registry.pm | 236 ++++++++++++++++++++++++++++++++++++++++++
t/01-basic_dbtests.t | 4 +-
t/03-legacy_registry.t | 62 +++++++++++
t/03-registry.t | 104 +++++++++----------
t/04-registered_types.t | 30 ++++--
12 files changed, 507 insertions(+), 237 deletions(-)
diff --git a/Changes b/Changes
index 72f6cbe..0d8ff1a 100644
--- a/Changes
+++ b/Changes
@@ -1,7 +1,36 @@
Revision history for PGObject
+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
+ Better exception handling
1.402.5 2014-09-07
Fixed test numbering that caused build failures
@@ -22,22 +51,22 @@ Revision history for PGObject
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.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.
+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.
+ 2. DB_TESTING environment variable now used to control database tests,
+ consistent with other PGObject modules.
- 3. MANIFEST.SKIP amended to support Mercurial
+ 3. MANIFEST.SKIP amended to support Mercurial
-1.3 2013-11-14
- 1. Added get_registered() for composite type decoding
+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
diff --git a/MANIFEST b/MANIFEST
index 87ef280..d9faba4 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -1,15 +1,16 @@
Changes
ignore.txt
lib/PGObject.pm
+lib/PGObject/Type/Registry.pm
LICENSE
Makefile.PL
MANIFEST This list of files
-MYMETA.json
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
diff --git a/META.json b/META.json
index b4cda67..c3c827c 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.72, CPAN::Meta::Converter version 2.132140",
+ "generated_by" : "ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150005",
"license" : [
"bsd"
],
@@ -25,12 +25,18 @@
"ExtUtils::MakeMaker" : "0"
}
},
+ "configure" : {
+ "requires" : {
+ "ExtUtils::MakeMaker" : "0"
+ }
+ },
"runtime" : {
"requires" : {
"DBD::Pg" : "2",
"Memoize" : "0",
"Test::Exception" : "0",
- "Test::More" : "0"
+ "Test::More" : "0",
+ "Try::Tiny" : "0"
}
}
},
@@ -42,5 +48,6 @@
"web" : "https://github.com/ledgersmb/PGObject"
}
},
- "version" : "v1.402.6"
+ "version" : 2.000001,
+ "x_serialization_backend" : "JSON::PP version 2.27400"
}
diff --git a/META.yml b/META.yml
index 2feb512..5b3abd3 100644
--- a/META.yml
+++ b/META.yml
@@ -3,23 +3,27 @@ abstract: 'A toolkit integrating intelligent PostgreSQL dbs into Perl objects'
author:
- 'Chris Travers <chris.travers at gmail.com>'
build_requires:
- ExtUtils::MakeMaker: 0
+ ExtUtils::MakeMaker: '0'
+configure_requires:
+ ExtUtils::MakeMaker: '0'
dynamic_config: 1
-generated_by: 'ExtUtils::MakeMaker version 6.72, CPAN::Meta::Converter version 2.132140'
+generated_by: 'ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150005'
license: bsd
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
- version: 1.4
+ version: '1.4'
name: PGObject
no_index:
directory:
- t
- inc
requires:
- DBD::Pg: 2
- Memoize: 0
- Test::Exception: 0
- Test::More: 0
+ DBD::Pg: '2'
+ Memoize: '0'
+ Test::Exception: '0'
+ Test::More: '0'
+ Try::Tiny: '0'
resources:
repository: https://github.com/ledgersmb/PGObject.git
-version: v1.402.6
+version: 2.000001
+x_serialization_backend: 'CPAN::Meta::YAML version 0.018'
diff --git a/MYMETA.json b/MYMETA.json
deleted file mode 100644
index ae67244..0000000
--- a/MYMETA.json
+++ /dev/null
@@ -1,46 +0,0 @@
-{
- "abstract" : "A toolkit integrating intelligent PostgreSQL dbs into Perl objects",
- "author" : [
- "Chris Travers <chris.travers at gmail.com>"
- ],
- "dynamic_config" : 0,
- "generated_by" : "ExtUtils::MakeMaker version 6.72, CPAN::Meta::Converter version 2.132140",
- "license" : [
- "bsd"
- ],
- "meta-spec" : {
- "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
- "version" : "2"
- },
- "name" : "PGObject",
- "no_index" : {
- "directory" : [
- "t",
- "inc"
- ]
- },
- "prereqs" : {
- "build" : {
- "requires" : {
- "ExtUtils::MakeMaker" : "0"
- }
- },
- "runtime" : {
- "requires" : {
- "DBD::Pg" : "2",
- "Memoize" : "0",
- "Test::Exception" : "0",
- "Test::More" : "0"
- }
- }
- },
- "release_status" : "stable",
- "resources" : {
- "repository" : {
- "type" : "git",
- "url" : "https://github.com/ledgersmb/PGObject.git",
- "web" : "https://github.com/ledgersmb/PGObject"
- }
- },
- "version" : "v1.402.6"
-}
diff --git a/Makefile.PL b/Makefile.PL
index 92c4a6f..1c1d2e4 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -1,4 +1,4 @@
-use 5.006;
+use 5.010;
use strict;
use warnings;
use ExtUtils::MakeMaker;
@@ -15,6 +15,7 @@ WriteMakefile(
PREREQ_PM => {
'DBD::Pg' => 2.0,
'Test::More' => 0,
+ 'Try::Tiny' => 0,
'Test::Exception' => 0,
'Memoize' => 0,
},
diff --git a/lib/PGObject.pm b/lib/PGObject.pm
index efedff5..b1c076e 100644
--- a/lib/PGObject.pm
+++ b/lib/PGObject.pm
@@ -7,20 +7,17 @@ PGObject - A toolkit integrating intelligent PostgreSQL dbs into Perl objects
package PGObject;
use strict;
use warnings;
+use PGObject::Type::Registry;
use Carp;
use Memoize;
=head1 VERSION
-Version 1.402.6
+Version 2.0.0
=cut
-our $VERSION = '1.402.6';
-
-my %typeregistry = (
- default => {},
-);
+our $VERSION = 2.000001;
=head1 SYNPOSIS
@@ -76,6 +73,7 @@ To do the same with a running total
sub import {
my @directives = @_;
memoize 'function_info' if grep { $_ eq ':cache' } @directives;
+ PGObject::Type::Registry->new_registry($_) for grep { $_ !~ /^\:/; } @directives;
}
=head1 DESCRIPTION
@@ -107,6 +105,7 @@ be found (this could be caused by updating the db).
=cut
sub clear_info_cache {
+ local ($@);
eval { Memoize::flush_cache('function_info') };
}
@@ -169,14 +168,13 @@ The number of arguments
=cut
sub function_info {
- my ($self) = shift @_;
- my %args = @_;
+ my ($self, %args) = @_;
$args{funcschema} ||= 'public';
$args{funcprefix} ||= '';
$args{funcname} = $args{funcprefix}.$args{funcname};
$args{argschema} ||= 'public';
- my $dbh = $args{dbh};
+ my $dbh = $args{dbh} || croak 'No dbh provided';
@@ -203,7 +201,7 @@ sub function_info {
}
my $sth = $dbh->prepare($query) || die $!;
- $sth->execute(@queryargs);
+ $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;
@@ -276,12 +274,12 @@ the framework level for this parameter.
sub call_procedure {
my ($self) = shift @_;
my %args = @_;
+ local $@;
$args{funcschema} ||= 'public';
$args{funcprefix} ||= '';
$args{funcname} = $args{funcprefix}.$args{funcname};
$args{registry} ||= 'default';
- my $registry = $typeregistry{$args{registry}};
my $dbh = $args{dbh};
croak "No database handle provided" unless $dbh;
croak "dbh not a database handle" unless eval {$dbh->isa('DBI::db')};
@@ -297,20 +295,23 @@ sub call_procedure {
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')};
- ref $arg ? $arg->{value} : $arg
+ $arg;
} @{$args{args}};
my $argstr = join ', ', map {
- (ref $_ and $_->{cast}) ? "?::$_->{cast}" : '?';
+ (ref $_ and eval { $_->{cast} } ) ? "?::$_->{cast}" : '?';
} @{$args{args}};
my $order = '';
if ($args{orderby}){
$order = join(', ', map {
- $_ =~ s/\s+(ASC|DESC)$//i;
- my $dir = $1;
+ my $dir = undef;
+ if ( s/\s+(ASC|DESC)\s*$//i ) {
+ $dir = $1;
+ }
defined $dir ? $dbh->quote_identifier($_)
. " $dir"
: $dbh->quote_identifier($_);
@@ -329,18 +330,16 @@ sub call_procedure {
my $place = 1;
- # This is needed to support byteas, which rquire special escaping during
- # the binding process. --Chris T
-
foreach my $carg (@qargs){
- if (ref($carg) eq ref {}){
+ 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) eq 'ARRAY'){
+ if (ref($carg) =~ /ARRAY/){
+ local ($@);
if (eval{$carg->[0]->can('to_db')}){
for my $ref(@$carg){
$ref = $ref->to_db;
@@ -353,7 +352,7 @@ sub call_procedure {
++$place;
}
- $sth->execute();
+ $sth->execute() || die $dbh->errstr . ": " . $query;
clear_info_cache() if $dbh->state eq '42883'; # (No Such Function)
@@ -363,8 +362,11 @@ sub call_procedure {
my @names = @{$sth->{NAME_lc}};
my $i = 0;
for my $type (@types){
- $row->{$names[$i]}
- = process_type($row->{$names[$i]}, $type, $registry);
+ $row->{$names[$i]} =
+ PGObject::Type::Registry->deserialize(
+ registry => $args{registry},
+ dbtype => $type, dbstring => $row->{$names[$i]}
+ );
++$i;
}
@@ -373,56 +375,29 @@ sub call_procedure {
return @rows;
}
-=head2 process_type($val, $type, $registry)
-
-If $type is registered, returns "$type"->from_db($val). Otherwise returns
-$val. If $val is an arrayref, loops through it for every item and strips
-trialing [] from $type.
-
-This module should generally only be used by type handlers or by this module.
-
-=cut
-
-sub process_type {
- my ($val, $type, $registry, $dbh) = @_;
-
- $registry = $typeregistry{$registry} unless ref $registry;
- # Array handling as we'd get this usually from DBD::Pg or equivalent
- if (ref $val eq ref []){
- # strangely, DBD::Pg returns, as of 2.x, the types of array types
- # as prefixed with an underscore. So we have to remove this. --CT
- $type =~ s/^\_//;
- my $newval = [];
- push @$newval, process_type($_, $type, $registry) for @$val;
- return $newval;
- }
-
- # Otherwise:
- if (defined $registry->{$type}){
- my $class = $registry->{$type};
- $val = $class->from_db($val);
- }
- return $val;
-}
-
=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.
-Returns 1 on creation, 2 if already exists.
+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) = @_;
- return 2 if defined $typeregistry{$registry_name};
- $typeregistry{$registry_name} = {};
- return 1;
+ 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
@@ -433,41 +408,25 @@ 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 = shift @_;
my %args = @_;
- $args{registry} ||= 'default';
- croak "Registry $args{registry} does not exist yet!"
- if !defined $typeregistry{$args{registry}};
- return 0 if defined $typeregistry{$args{registry}}->{$args{pg_type}}
- and $args{perl_class}
- ne $typeregistry{$args{registry}}->{$args{pg_type}};
-
- $typeregistry{$args{registry}}->{$args{pg_type}} = $args{perl_class};
- return 1;
-}
-=head2 get_registered(registry => $registry, pg_type => $pg_type)
-
-This is a public interface to the registry, which can be useful for composite
-types decoding themselves from tuple data, and so forth.
-
-=cut
-
-sub get_registered {
- my ($self) = shift @_;
- my %args = @_;
- $args{registry} ||= 'default';
- croak "Registry $args{registry} does not exist yet!"
- if !defined $typeregistry{$args{registry}};
- return undef unless defined $typeregistry{$args{registry}}->{$args{pg_type}};
- return $typeregistry{$args{registry}}->{$args{pg_type}};
+ 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
@@ -476,24 +435,13 @@ instead.
=cut
sub unregister_type{
+ carp 'Use of deprecated method unregister_type of PGObject';
my $self = shift @_;
my %args = @_;
$args{registry} ||= 'default';
- croak "Registry $args{registry} does not exist yet!"
- if !defined $typeregistry{$args{registry}};
- return 0 if not defined $typeregistry{$args{registry}}->{$args{pg_type}};
- delete $typeregistry{$args{registry}}->{$args{pg_type}};
- return 1;
-}
-
-=head2 $hashref = get_type_registry()
-
-Returns the type registry. Mostly useful for debugging.
-
-=cut
-
-sub get_type_registry {
- return \%typeregistry;
+ PGObject::Type::Registry->unregister_type(
+ registry => $args{registry}, dbtype => $args{pg_type}
+ );
}
=head1 WRITING PGOBJECT-AWARE HELPER CLASSES
@@ -528,6 +476,10 @@ Any type MAY present an $object->to_db() interface, requiring no arguments, and
=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
@@ -545,6 +497,21 @@ 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.
@@ -654,7 +621,7 @@ L<http://search.cpan.org/dist/PGObject/>
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 signficant ways. This being said, without
+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.
@@ -673,6 +640,7 @@ not be half of what it is today.
=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:
diff --git a/lib/PGObject/Type/Registry.pm b/lib/PGObject/Type/Registry.pm
new file mode 100644
index 0000000..eebb8dd
--- /dev/null
+++ b/lib/PGObject/Type/Registry.pm
@@ -0,0 +1,236 @@
+=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}::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;
diff --git a/t/01-basic_dbtests.t b/t/01-basic_dbtests.t
index 65a38c1..58204e4 100644
--- a/t/01-basic_dbtests.t
+++ b/t/01-basic_dbtests.t
@@ -8,7 +8,7 @@ my $dbh1 = DBI->connect('dbi:Pg:', 'postgres') ;
plan skip_all => 'Needs superuser connection for this test script' unless $dbh1;
-plan tests => 34;
+plan tests => 35;
$dbh1->do('CREATE DATABASE pgobject_test_db');
@@ -75,6 +75,7 @@ is($function_info3->{args}->[1]->{name}, 'in_test2',
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',
@@ -135,6 +136,7 @@ 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;
diff --git a/t/03-legacy_registry.t b/t/03-legacy_registry.t
new file mode 100644
index 0000000..f615fbe
--- /dev/null
+++ b/t/03-legacy_registry.t
@@ -0,0 +1,62 @@
+package Foo;
+
+package Foo2;
+
+package main;
+
+use Test::More tests => 14;
+use PGObject;
+use Test::Exception;
+
+
+lives_ok(sub {PGObject->register_type(pg_type => 'foo', perl_class => 'PGObject') }, "Basic type registration");
+lives_ok(sub {PGObject->register_type(pg_type => 'foo', perl_class => 'PGObject')},
+ "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 => 'main'), 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',
+
+ },
+};
+
diff --git a/t/03-registry.t b/t/03-registry.t
index c3f15de..ab97bbf 100644
--- a/t/03-registry.t
+++ b/t/03-registry.t
@@ -1,61 +1,53 @@
-use Test::More tests => 18;
-use PGObject;
+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;
-is(PGObject->register_type(pg_type => 'foo', perl_class => 'Foo'), 1,
- "Basic type registration");
-is(PGObject->register_type(pg_type => 'foo', perl_class => 'Foo'), 1,
- "Repeat type registration, same type");
-is(PGObject->register_type(pg_type => 'foo', perl_class => 'Foo2'), 0,
- "Repeat type registration, different type, fails");
+lives_ok {PGObject::Type::Registry->register_type(
+ registry => 'default', dbtype => 'foo', apptype => 'PGObject') },
+ "Basic type registration";
+lives_ok {PGObject::Type::Registry->register_type(
+ registry => 'default', dbtype => 'foo', apptype => 'PGObject') },
+ "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->register_type(
- pg_type => 'foo', perl_class => 'Foo2', registry => 'bar')
-} qr/Registry.*exist/,
+
+throws_ok{PGObject::Type::Registry->register_type(
+ registry => 'foo', dbtype => 'foo', apptype => 'PGObject') }
+ qr/Registry.*exist/,
'Correction exception thrown, reregistering in nonexistent registry.';
-is(PGObject->unregister_type(pg_type => 'foo'), 1, 'Unregister type, try 1');
-is(PGObject->unregister_type(pg_type => 'foo'), 0, 'Unregister type, try 0');
-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.';
-
-is(PGObject->new_registry('bar'), 1, 'new registry succeeds first try');
-is(PGObject->new_registry('bar'), 2, 'new registry already exists status');
-
-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");
-is(PGObject->register_type(
- pg_type => 'foo', perl_class => 'Foo2', registry => 'bar'
-), 0,
- "Repeat type registration, different type, fails");
-
-my $test_registry = {
- default => { foo => 'Foo2',
- },
- bar => {
- foo => 'Foo',
-
- },
-};
-
-is(PGObject->get_registered(registry => 'bar', pg_type => 'bar'), undef,
- "get_registered_type returns undef on non-registered type");
-is(PGObject->get_registered(registry => 'default', pg_type => 'foo'), 'Foo2',
- "get_registered_type returns Foo on registered type, explicit default reg.");
-is(PGObject->get_registered(registry => 'bar', pg_type => 'foo'), 'Foo',
- "get_registered_type returns Foo on registered type, bar reg.");
-is(PGObject->get_registered(pg_type => 'foo'), 'Foo2',
- "get_registered_type returns Foo on registered type, implicit default reg.");
-
-is_deeply(PGObject->get_type_registry(), $test_registry, 'Correct 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");
diff --git a/t/04-registered_types.t b/t/04-registered_types.t
index 49b4f90..32d0d59 100644
--- a/t/04-registered_types.t
+++ b/t/04-registered_types.t
@@ -1,21 +1,22 @@
-use Test::More tests => 14;
+use Test::More tests => 18;
+use Test::Exception;
use DBI;
-use PGObject;
+use PGObject 'test1', 'test2';
-is(PGObject->new_registry('test1'), 1, 'New registry 1 created');
-is(PGObject->new_registry('blank'), 1, 'New registry blank created');
-is(PGObject->new_registry('test2'), 1, 'New registry 2 created');
+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', 9 unless $ENV{DB_TESTING};
+ skip 'No database connection', 11 unless $ENV{DB_TESTING};
# Initial db setup
@@ -39,6 +40,11 @@ SKIP: {
$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;
@@ -99,6 +105,13 @@ SKIP: {
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;
@@ -109,6 +122,7 @@ SKIP: {
package test1;
sub from_db {
+ my ($string, $type) = @_;
return 4;
}
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libpgobject-perl.git
More information about the Pkg-perl-cvs-commits
mailing list