├── .dir-locals.el
├── .gitignore
├── MANIFEST.SKIP
├── lib
    └── Bundle
    │   └── DBD
    │       └── Pg.pm
├── t
    ├── 99_yaml.t
    ├── 99cleanup.t
    ├── 00_signature.t
    ├── 00basic.t
    ├── lib
    │   └── App
    │   │   └── Info
    │   │       ├── RDBMS.pm
    │   │       ├── Handler
    │   │           ├── Prompt.pm
    │   │           └── Print.pm
    │   │       ├── Request.pm
    │   │       └── Handler.pm
    ├── 20savepoints.t
    ├── 10_pg_error_field.t
    ├── 99_perlcritic.t
    ├── 06bytea.t
    ├── 00_release.t
    ├── 99_pod.t
    ├── 99_lint.t
    ├── 01keywords.t
    ├── 01connect.t
    ├── 30unicode.t
    ├── 08async.t
    └── 07copy.t
├── MANIFEST
├── z_announcements
    ├── announce.3.18.0.log.asc
    ├── announce.3.16.0.log.asc
    ├── announce.3.15.0.log.asc
    ├── announce.3.11.1.log.asc
    ├── announce.3.10.0.log.asc
    └── announce.3.8.0.log.asc
├── quote.h
├── CONTRIBUTING.md
├── META.json
├── .github
    └── workflows
    │   └── with_pg.yaml
├── META.yml
├── TODO
├── dbivport.h
├── README.win32
├── win32.mak
├── SIGNATURE
├── LICENSES
    └── artistic.txt
├── .perlcriticrc
├── dbdpg_test_postgres_versions.pl
├── Pg.h
├── types.h
└── Makefile.PL


/.dir-locals.el:
--------------------------------------------------------------------------------
1 | ((nil . ((indent-tabs-mode . nil)))	; all modes
2 |  (cperl-mode . ((cperl-indent-level . 4)
3 |                 (cperl-merge-trailing-else . nil)))
4 |  (c-mode . ((c-indentation-style . bsd)
5 |             (c-basic-offset . 4))))
6 | 


--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
 1 | Makefile
 2 | Makefile.old
 3 | *.o
 4 | Pg.bs
 5 | Pg.c
 6 | *.xsi
 7 | blib/
 8 | pm_to_blib
 9 | README.testdatabase
10 | dbdpg_test_database/
11 | tmp/
12 | core*
13 | MYMETA*
14 | *~
15 | *.tmp
16 | *#
17 | *.orig
18 | *.blame
19 | dbdpg.testing.*
20 | *.log
21 | *.asc
22 | *.patch
23 | dbdpg_test_*
24 | !dbdpg_test_setup.pl
25 | *.tar.gz
26 | cover_db/
27 | tarballs/
28 | *.swp
29 | 


--------------------------------------------------------------------------------
/MANIFEST.SKIP:
--------------------------------------------------------------------------------
 1 | 
 2 | ^Build$
 3 | ^Makefile$
 4 | ^Makefile.old$
 5 | README.testdatabase
 6 | ^Pg.c$
 7 | ^Pg.bs$
 8 | ^Pg.xsi$
 9 | ^pm_to_blib$
10 | dbdpg_test_postgres_versions.pl
11 | MYMETA.json
12 | MYMETA.yml
13 | 
14 | ^_build
15 | ^DBD-Pg
16 | ^blib
17 | ^testrun
18 | 
19 | ~$
20 | \.bak$
21 | \.o$
22 | \.tmp$
23 | \.log$
24 | \.blame$
25 | \.asc$
26 | 
27 | \.git/*
28 | ^tmp/*
29 | cover_db/
30 | dbdpg_test_database/*
31 | versiontest/*
32 | t/00_release.t
33 | t/99_lint.t
34 | t/99_perlcritic.t
35 | t/99_pod.t
36 | t/99_spellcheck.t
37 | t/99_yaml.t
38 | z_tarballs/
39 | 


--------------------------------------------------------------------------------
/lib/Bundle/DBD/Pg.pm:
--------------------------------------------------------------------------------
 1 | 
 2 | package Bundle::DBD::Pg;
 3 | 
 4 | use strict;
 5 | use warnings;
 6 | use 5.008001;
 7 | 
 8 | our $VERSION = '3.18.0';
 9 | 
10 | 1;
11 | 
12 | __END__
13 | 
14 | =head1 NAME
15 | 
16 | Bundle::DBD::Pg - A bundle to install all DBD::Pg related modules
17 | 
18 | =head1 SYNOPSIS
19 | 
20 | C<perl -MCPAN -e 'install Bundle::DBD::Pg'>
21 | 
22 | =head1 CONTENTS
23 | 
24 | DBI
25 | 
26 | DBD::Pg
27 | 
28 | =head1 DESCRIPTION
29 | 
30 | This bundle includes all the modules needed for DBD::Pg (the Perl 
31 | interface to the Postgres database system). Please feel free to 
32 | ask for help or report any problems to dbd-pg@perl.org.
33 | 
34 | =cut
35 | 
36 | =head1 AUTHOR
37 | 
38 | Greg Sabino Mullane E<lt>F<greg@turnstep.com>E<gt>
39 | 
40 | =cut
41 | 
42 | 


--------------------------------------------------------------------------------
/t/99_yaml.t:
--------------------------------------------------------------------------------
 1 | #!perl
 2 | 
 3 | ## Test META.yml for YAMLiciousness, requires Test::YAML::Meta
 4 | 
 5 | use 5.008001;
 6 | use strict;
 7 | use warnings;
 8 | use Test::More;
 9 | select(($|=1,select(STDERR),$|=1)[1]);
10 | 
11 | if (! $ENV{RELEASE_TESTING}) {
12 |     plan (skip_all =>  'Test skipped unless environment variable RELEASE_TESTING is set');
13 | }
14 | 
15 | plan tests => 2;
16 | 
17 | my $V = 0.03;
18 | eval {
19 |     require Test::YAML::Meta;
20 |     Test::YAML::Meta->import;
21 | };
22 | if ($@) {
23 |     SKIP: {
24 |         skip ('Skipping Test::YAML::Meta tests: module not found', 2);
25 |     }
26 | }
27 | elsif ($Test::YAML::Meta::VERSION < $V) {
28 |     SKIP: {
29 |         skip ("Skipping Test::YAML::Meta tests: need version $V, but only have $Test::YAML::Meta::VERSION", 2);
30 |     }
31 | }
32 | else {
33 |     meta_spec_ok ('META.yml', 1.4);
34 | }
35 | 


--------------------------------------------------------------------------------
/t/99cleanup.t:
--------------------------------------------------------------------------------
 1 | #!perl
 2 | 
 3 | ## Cleanup all database objects we may have created
 4 | ## Shutdown the test database if we created one
 5 | ## Remove the entire directory if it was created as a tempdir
 6 | 
 7 | use 5.008001;
 8 | use strict;
 9 | use warnings;
10 | use lib 'blib/lib', 'blib/arch', 't';
11 | use Test::More tests => 1;
12 | 
13 | if ($ENV{DBDPG_NOCLEANUP}) {
14 |     pass (q{No cleaning up because ENV 'DBDPG_NOCLEANUP' is set});
15 |     exit;
16 | }
17 | 
18 | require 'dbdpg_test_setup.pl';
19 | select(($|=1,select(STDERR),$|=1)[1]);
20 | 
21 | my $dbh = connect_database({nosetup => 1, nocreate => 1, norestart => 1});
22 | 
23 | SKIP: {
24 |     if (! $dbh) {
25 |         skip ('Connection to database failed, cannot cleanup', 1);
26 |     }
27 | 
28 |     isnt ($dbh, undef, 'Connect to database for cleanup');
29 | 
30 |     cleanup_database($dbh);
31 | }
32 | 
33 | $dbh->disconnect() if defined $dbh and ref $dbh;
34 | 
35 | shutdown_test_database();
36 | 
37 | unlink 'README.testdatabase';
38 | 


--------------------------------------------------------------------------------
/t/00_signature.t:
--------------------------------------------------------------------------------
 1 | #!perl
 2 | 
 3 | ## Test that our SIGNATURE file is valid - requires TEST_SIGNATURE env
 4 | 
 5 | use 5.008001;
 6 | use strict;
 7 | use warnings;
 8 | use Test::More;
 9 | select(($|=1,select(STDERR),$|=1)[1]);
10 | 
11 | if (!$ENV{TEST_SIGNATURE}) {
12 |     plan skip_all => 'Set the environment variable TEST_SIGNATURE to enable this test';
13 | }
14 | plan tests => 1;
15 | 
16 | SKIP: {
17 |     if (!eval { require Module::Signature; 1 }) {
18 |         skip ('Must have Module::Signature to test SIGNATURE file', 1);
19 |     }
20 |     elsif ( !-e 'SIGNATURE' ) {
21 |         fail ('SIGNATURE file was not found');
22 |     }
23 |     elsif ( ! -s 'SIGNATURE') {
24 |         fail ('SIGNATURE file was empty');
25 |     }
26 |     else {
27 |         my $ret = Module::Signature::verify(skip=>1);
28 |         if ($ret eq Module::Signature::SIGNATURE_OK()) {
29 |             pass ('Valid SIGNATURE file');
30 |         }
31 |         else {
32 |             fail ('Invalid SIGNATURE file');
33 |         }
34 |     }
35 | }
36 | 


--------------------------------------------------------------------------------
/MANIFEST:
--------------------------------------------------------------------------------
 1 | Changes
 2 | README
 3 | CONTRIBUTING.md
 4 | SIGNATURE
 5 | Pg.pm
 6 | META.yml
 7 | META.json
 8 | TODO
 9 | Makefile.PL
10 | .dir-locals.el
11 | 
12 | 
13 | MANIFEST
14 | MANIFEST.SKIP
15 | README.win32
16 | README.dev
17 | win32.mak
18 | LICENSES/gpl-2.0.txt
19 | LICENSES/artistic.txt
20 | testme.tmp.pl
21 | 
22 | Pg.h
23 | Pg.xs
24 | dbivport.h
25 | dbdimp.c
26 | dbdimp.h
27 | types.c
28 | types.h
29 | quote.c
30 | quote.h
31 | 
32 | .perlcriticrc
33 | t/dbdpg_test_setup.pl
34 | t/00_signature.t
35 | t/00basic.t
36 | t/01connect.t
37 | t/01constants.t
38 | t/02attribs.t
39 | t/03dbmethod.t
40 | t/03smethod.t
41 | t/04misc.t
42 | t/06bytea.t
43 | t/07copy.t
44 | t/08async.t
45 | t/09arrays.t
46 | t/10_pg_error_field.t
47 | t/12placeholders.t
48 | t/20savepoints.t
49 | t/30unicode.t
50 | t/99cleanup.t
51 | 
52 | t/lib/App/Info.pm
53 | t/lib/App/Info/Handler.pm
54 | t/lib/App/Info/Handler/Prompt.pm
55 | t/lib/App/Info/Handler/Print.pm
56 | t/lib/App/Info/RDBMS.pm
57 | t/lib/App/Info/RDBMS/PostgreSQL.pm
58 | t/lib/App/Info/Request.pm
59 | t/lib/App/Info/Util.pm
60 | 
61 | lib/Bundle/DBD/Pg.pm
62 | 


--------------------------------------------------------------------------------
/z_announcements/announce.3.18.0.log.asc:
--------------------------------------------------------------------------------
 1 | -----BEGIN PGP SIGNED MESSAGE-----
 2 | Hash: SHA1
 3 | 
 4 | 
 5 | Version 3.18.0 of DBD::Pg, the Perl DBI driver for PostgreSQL, is now available.
 6 | 
 7 | This release adds support for the new PQclosePrepared function inside 
 8 | libpq. What this means is that if DBD::Pg is compiled against version 
 9 | 17 or higher of Postgres, prepared statements are now closed at the 
10 | protocol level rather than a 'DEALLOCATE' call. This prevents the 
11 | need to use the 'pg_skip_deallocate' attribute when using PgBouncer 
12 | in transaction mode.
13 | 
14 | Development of DBD::Pg happens at:
15 | https://github.com/bucardo/dbdpg
16 | 
17 | Version 3.18.0 can be downloaded from CPAN at:
18 | https://metacpan.org/release/DBD-Pg
19 | 
20 | Checksums for the 3.18.0 tarball:
21 | 
22 | f58e5f6cbcc94e599afa08224f4e1dd2  DBD-Pg-3.18.0.tar.gz (md5)
23 | c75f0667769ac7921c59ef4b4d44a249a3881e05  DBD-Pg-3.18.0.tar.gz (sha1)
24 | 
25 | 
26 | Greg Sabino Mullane greg@turnstep.com
27 | PGP Key: 0x14964AC8 20231207
28 | http://biglumber.com/x/web?pk=2529DF6AB8F79407E94445B4BC9B906714964AC8
29 | 
30 | -----BEGIN PGP SIGNATURE-----
31 | 
32 | iF0EARECAB0WIQQlKd9quPeUB+lERbS8m5BnFJZKyAUCZXHWIQAKCRC8m5BnFJZK
33 | yNpgAKCkBMH8CN9YBgG/Z6BTFrpc8jtOpgCg9AhABbBfBEOvYpvRj1qpXL8mUgg=
34 | =9Q/A
35 | -----END PGP SIGNATURE-----
36 | 


--------------------------------------------------------------------------------
/t/00basic.t:
--------------------------------------------------------------------------------
 1 | #!perl
 2 | 
 3 | ## Simply test that we can load the DBI and DBD::Pg modules,
 4 | ## and that the latter gives a good version
 5 | 
 6 | use 5.008001;
 7 | use strict;
 8 | use warnings;
 9 | use lib 'blib/lib', 'blib/arch', 't';
10 | use Test::More tests => 3;
11 | select(($|=1,select(STDERR),$|=1)[1]);
12 | 
13 | BEGIN {
14 | 
15 |     use_ok ('DBI') or BAIL_OUT 'Cannot continue without DBI';
16 | 
17 |     ## If we cannot load DBD::Pg, output some compiler information for debugging:
18 |     if (! use_ok ('DBD::Pg')) {
19 |         my $file = 'Makefile';
20 |         if (! -e $file) {
21 |             $file = '../Makefile';
22 |         }
23 |         my $fh;
24 |         if (open $fh, '<', $file) { ## no critic (CompileTime)
25 |             { local $/; $_ = <$fh>; }
26 |             close $fh or die qq{Could not close file "$file" $!\n}; ## no critic (CompileTime) 
27 |             for my $keyword (qw/ CCFLAGS INC LIBS /) {
28 |                 if (/^#\s+$keyword => (.+)/m) {
29 |                     diag "$keyword: $1";
30 |                 }
31 |             }
32 |         }
33 | 
34 |         diag 'If the error mentions libpq.so, please see the troubleshooting section of the README file';
35 | 
36 |         BAIL_OUT 'Cannot continue without DBD::Pg';
37 |     }
38 | }
39 | use DBD::Pg;
40 | like ($DBD::Pg::VERSION, qr/^v?[0-9]+\.[0-9]+\.[0-9]+(?:_[0-9]+)?$/, qq{Found DBD::Pg::VERSION as "$DBD::Pg::VERSION"});
41 | 


--------------------------------------------------------------------------------
/quote.h:
--------------------------------------------------------------------------------
 1 | 
 2 | char * null_quote(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring);
 3 | char * quote_string(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring);
 4 | char * quote_bytea(pTHX_ char *string, STRLEN len, STRLEN *retlen, int estring);
 5 | char * quote_sql_binary(pTHX_ char *string, STRLEN len, STRLEN *retlen, int estring);
 6 | char * quote_bool(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring);
 7 | char * quote_integer(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring);
 8 | char * quote_int(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring);
 9 | char * quote_float(pTHX_ char *string, STRLEN len, STRLEN *retlen, int estring);
10 | char * quote_name(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring);
11 | char * quote_geom(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring);
12 | char * quote_path(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring);
13 | char * quote_circle(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring);
14 | void dequote_char(pTHX_ const char *string, STRLEN *retlen, int estring);
15 | void dequote_string(pTHX_ const char *string, STRLEN *retlen, int estring);
16 | void dequote_bytea(pTHX_ char *string, STRLEN *retlen, int estring);
17 | void dequote_sql_binary(pTHX_ char *string, STRLEN *retlen, int estring);
18 | void dequote_bool(pTHX_ char *string, STRLEN *retlen, int estring);
19 | void null_dequote(pTHX_ const char *string, STRLEN *retlen, int estring);
20 | bool is_keyword(const char *string);
21 | 


--------------------------------------------------------------------------------
/z_announcements/announce.3.16.0.log.asc:
--------------------------------------------------------------------------------
 1 | -----BEGIN PGP SIGNED MESSAGE-----
 2 | Hash: SHA1
 3 | 
 4 | 
 5 | Version 3.16.0 of DBD::Pg, the Perl DBI driver for PostgreSQL, is now available.
 6 | 
 7 | The full list of changes for 3.16.0 is listed below.
 8 | 
 9 | Development happens at:
10 | https://github.com/bucardo/dbdpg
11 | 
12 | Version 3.16.0 can be downloaded from CPAN at:
13 | https://metacpan.org/release/DBD-Pg
14 | 
15 | Checksums for the 3.16.0 tarball:
16 | 
17 | 5435075d31a55fa1281cf10239cc5e7b  DBD-Pg-3.16.0.tar.gz (md5)
18 | 1d018be0004402f975d789ede570bf9684bceaea  DBD-Pg-3.16.0.tar.gz (sha1)
19 | 
20 | Complete list of changes:
21 | 
22 |  - Automatically use 64-bit versions of large object functions when available
23 |    [Dagfinn Ilmari Mannsåker, David Christensen]
24 | 
25 |  - Set UTF8 flag as needed for error messages
26 |    [Github user olafgw]
27 |    (Github issue #97)
28 | 
29 |  - In tests, do not assume what the default transaction isolation level will be
30 |    [Rene Schickbauer]
31 |    (Github issue #94)
32 | 
33 |  - Make tests smarter about detecting pg_ctl results in different locales
34 |    [Greg Sabino Mullane]
35 |    (Github issue #95)
36 | 
37 | 
38 | 
39 | - -- 
40 | Greg Sabino Mullane greg@turnstep.com
41 | PGP Key: 0x14964AC8 202208111005
42 | http://biglumber.com/x/web?pk=2529DF6AB8F79407E94445B4BC9B906714964AC8
43 | -----BEGIN PGP SIGNATURE-----
44 | 
45 | iF0EARECAB0WIQQlKd9quPeUB+lERbS8m5BnFJZKyAUCYvUNDwAKCRC8m5BnFJZK
46 | yDqCAJ9BMTtXEV4KorTILy4sTukEvLv+iQCg8WJJZBLHCxeFjPKcpCHthTgu06k=
47 | =WS6y
48 | -----END PGP SIGNATURE-----
49 | 


--------------------------------------------------------------------------------
/CONTRIBUTING.md:
--------------------------------------------------------------------------------
 1 | # How to Contribute
 2 | 
 3 | Help with DBD::Pg is always welcome. You do not have to know any code to help out - 
 4 | we also need help testing, answering questions, improving documentation, etc.
 5 | 
 6 | 
 7 | ## Issues
 8 | 
 9 | Bugs and problems can be reported at:
10 | 
11 | https://github.com/bucardo/dbdpg/issues
12 | 
13 | 
14 | ## Questions
15 | 
16 | Questions about usage can be answered in a number of places:
17 | 
18 | ### IRC
19 | 
20 | You may find helpful people at #postgresql on irc.libera.chat
21 | 
22 | Lower volume but more technical discussions happen at #dbi on irc.perl.org
23 | 
24 | ### Slack
25 | 
26 | The Slack channel #general at postgresteam.slack.com is full of helpful people
27 | 
28 | ### Email
29 | 
30 | There is a low-volume mailing list for discussion about this module
31 | 
32 | Send an email to <dbd-pg@perl.org>. Before doing so, you probably want to 
33 | subscribe by sending an email to dbd-pg-subscribe@perl.org
34 | 
35 | 
36 | ## Testing
37 | 
38 | You can help by testing DBD::Pg as widely as possible. Running the tests 
39 | on a wide variety of platforms, Postgres versions, DBI versions, and other 
40 | factors is a great help in uncovering problems and improving DBD::Pg
41 | 
42 | 
43 | ## Code development
44 | 
45 | Development happens in a git repo. The canonical location is currently 
46 | at https://github.com/bucardo/dbdpg
47 | 
48 | Create your own copy of the repo by running:
49 | 
50 | git clone https://github.com/bucardo/dbdpg.git
51 | 
52 | See the README.dev file for more information about developing DBD::Pg
53 | 
54 | 


--------------------------------------------------------------------------------
/z_announcements/announce.3.15.0.log.asc:
--------------------------------------------------------------------------------
 1 | -----BEGIN PGP SIGNED MESSAGE-----
 2 | Hash: SHA1
 3 | 
 4 | 
 5 | Version 3.15.0 of DBD::Pg, the Perl DBI driver for PostgreSQL, is now available.
 6 | 
 7 | The full (but short) list of changes for 3.15.0 is listed below.
 8 | 
 9 | Development happens at:
10 | https://github.com/bucardo/dbdpg
11 | 
12 | Version 3.15.0 can be downloaded from CPAN at:
13 | https://metacpan.org/release/DBD-Pg
14 | 
15 | Checksums for the 3.15.0 tarball:
16 | 
17 | 4c08f0effbc69393242933bf75034b8d  DBD-Pg-3.15.0.tar.gz (md5)
18 | b44a67a706466cc0d1b479528e2382794cdcc300  DBD-Pg-3.15.0.tar.gz (sha1)
19 | 
20 | Complete list of changes:
21 | 
22 |  - Correctly pull back pg_async status from statement handle.
23 |    Previously, $dbh->{pg_async} would return undef.
24 |    [Greg Sabino Mullane]
25 |    (RT ticket #136553)
26 | 
27 |  - Adjust tests for the fact that reltuples can be -1 in Postgres
28 |      version 14 and later. This is mostly reflected in the CARDINALITY 
29 |      column for $dbh->statistics_info.
30 |    [Greg Sabino Mullane]
31 | 
32 |  - Remove the experimental 'fulltest' Makefile target.
33 |    [Greg Sabino Mullane]
34 |    (RT ticket #136567)
35 | 
36 | 
37 | - -- 
38 | Greg Sabino Mullane greg@turnstep.com
39 | PGP Key: 0x14964AC8 202105211725
40 | http://biglumber.com/x/web?pk=2529DF6AB8F79407E94445B4BC9B906714964AC8
41 | -----BEGIN PGP SIGNATURE-----
42 | 
43 | iF0EARECAB0WIQQlKd9quPeUB+lERbS8m5BnFJZKyAUCYKgmNgAKCRC8m5BnFJZK
44 | yBsgAJ91IuHB2zeTn1rhPzJ3TSIdam0a8gCgu9espbOQd3qF8lzwoDKfFKXzZxk=
45 | =NVXQ
46 | -----END PGP SIGNATURE-----
47 | 


--------------------------------------------------------------------------------
/t/lib/App/Info/RDBMS.pm:
--------------------------------------------------------------------------------
 1 | package App::Info::RDBMS;
 2 | 
 3 | use strict;
 4 | use App::Info;
 5 | our @ISA = qw(App::Info);
 6 | our $VERSION = '0.57';
 7 | 
 8 | 1;
 9 | __END__
10 | 
11 | =head1 NAME
12 | 
13 | App::Info::RDBMS - Information about databases on a system
14 | 
15 | =head1 DESCRIPTION
16 | 
17 | This class is an abstract base class for App::Info subclasses that provide
18 | information about relational databases. Its subclasses are required to
19 | implement its interface. See L<App::Info|App::Info> for a complete description
20 | and L<App::Info::RDBMS::PostgreSQL|App::Info::RDBMS::PostgreSQL> for an example
21 | implementation.
22 | 
23 | =head1 INTERFACE
24 | 
25 | Currently, App::Info::RDBMS adds no more methods than those from its parent
26 | class, App::Info.
27 | 
28 | =head1 SUPPORT
29 | 
30 | This module is stored in an open L<GitHub
31 | repository|http://github.com/theory/app-info/>. Feel free to fork and
32 | contribute!
33 | 
34 | Please file bug reports via L<GitHub
35 | Issues|http://github.com/theory/app-info/issues/> or by sending mail to
36 | L<bug-App-Info@rt.cpan.org|mailto:bug-App-Info@rt.cpan.org>.
37 | 
38 | =head1 AUTHOR
39 | 
40 | David E. Wheeler <david@justatheory.com>
41 | 
42 | =head1 SEE ALSO
43 | 
44 | L<App::Info|App::Info>,
45 | L<App::Info::RDBMS::PostgreSQL|App::Info::RDBMS::PostgreSQL>
46 | 
47 | =head1 COPYRIGHT AND LICENSE
48 | 
49 | Copyright (c) 2002-2011, David E. Wheeler. Some Rights Reserved.
50 | 
51 | This module is free software; you can redistribute it and/or modify it under the
52 | same terms as Perl itself.
53 | 
54 | =cut
55 | 


--------------------------------------------------------------------------------
/META.json:
--------------------------------------------------------------------------------
 1 | {
 2 |    "generated_by" : "emacs",
 3 |    "dynamic_config" : "1",
 4 |    "recommends" : {
 5 |       "Encode" : "0",
 6 |       "Module::Signature" : "0.50",
 7 |       "Cwd" : "0"
 8 |    },
 9 |    "name" : "DBD-Pg",
10 |    "resources" : {
11 |       "homepage" : "http://search.cpan.org/dist/DBD-Pg/",
12 |       "MailingList" : "http://www.nntp.perl.org/group/perl.dbd.pg/",
13 |       "repository" : "https://github.com/bucardo/dbdpg",
14 |       "bugtracker" : "https://github.com/bucardo/dbdpg/issues",
15 |       "license" : "http://dev.perl.org/licenses/",
16 |       "IRC" : "irc://irc.libera.chat/#postgresql"
17 |    },
18 |    "provides" : {
19 |       "DBD::Pg" : {
20 |          "file" : "Pg.pm",
21 |          "version" : "3.18.0"
22 |       },
23 |       "Bundle::DBD::Pg" : {
24 |          "version" : "3.18.0",
25 |          "file" : "lib/Bundle/DBD/Pg.pm"
26 |       }
27 |    },
28 |    "version" : "3.18.0",
29 |    "requires" : {
30 |       "perl" : "5.008001",
31 |       "DBI" : "1.614",
32 |       "version" : "0"
33 |    },
34 |    "keywords" : [
35 |       "Postgres",
36 |       "PostgreSQL",
37 |       "DBI",
38 |       "libpq",
39 |       "dbdpg"
40 |    ],
41 |    "meta-spec" : {
42 |       "url" : "http://module-build.sourceforge.net/META-spec-v1.4.html",
43 |       "version" : "1.4"
44 |    },
45 |    "author" : [
46 |       "Greg Sabino Mullane <greg@turnstep.com>"
47 |    ],
48 |    "configure_requires" : {
49 |       "DBI" : "1.614",
50 |       "version" : "0"
51 |    },
52 |    "license" : "perl",
53 |    "distribution_type" : "module",
54 |    "build_requires" : {
55 |       "File::Temp" : "0",
56 |       "version" : "0",
57 |       "Time::HiRes" : "0",
58 |       "DBI" : "1.614",
59 |       "Test::More" : "0.88"
60 |    },
61 |    "abstract" : "DBI PostgreSQL interface"
62 | }
63 | 


--------------------------------------------------------------------------------
/.github/workflows/with_pg.yaml:
--------------------------------------------------------------------------------
 1 | name: CI in Docker container
 2 | 
 3 | on:
 4 |   push:
 5 |   pull_request:
 6 |   workflow_dispatch:
 7 | #  schedule:
 8 | #    - cron: '42 5 * * *'
 9 | 
10 | jobs:
11 |   test:
12 |     strategy:
13 |       fail-fast: false
14 |       matrix:
15 |         perl: [ '5.30', '5.36', '5.40' ]
16 |         postgres: [ '11', '13', 'latest' ]
17 | 
18 |     services:
19 |       postgreshost:
20 |         image: postgres:${{matrix.postgres}}
21 |         env:
22 |           POSTGRES_USER: test_user
23 |           POSTGRES_PASSWORD: test_secret
24 |           POSTGRES_DB: test_db
25 |         options: >-
26 |           --health-cmd pg_isready
27 |           --health-interval 10s
28 |           --health-timeout 5s
29 |           --health-retries 5
30 | 
31 | 
32 |     runs-on: ubuntu-latest
33 |     container: perl:${{ matrix.perl }}
34 | 
35 |     steps:
36 |     - uses: actions/checkout@v3
37 | 
38 |     - name: Show Perl Version
39 |       run: |
40 |         perl -v
41 | 
42 |     - name: Install non-perl dependencies
43 |       run: |
44 |         apt-get update
45 |         apt-get install -y libaspell-dev
46 | 
47 |     - name: Install Modules
48 |       run: |
49 |         cpanm -v
50 |         cpanm --installdeps --notest .
51 |         cpanm --notest Perl::Critic Text::SpellChecker
52 | 
53 |     - name: Show Errors on Ubuntu
54 |       if:  ${{ failure() && startsWith( matrix.runner, 'ubuntu-')}}
55 |       run: |
56 |          cat /home/runner/.cpanm/work/*/build.log
57 | 
58 |     - name: Run make
59 |       run: |
60 |         perl Makefile.PL
61 |         make
62 | 
63 |     - name: Run tests
64 |       env:
65 |         AUTHOR_TESTING: 1
66 |         RELEASE_TESTING: 1
67 |         DBI_DSN: "dbi:Pg:dbname=test_db;host=postgreshost"
68 |         DBI_PASS: test_secret
69 |         DBI_USER: test_user
70 |       run: |
71 |         make test
72 | 
73 | 
74 | 


--------------------------------------------------------------------------------
/META.yml:
--------------------------------------------------------------------------------
 1 | --- #YAML:1.0
 2 | name                        : DBD-Pg
 3 | version                     : 3.18.0
 4 | abstract                    : DBI PostgreSQL interface
 5 | author:              
 6 |   - Greg Sabino Mullane <greg@turnstep.com>
 7 | 
 8 | license                     : perl
 9 | distribution_type           : module
10 | dynamic_config              : 1
11 | 
12 | requires:
13 |   DBI                       : 1.614
14 |   perl                      : 5.008001
15 |   version                   : 0
16 | build_requires:
17 |   DBI                       : 1.614
18 |   File::Temp                : 0
19 |   Test::More                : 0.88
20 |   Time::HiRes               : 0
21 |   version                   : 0
22 | configure_requires:
23 |   DBI                       : 1.614
24 |   version                   : 0
25 | recommends:
26 |   Cwd                       : 0
27 |   Encode                    : 0
28 |   Module::Signature         : 0.50
29 | 
30 | provides:
31 |   DBD::Pg:
32 |     file                    : Pg.pm
33 |     version                 : 3.18.0
34 |   Bundle::DBD::Pg:
35 |     file                    : lib/Bundle/DBD/Pg.pm
36 |     version                 : 3.18.0
37 | 
38 | keywords:
39 |   - Postgres
40 |   - PostgreSQL
41 |   - DBI
42 |   - libpq
43 |   - dbdpg
44 | 
45 | resources:
46 |   homepage                  : http://search.cpan.org/dist/DBD-Pg/
47 |   license                   : http://dev.perl.org/licenses/
48 |   bugtracker                : https://github.com/bucardo/dbdpg/issues
49 |   repository                : https://github.com/bucardo/dbdpg
50 |   MailingList               : http://www.nntp.perl.org/group/perl.dbd.pg/
51 |   IRC                       : irc://irc.libera.chat/#postgresql
52 | 
53 | meta-spec:
54 |   version                   : 1.4
55 |   url                       : http://module-build.sourceforge.net/META-spec-v1.4.html
56 | 
57 | generated_by                : emacs
58 | 


--------------------------------------------------------------------------------
/z_announcements/announce.3.11.1.log.asc:
--------------------------------------------------------------------------------
 1 | -----BEGIN PGP SIGNED MESSAGE-----
 2 | Hash: RIPEMD160
 3 | 
 4 | 
 5 | Version 3.11.1 of DBD::Pg, the Perl DBI driver for PostgreSQL, is now available. 
 6 | 
 7 | The full list of changes for 3.11.0 and 3.11.1 is below.
 8 | 
 9 | Development happens at:
10 | https://github.com/bucardo/dbdpg
11 | 
12 | Version 3.11.1 can be downloaded from CPAN at:
13 | https://metacpan.org/release/DBD-Pg
14 | 
15 | Checksums for the 3.11.1 tarball:
16 | 
17 | 86b0337a347fca067ae279f0f192e8e2  DBD-Pg-3.11.1.tar.gz (md5)
18 | 955a3837a02d18659202605d4ff8cb098daf5751  DBD-Pg-3.11.1.tar.gz (sha1)
19 | 
20 | 
21 | Complete list of changes:
22 | 
23 | 
24 | Version 3.11.1  (released April 28, 2020)
25 | 
26 |  - Adjust Makefile to fix failing 'fulltest' target on BSD systems
27 |    [Slaven Rezić]
28 |    (RT ticket #132412)
29 | 
30 | 
31 | Version 3.11.0  (released April 23, 2020)
32 | 
33 |  - Indicate non-key index columns (INCLUDE) in statistics_info
34 |    [Dagfinn Ilmari Mannsåker]
35 | 
36 |  - Return an empty result set instead of undef from statistics_info
37 |      when the requested table doesn't exist and $unique_only is false.
38 |    [Dagfinn Ilmari Mannsåker]
39 | 
40 |  - Fix segfault during st destroy
41 |    [Gregory Oschwald]
42 |    (Github pull request #66)
43 |    (Github issue #57)
44 | 
45 |  - Improve testing for table_info()
46 |    [Greg Sabino Mullane]
47 |    (Github issue #67)
48 | 
49 |  - Improve UTF-8 wording in docs
50 |    [Felipe Gasper]
51 |    (Github pull request #65)
52 | 
53 | 
54 | - -- 
55 | Greg Sabino Mullane greg@turnstep.com
56 | PGP Key: 0x14964AC8 202004281124
57 | http://biglumber.com/x/web?pk=2529DF6AB8F79407E94445B4BC9B906714964AC8
58 | 
59 | -----BEGIN PGP SIGNATURE-----
60 | 
61 | iF0EAREDAB0WIQQlKd9quPeUB+lERbS8m5BnFJZKyAUCXqhM3wAKCRC8m5BnFJZK
62 | yKr9AJoCANUprpq0u+Da9NOPhNLHesxLawCgoHaYAJuLkqjefPazGK9z/0uugAU=
63 | =E1J7
64 | -----END PGP SIGNATURE-----
65 | 


--------------------------------------------------------------------------------
/t/20savepoints.t:
--------------------------------------------------------------------------------
 1 | #!perl
 2 | 
 3 | ## Test savepoint functionality
 4 | 
 5 | use 5.008001;
 6 | use strict;
 7 | use warnings;
 8 | use lib 'blib/lib', 'blib/arch', 't';
 9 | use Test::More;
10 | use DBI ':sql_types';
11 | require 'dbdpg_test_setup.pl';
12 | select(($|=1,select(STDERR),$|=1)[1]);
13 | 
14 | my $dbh = connect_database();
15 | 
16 | if (! $dbh) {
17 |     plan skip_all => 'Connection to database failed, cannot continue testing';
18 | }
19 | plan tests => 3;
20 | 
21 | isnt ($dbh, undef, 'Connect to database for savepoint testing');
22 | 
23 | my $t;
24 | 
25 | my $str = 'Savepoint Test';
26 | my $sth = $dbh->prepare('INSERT INTO dbd_pg_test (id,pname) VALUES (?,?)');
27 | 
28 | ## Create 500 without a savepoint
29 | $sth->execute(500,$str);
30 | 
31 | ## Create 501 inside a savepoint and roll it back
32 | $dbh->pg_savepoint('dbd_pg_test_savepoint');
33 | $sth->execute(501,$str);
34 | 
35 | $dbh->pg_rollback_to('dbd_pg_test_savepoint');
36 | $dbh->pg_rollback_to('dbd_pg_test_savepoint'); ## Yes, we call it twice
37 | 
38 | ## Create 502 after the rollback:
39 | $sth->execute(502,$str);
40 | 
41 | $dbh->commit;
42 | 
43 | $t='Only row 500 and 502 should be committed';
44 | my $ids = $dbh->selectcol_arrayref('SELECT id FROM dbd_pg_test WHERE pname = ?',undef,$str);
45 | ok (eq_set($ids, [500, 502]), $t);
46 | 
47 | ## Create 503, then release the savepoint
48 | $dbh->pg_savepoint('dbd_pg_test_savepoint');
49 | $sth->execute(503,$str);
50 | $dbh->pg_release('dbd_pg_test_savepoint');
51 | 
52 | ## Create 504 outside of any savepoint
53 | $sth->execute(504,$str);
54 | $dbh->commit;
55 | 
56 | $t='Implicit rollback on deallocate should rollback to last savepoint';
57 | $ids = $dbh->selectcol_arrayref('SELECT id FROM dbd_pg_test WHERE pname = ?',undef,$str);
58 | ok (eq_set($ids, [500, 502, 503, 504]), $t);
59 | 
60 | $dbh->do('DELETE FROM dbd_pg_test');
61 | $dbh->commit();
62 | 
63 | cleanup_database($dbh,'test');
64 | $dbh->disconnect();
65 | 


--------------------------------------------------------------------------------
/z_announcements/announce.3.10.0.log.asc:
--------------------------------------------------------------------------------
 1 | -----BEGIN PGP SIGNED MESSAGE-----
 2 | Hash: RIPEMD160
 3 | 
 4 | 
 5 | Version 3.10.0 of DBD::Pg, the Perl DBI driver for PostgreSQL, is now available. 
 6 | 
 7 | The full list of changes is provided below.
 8 | 
 9 | Development happens at:
10 | https://github.com/bucardo/dbdpg
11 | 
12 | Version 3.10.0 can be downloaded from CPAN at:
13 | https://metacpan.org/release/DBD-Pg
14 | 
15 | Checksums for the 3.10.0 tarball:
16 | 
17 | 1cd697899aec65117464d12e9c874ce8  DBD-Pg-3.10.0.tar.gz (md5)
18 | 3e5ba30e1f80c49ad861e9ede241aa5f505836dd  DBD-Pg-3.10.0.tar.gz (sha1)
19 | 
20 | Complete list of changes:
21 | 
22 | Version 3.10.0  (released September 3, 2019)
23 | 
24 |   - Prevent memory leak related to pg_error_field
25 |     [Greg Sabino Mullane]
26 |     [RT #130430]
27 | 
28 |   - Fix for bug by making sure pg_error_field works properly when switching between 
29 |     do-with-params and do-without-params.
30 |     [Greg Sabino Mullane]
31 |     [Github issue #57]
32 | 
33 |   - If a commit or rollback fails, do not set BegunWork
34 |     [Greg Sabino Mullane]
35 |     [Github issue #40]
36 | 
37 |   - Treat partitioned tables same as regular tables for column_info, table_info, 
38 |     and foreign_key_info (i.e. support pg_class.relkind = 'p')
39 |     [Octavian R. Corlade]
40 |     [Github PR #55]
41 | 
42 |   - Allow last_insert_id() to work against inherited tables
43 |     [Greg Sabino Mullane]
44 |     [RT #52441]
45 | 
46 |   - Add DBI SQL_BLOB, SQL_BINARY and SQL_LONGVARBINARY types as alias for PG_BYTEA
47 |     [Pali]
48 |     [Github PR #58]
49 | 
50 | 
51 | - -- 
52 | Greg Sabino Mullane greg@turnstep.com
53 | PGP Key: 0x14964AC8 201909051125
54 | http://biglumber.com/x/web?pk=2529DF6AB8F79407E94445B4BC9B906714964AC8
55 | 
56 | -----BEGIN PGP SIGNATURE-----
57 | 
58 | iEYEAREDAAYFAl1xKsoACgkQvJuQZxSWSshtzwCgyEOWJHJkurwI41xCwu4EHREr
59 | hAgAniiFodtwV301/5YGUChuFzop4V8H
60 | =a8c9
61 | -----END PGP SIGNATURE-----
62 | 


--------------------------------------------------------------------------------
/TODO:
--------------------------------------------------------------------------------
 1 | Possible items to do, in no particular order
 2 | 
 3 | Feature requests can be entered at 
 4 | https://github.com/bucardo/dbdpg/issues
 5 | 
 6 | - Consider support for PQchangePassword
 7 | - Support pipeline mode: https://www.postgresql.org/docs/14/libpq-pipeline-mode.html
 8 | - Consider adding pg_application_name
 9 | - Evaluate if we really need strtod in the code
10 | - Have docs describe various ways to set client_encoding
11 | - Change license to Artistic 2
12 | - Remove the "goto" calls in the tests
13 | - Force a test database rebuild when a git branch switch is detected
14 | - Make all tests work when server and/or client encoding is SQL_ASCII
15 | - Enable native JSON decoding, similar to arrays, perhaps with JSON::PP
16 | - Allow partial result sets, either via PQsetSingleRowMode or something better
17 | - Hack libpq to make user-defined number of rows returned
18 | - Map hstore to hashes similar to the array/array mapping
19 | - Fix ping problem: http://www.cpantesters.org/cpan/report/53c5cc72-6d39-11e1-8b9d-82c3d2d9ea9f
20 | - Use WITH HOLD for cursor work
21 | - Devise a way to automatically create ppm for Windows builds
22 | - I8N docs and error messages
23 | - Change quote and dequote functions to take Sv instead of string so that
24 |    things like arrays can be serialized by the quote function.  This will
25 |    take care of broken chopblanks and pg_bool_tf (pass the quote/dequote 
26 |    options struct to function quote/dequote functions)
27 | - Allow user callbacks to quote user-defined types
28 | - Revisit the use of version.pm
29 | - Test heavily with a thread-enabled Perl
30 | - Remove libpq dependency
31 | - Handle and/or better tests for different encoding, especially those not 
32 |    supported as a server encoding (e.g. BIG5)
33 | - Support passing hashrefs in and out for custom types.
34 | - Support a flag for behind-the-scenes CURSOR to emulate partial fetches.
35 | - Composite type support: http://www.postgresql.org/docs/current/interactive/rowtypes.html
36 | - Full support for execute_array, e.g. the return values
37 | - Fix array support: execute([1,2]) not working as expected, deep arrays not returned correctly.
38 | - Support RaiseError on $sth from closed $dbh (GH #28)
39 | 


--------------------------------------------------------------------------------
/dbivport.h:
--------------------------------------------------------------------------------
 1 | /* dbivport.h
 2 | 
 3 | 	Provides macros that enable greater portability between DBI versions.
 4 | 
 5 | 	This file should be *copied* and included in driver distributions
 6 | 	and #included into the source, after #include DBIXS.h
 7 | 
 8 | 	New driver releases should include an updated copy of dbivport.h
 9 | 	from the most recent DBI release.
10 | */
11 | 
12 | #ifndef DBI_VPORT_H
13 | #define DBI_VPORT_H
14 | 
15 | #ifndef DBIh_SET_ERR_CHAR
16 | /* Emulate DBIh_SET_ERR_CHAR
17 | 	Only uses the err_i, errstr and state parameters.
18 | */
19 | #define DBIh_SET_ERR_CHAR(h, imp_xxh, err_c, err_i, errstr, state, method) \
20 |         sv_setiv(DBIc_ERR(imp_xxh), err_i); \
21 |         (state) ? (void)sv_setpv(DBIc_STATE(imp_xxh), state) : (void)SvOK_off(DBIc_STATE(imp_xxh)); \
22 |         sv_setpv(DBIc_ERRSTR(imp_xxh), errstr)
23 | #endif
24 | 
25 | #ifndef DBIcf_Executed
26 | #define DBIcf_Executed    0x080000
27 | #endif
28 | 
29 | #ifndef DBIc_TRACE_LEVEL_MASK
30 | #define DBIc_TRACE_LEVEL_MASK   0x0000000F
31 | #define DBIc_TRACE_FLAGS_MASK   0xFFFFFF00
32 | #define DBIc_TRACE_SETTINGS(imp) (DBIc_DBISTATE(imp)->debug)
33 | #define DBIc_TRACE_LEVEL(imp)   (DBIc_TRACE_SETTINGS(imp) & DBIc_TRACE_LEVEL_MASK)
34 | #define DBIc_TRACE_FLAGS(imp)   (DBIc_TRACE_SETTINGS(imp) & DBIc_TRACE_FLAGS_MASK)
35 | /* DBIc_TRACE_MATCHES - true if s1 'matches' s2  (c.f. trace_msg())
36 |    DBIc_TRACE_MATCHES(foo, DBIc_TRACE_SETTINGS(imp))
37 | */
38 | #define DBIc_TRACE_MATCHES(s1, s2)      \
39 |         (  ((s1 & DBIc_TRACE_LEVEL_MASK) >= (s2 & DBIc_TRACE_LEVEL_MASK)) \
40 |         || ((s1 & DBIc_TRACE_FLAGS_MASK)  & (s2 & DBIc_TRACE_FLAGS_MASK)) )
41 | /* DBIc_TRACE - true if flags match & DBI level>=flaglevel, or if DBI level>level
42 |    DBIc_TRACE(imp,         0, 0, 4) = if level >= 4
43 |    DBIc_TRACE(imp, DBDtf_FOO, 2, 4) = if tracing DBDtf_FOO & level>=2 or level>=4
44 |    DBIc_TRACE(imp, DBDtf_FOO, 2, 0) = as above but never trace just due to level
45 | */
46 | #define DBIc_TRACE(imp, flags, flaglevel, level)        \
47 |         (  (flags && (DBIc_TRACE_FLAGS(imp) & flags) && (DBIc_TRACE_LEVEL(imp) >= flaglevel)) \
48 |         || (level && DBIc_TRACE_LEVEL(imp) >= level) )
49 | #endif
50 | 
51 | 
52 | #endif /* !DBI_VPORT_H */
53 | 


--------------------------------------------------------------------------------
/z_announcements/announce.3.8.0.log.asc:
--------------------------------------------------------------------------------
 1 | -----BEGIN PGP SIGNED MESSAGE-----
 2 | Hash: RIPEMD160
 3 | 
 4 | 
 5 | Version 3.8.0 of DBD::Pg, the Perl DBI driver for PostgreSQL, is now available. 
 6 | 
 7 | The full list of changes is provided below.
 8 | 
 9 | Development happens at:
10 | https://github.com/bucardo/dbdpg
11 | 
12 | Version 3.8.0 can be downloaded from CPAN at:
13 | https://metacpan.org/release/DBD-Pg
14 | 
15 | Checksums for the 3.8.0 tarball:
16 | 
17 | 92195caa3cc1ed93480dd48b8900b126  DBD-Pg-3.8.0.tar.gz (md5)
18 | 9cd82ecb9b569b27dc7c6806cc83c4b05f1c20e0  DBD-Pg-3.8.0.tar.gz (sha1)
19 | 
20 | Complete list of changes:
21 | 
22 | Version 3.8.0, released April 25, 2019
23 | 
24 |   - Increase minimum supported PostgreSQL version to 8.0
25 |     [Dagfinn Ilmari Mannsåker]
26 | 
27 |   - Add support for foreign tables in table_info() and column_info()
28 |     [Dagfinn Ilmari Mannsåker]
29 | 
30 |   - Return the current database name as TABLE_CAT in info methods
31 |     [Dagfinn Ilmari Mannsåker]
32 | 
33 |   - Handle backslash-escaped quotes in E'' strings
34 |     [Dagfinn Ilmari Mannsåker]
35 | 
36 |   - Fix typo in Makefile.PL
37 |     [CPAN ticket #127097]
38 | 
39 |   - Fix parsing of PostgreSQL versions >= 10 on Debian/Ubuntu
40 |     [Dagfinn Ilmari Mannsåker]
41 | 
42 |   - Fix client_min_messages=FATAL test when PostgreSQL caps it to ERROR
43 |     [Dagfinn Ilmari Mannsåker]
44 |     [CPAN ticket #128529]
45 | 
46 |   - Fix ->ping error detection on PostgreSQL 12
47 |     [Dagfinn Ilmari Mannsåker]
48 | 
49 |   - Adjust tests for new pg_ctl output
50 |     [Erik Rijkers    er at xs4all.nl]
51 |     [CPAN ticket #128966]
52 | 
53 |   - Adjust tests for removal of WITH OIDS in PostgreSQL 12
54 |     [Dagfinn Ilmari Mannsåker]
55 | 
56 |   - Fix support for PostgreSQL versions back to 8.0
57 |     [Dagfinn Ilmari Mannsåker]
58 | 
59 |   - Remove usage of deprecated pg_attrdef.adsrc and pg_constraint.consrc columns
60 |     [Dagfinn Ilmari Mannsåker]
61 | 
62 |   - Fix typo in pg_placeholder_colons example
63 |     (Github issue #41)
64 | 
65 |   - Support GENERATED ... AS IDENTITY columns in last_insert_id()
66 |     [Dagfinn Ilmari Mannsåker]
67 | 
68 | 
69 | - -- 
70 | Greg Sabino Mullane greg@turnstep.com
71 | PGP Key: 0x14964AC8 201905040807
72 | http://biglumber.com/x/web?pk=2529DF6AB8F79407E94445B4BC9B906714964AC8
73 | -----BEGIN PGP SIGNATURE-----
74 | 
75 | iEYEAREDAAYFAlzNgXsACgkQvJuQZxSWSsgWAQCdFYDRouHlMR/yT8Fat9u6GVlW
76 | rMoAnR49g/ye5v5Z/1PoNNDSoBvQAu9c
77 | =3Wee
78 | -----END PGP SIGNATURE-----
79 | 


--------------------------------------------------------------------------------
/README.win32:
--------------------------------------------------------------------------------
  1 | 
  2 | How to get a working DBD::Pg on Windows
  3 | 
  4 | Warning! This information is outdated. Please ask on the mailing list for help 
  5 | if you encounter any problems.
  6 | 
  7 | Also see the notes about Strawberry Perl in the README file.
  8 | 
  9 | Start with:
 10 | MS VC++.Net Standard Edition
 11 | MS VC++ Toolkit 2003
 12 | Latest PostgreSQL (e.g. postgresql-8.00.rc2.tar.gz)
 13 | Latest Perl (e.g. perl-5.8.6.tar.gz)
 14 | Latest DBI (e.g. DBI-1.46.tar.gz)
 15 | Latest DBD::Pg (1.40 or higher)
 16 | Custom "win32.mak" file (included with DBD::Pg)
 17 | 
 18 | Unpack the .tar.gz files in c:\tmp
 19 | 
 20 | Save win32.mak as src\bin\pg_config\win32.mak in postgres tree.
 21 | 
 22 | 1. In Windows command window, set up to compile:
 23 | 
 24 | set PATH=C:\Program Files\Microsoft Visual Studio .NET 2003\Vc7\bin;%PATH%
 25 | set PATH=C:\Program Files\Microsoft Visual C++ Toolkit 2003\bin;%PATH%
 26 | vcvars32
 27 | 
 28 | 2. Run win32 make for postgresql:
 29 | 
 30 | cd \tmp\postgresql-8.0.0rc2\src
 31 | nmake -f win32.mak
 32 | 
 33 | 3. Make pg_config.exe (not part of standard MSVC build), and copy it out:
 34 | 
 35 | cd bin\pg_config
 36 | nmake -f win32.mak
 37 | copy Release\pg_config.exe \tmp\DBD-Pg-1.42
 38 | 
 39 | 4. Install lib and include to some permanent location like this:
 40 | 
 41 | mkdir c:\postgres
 42 | mkdir c:\postgres\lib
 43 | mkdir c:\postgres\include
 44 | cd ..\..\interfaces\libpq\Release
 45 | copy libpq* c:\postgres\lib
 46 | cd ..\..\..
 47 | xcopy /s include c:\postgres\include
 48 | xcopy \tmp\postgresql-8.0.3\src\interfaces\libpq\libpg-fe.h c:\postgres\include
 49 | 
 50 | 
 51 | 5. Make a non-threaded perl, like this:
 52 | 
 53 | cd \tmp\perl-5.8.6\win32
 54 | 
 55 | in Makefile, 
 56 | .. change the install location thus:
 57 |       INST_TOP        = $(INST_DRV)\myperl
 58 | .. comment out the following lines
 59 |   USE_MULTI = define
 60 |   USE_ITHREADS = define
 61 |   USE_IMP_SYS = define
 62 | .. change both instances of deprecated '-Gf' flag to '-GF'
 63 | 
 64 | then just run:
 65 | 
 66 | nmake
 67 | nmake test
 68 | nmake install
 69 |   
 70 | 5. Add new perl to path:
 71 | 
 72 | set PATH=c:\myperl\bin;%PATH%
 73 | 
 74 | 6. Make and install DBI:
 75 | 
 76 | cd \tmp\DBI-1.46
 77 | perl Makefile.PL
 78 | nmake
 79 | nmake test
 80 | nmake install
 81 | 
 82 | 7. Set up environment for DBD::Pg:
 83 | 
 84 | set POSTGRES_LIB=c:\postgres\lib
 85 | set POSTGRES_INCLUDE=c:\postgres\include
 86 | 
 87 | 8. Build DBD::Pg:
 88 | 
 89 | cd \tmp\DBD-Pg1.42
 90 | perl Makefile.PL (when asked for pg_config path, say: .\pg_config.exe )
 91 | nmake
 92 | 
 93 | 9. Test and install
 94 | 
 95 | You should now be able to set things up for normal DBD::Pg testing, 
 96 | which you can invoke via "nmake test"
 97 | 
 98 | Then install using "nmake install"
 99 | 
100 | If you have any problems or questions, please email the DBD::Pg 
101 | mailing list: dbd-pg@perl.org
102 | 
103 | 


--------------------------------------------------------------------------------
/win32.mak:
--------------------------------------------------------------------------------
  1 | 
  2 | ## Makefile for Microsoft Visual C++ 5.0 (or compat)
  3 | 
  4 | ## See the README.win32 file for instructions
  5 | 
  6 | !IF "$(OS)" == "Windows_NT"
  7 | NULL=
  8 | !ELSE 
  9 | NULL=nul
 10 | !ENDIF 
 11 | 
 12 | CPP=cl.exe
 13 | 
 14 | !IFDEF DEBUG
 15 | OPT=/Od /Zi /MDd
 16 | LOPT=/DEBUG
 17 | DEBUGDEF=/D _DEBUG
 18 | OUTDIR=.\Debug
 19 | INTDIR=.\Debug
 20 | !ELSE
 21 | OPT=/O2 /MD
 22 | LOPT=
 23 | DEBUGDEF=/D NDEBUG
 24 | OUTDIR=.\Release
 25 | INTDIR=.\Release
 26 | !ENDIF
 27 | 
 28 | ALL : "..\..\port\pg_config_paths.h" "$(OUTDIR)\pg_config.exe"
 29 | 
 30 | CLEAN :
 31 | 	-@erase "$(INTDIR)\pg_config.obj"
 32 | 	-@erase "$(OUTDIR)\pg_config.exe"
 33 | 	-@erase "$(INTDIR)\..\..\port\pg_config_paths.h"
 34 | 
 35 | "..\..\port\pg_config_paths.h": win32.mak
 36 | 	echo #define PGBINDIR "" >$@
 37 | 	echo #define PGSHAREDIR "" >>$@
 38 | 	echo #define SYSCONFDIR "" >>$@
 39 | 	echo #define INCLUDEDIR "" >>$@
 40 | 	echo #define PKGINCLUDEDIR "" >>$@
 41 | 	echo #define INCLUDEDIRSERVER "" >>$@
 42 | 	echo #define LIBDIR "" >>$@
 43 | 	echo #define PKGLIBDIR "" >>$@
 44 | 	echo #define LOCALEDIR "" >>$@
 45 | 
 46 | "$(OUTDIR)" :
 47 |     if not exist "$(OUTDIR)/$(NULL)" mkdir "$(OUTDIR)"
 48 | 
 49 | CPP_PROJ=/nologo $(OPT) /W3 /GX /D "WIN32" $(DEBUGDEF) /D "_CONSOLE" /D\
 50 |  "_MBCS" /Fp"$(INTDIR)\pg_config.pch" /YX /Fo"$(INTDIR)\\" /Fd"$(INTDIR)\\" /FD /c \
 51 |  /I ..\..\include /I ..\..\interfaces\libpq /I ..\..\include\port\win32 \
 52 |  /D "HAVE_STRDUP" /D "FRONTEND" /D VAL_CONFIGURE="\"\""
 53 | 
 54 | CPP_OBJS=$(INTDIR)/
 55 | CPP_SBRS=.
 56 | 
 57 | LINK32=link.exe
 58 | LINK32_FLAGS=kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib\
 59 |  advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib\
 60 |  odbccp32.lib wsock32.lib /nologo /subsystem:console /incremental:no\
 61 |  /pdb:"$(OUTDIR)\pg_config.pdb" /machine:I386 $(LOPT) /out:"$(OUTDIR)\pg_config.exe" 
 62 | LINK32_OBJS= \
 63 | 	"$(INTDIR)\pg_config.obj" \
 64 | 	"$(INTDIR)\pgstrcasecmp.obj" \
 65 | 	"$(OUTDIR)\path.obj" \
 66 | 	"$(INTDIR)\exec.obj" \
 67 | !IFDEF DEBUG
 68 | 	"..\..\interfaces\libpq\Debug\libpqddll.lib"
 69 | !ELSE
 70 | 	"..\..\interfaces\libpq\Release\libpqdll.lib"
 71 | !ENDIF
 72 | 
 73 | "$(OUTDIR)\pg_config.exe" : "$(OUTDIR)" $(DEF_FILE) $(LINK32_OBJS)
 74 |     $(LINK32) @<<
 75 |   $(LINK32_FLAGS) $(LINK32_OBJS)
 76 | <<
 77 | 
 78 | "$(OUTDIR)\pg_config.obj" : .\pg_config.c
 79 |     $(CPP) @<<
 80 |     $(CPP_PROJ) ..\pg_config.c
 81 | <<
 82 | 
 83 | "$(OUTDIR)\path.obj" : "$(OUTDIR)" ..\..\port\path.c
 84 |     $(CPP) @<<
 85 |     $(CPP_PROJ) ..\..\port\path.c
 86 | <<
 87 | 
 88 | "$(INTDIR)\pgstrcasecmp.obj" : ..\..\port\pgstrcasecmp.c
 89 |     $(CPP) @<<
 90 |     $(CPP_PROJ) ..\..\port\pgstrcasecmp.c
 91 | <<
 92 | 
 93 | "$(INTDIR)\exec.obj" : ..\..\port\exec.c
 94 |     $(CPP) @<<
 95 |     $(CPP_PROJ) ..\..\port\exec.c
 96 | <<
 97 | 
 98 | ..c{$(CPP_OBJS)}.obj::
 99 |    $(CPP) @<<
100 |    $(CPP_PROJ) $< 
101 | <<
102 | 
103 | ..cpp{$(CPP_OBJS)}.obj::
104 |    $(CPP) @<<
105 |    $(CPP_PROJ) $< 
106 | <<
107 | 
108 | 


--------------------------------------------------------------------------------
/t/10_pg_error_field.t:
--------------------------------------------------------------------------------
  1 | #!perl
  2 | 
  3 | ## Test of $dbh->pg_error_field
  4 | 
  5 | use 5.008001;
  6 | use strict;
  7 | use warnings;
  8 | use lib 'blib/lib', 'blib/arch', 't';
  9 | use Test::More;
 10 | require 'dbdpg_test_setup.pl';
 11 | select(($|=1,select(STDERR),$|=1)[1]);
 12 | 
 13 | my $dbh = connect_database();
 14 | 
 15 | if (! $dbh) {
 16 |     plan skip_all => 'Connection to database failed, cannot continue testing';
 17 | }
 18 | 
 19 | my $t='Connect to database for pg_error_field testing';
 20 | isnt ($dbh, undef, $t);
 21 | 
 22 | $t = 'Call to pg_error_field gives a usage error if no specific field given';
 23 | eval {
 24 |     $dbh->pg_error_field;
 25 | };
 26 | like ($@, qr{Usage: }, $t);
 27 | 
 28 | $t = 'Call to pg_error_field gives an error if a null field is given';
 29 | eval {
 30 |     no warnings;
 31 |     $dbh->pg_error_field(undef);
 32 | };
 33 | like ($@, qr{Invalid error field}, $t);
 34 | 
 35 | eval {
 36 |     $dbh->pg_error_field('');
 37 | };
 38 | like ($@, qr{Invalid error field}, $t);
 39 | 
 40 | my $test_table = 'dbdpg_error_field_test';
 41 | 
 42 | my $fields = qq{
 43 | pg_diag_severity_nonlocalized        | 100001 | undef | ERROR             | ERROR | ERROR | ERROR
 44 | pg_diag_severity                     | 70400  | undef | ERROR             | ERROR | ERROR | ERROR
 45 | pg_diag_sqlstate,state               | 70400  | undef | 22012             | 42703 | 23514 | undef
 46 | pg_diag_message_primary              | 70400  | undef | division by zero  | column "foobar" does not exist | violates check constraint "rainbow" | undef
 47 | pg_diag_message_detail,detail        | 90200  | undef | undef             | undef | Failing row contains | undef
 48 | pg_diag_message_hint,hint            | 70400  | undef | undef             | undef | undef | undef
 49 | pg_diag_statement_position           | 80200  | undef | undef             | 8     | undef | undef
 50 | pg_diag_internal_position            | 70400  | undef | undef             | undef | undef | undef
 51 | pg_diag_internal_query               | 70400  | undef | undef             | undef | undef | undef
 52 | pg_diag_context                      | 70400  | undef | undef             | undef | undef | undef
 53 | pg_diag_schema_name,schema           | 90300  | undef | undef             | undef | dbd_pg_testschema | undef
 54 | pg_diag_table_name,table             | 90300  | undef | undef             | undef | $test_table | undef
 55 | pg_diag_column_name,column           | 90300  | undef | undef             | undef | undef | undef
 56 | pg_diag_datatype_name,datatype,type  | 90300  | undef | undef             | undef | undef | undef
 57 | pg_diag_constraint_name,constraint   | 90400  | undef | undef             | undef | rainbow | undef
 58 | pg_diag_source_file                  | 70400  | undef | \\.c\\z      | parse_ | execMain.c | undef
 59 | pg_diag_source_line                  | 70400  | undef | number            | number | number | undef
 60 | pg_diag_source_function              | 70400  | undef | int4div           | Column | ExecConstraints | undef
 61 | };
 62 | 
 63 | $dbh->do("CREATE TABLE $test_table (id int, constraint rainbow check(id < 10) )");
 64 | $dbh->commit();
 65 | 
 66 | my $pgversion = $dbh->{pg_server_version};
 67 | for my $loop (1..5) {
 68 |     if (2==$loop) { eval { $dbh->do('SELECT 1/0'); }; }
 69 |     if (3==$loop) { eval { $dbh->do('SELECT foobar FROM pg_class'); }; }
 70 |     if (4==$loop) {
 71 |         eval { $dbh->do("INSERT INTO $test_table VALUES (123)"); };
 72 |     }
 73 |     if (5==$loop) {
 74 |         my $sth = $dbh->prepare("INSERT INTO $test_table VALUES (?)");
 75 |         eval { $sth->execute(234); };
 76 |     }
 77 | 
 78 |     for (split /\n/ => $fields) {
 79 |         next unless /pg/;
 80 |         my ($lfields,$minversion,@error) = split /\s+\|\s+/;
 81 |         next if $pgversion < $minversion;
 82 |         for my $field (split /,/ => $lfields) {
 83 |             my $expected = $error[5==$loop ? 3 : $loop-1];
 84 |             $expected = undef if $expected eq 'undef';
 85 |             if (defined $expected) {
 86 |                 $expected = ($expected eq 'number') ? qr/^[0-9]+$/ : qr/$expected/i;
 87 |             }
 88 |             $t = "(query $loop) Calling pg_error_field returns expected value for field $field";
 89 |             my $actual = $dbh->pg_error_field($field);
 90 |             defined $expected ? like ($actual, $expected, $t) : is($actual, undef, $t);
 91 | 
 92 |             $field = uc $field;
 93 |             $t = "(query $loop) Calling pg_error_field returns expected value for field $field";
 94 |             $actual = $dbh->pg_error_field($field);
 95 |             defined $expected ? like ($actual, $expected, $t) : is($actual, undef, $t);
 96 | 
 97 |             if ($field =~ s/PG_DIAG_//) {
 98 |                 $t = "(query $loop) Calling pg_error_field returns expected value for field $field";
 99 |                 $actual = $dbh->pg_error_field($field);
100 |                 defined $expected ? like ($actual, $expected, $t) : is($actual, undef, $t);
101 |             }
102 |         }
103 |     }
104 |     $dbh->rollback();
105 | }
106 | 
107 | $dbh->do("DROP TABLE $test_table");
108 | $dbh->commit();
109 | $dbh->disconnect();
110 | 
111 | done_testing();
112 | 
113 | 


--------------------------------------------------------------------------------
/t/99_perlcritic.t:
--------------------------------------------------------------------------------
  1 | #!perl
  2 | 
  3 | ## Run Perl::Critic against the source code and the tests
  4 | ## This is highly customized, so take with a grain of salt
  5 | 
  6 | use 5.008001;
  7 | use strict;
  8 | use warnings;
  9 | use Test::More;
 10 | use Data::Dumper;
 11 | 
 12 | if (! $ENV{AUTHOR_TESTING}) {
 13 |     plan (skip_all =>  'Test skipped unless environment variable AUTHOR_TESTING is set');
 14 | }
 15 | elsif (!eval { require Perl::Critic; 1 }) {
 16 |     plan skip_all => 'Could not find Perl::Critic';
 17 | }
 18 | elsif ($Perl::Critic::VERSION < 0.23) {
 19 |     plan skip_all => 'Perl::Critic must be version 0.23 or higher';
 20 | }
 21 | 
 22 | $ENV{LANG} = 'C';
 23 | opendir my $dir, 't' or die qq{Could not open directory 't': $!\n};
 24 | my @testfiles = map { "t/$_" } grep { /^.+\.(t|pl)$/ } readdir $dir;
 25 | closedir $dir or die qq{Could not closedir "$dir": $!\n};
 26 | 
 27 | ## Check some non-test files
 28 | my $critic = Perl::Critic->new(-severity => 1);
 29 | 
 30 | for my $filename (qw{Pg.pm Makefile.PL lib/Bundle/DBD/Pg.pm }) {
 31 | 
 32 |     if ($ENV{TEST_CRITIC_SKIPNONTEST}) {
 33 |         pass (qq{Skipping non-test file "$filename"});
 34 |         next;
 35 |     }
 36 | 
 37 |     -e $filename or die qq{Could not find "$filename"!};
 38 |     open my $oldstderr, '>&', \*STDERR or die 'Could not dupe STDERR';
 39 |     close STDERR or die qq{Could not close STDERR: $!};
 40 |     my @vio = $critic->critique($filename);
 41 |     open STDERR, '>&', $oldstderr or die 'Could not recreate STDERR'; ## no critic
 42 |     close $oldstderr or die qq{Could not close STDERR copy: $!};
 43 |     my $vios = 0;
 44 |   VIO: for my $v (@vio) {
 45 |         my $d = $v->description();
 46 |         (my $policy = $v->policy()) =~ s/Perl::Critic::Policy:://;
 47 |         my $source = $v->source();
 48 | 
 49 |         ## This one does not respect perlcriticrc at all
 50 |         next if $policy =~ /NamingConventions::Capitalization/;
 51 | 
 52 |         ## These are mostly artifacts of P::C being confused by multiple package layout:
 53 |         next if $policy =~ /ProhibitCallsToUndeclaredSubs/;
 54 |         next if $policy =~ /ProhibitCallsToUnexportedSubs/;
 55 |         next if $policy =~ /RequireExplicitPackage/;
 56 |         next if $policy =~ /RequireUseStrict/;
 57 |         next if $policy =~ /RequireUseWarnings/;
 58 |         next if $policy =~ /RequireExplicitPackage/;
 59 | 
 60 |         ## Allow our sql and qw blocks to have tabs:
 61 |         next if $policy =~ /ProhibitHardTabs/ and ($source =~ /sql = qq/i or $source =~ /qw[\(\/]/);
 62 | 
 63 |         $vios++;
 64 |         my $f = $v->filename();
 65 |         my $l = $v->location();
 66 |         my $line = $l->[0];
 67 |         diag "\nFile: $f (line $line)\n";
 68 |         diag "Vio: $d\n";
 69 |         diag "Policy: $policy\n";
 70 |         diag "Source: $source\n\n";
 71 |     }
 72 |     if ($vios) {
 73 |         fail (qq{Failed Perl::Critic tests for file "$filename": $vios});
 74 |     }
 75 |     else {
 76 |         pass (qq{Passed all Perl::Critic tests for file "$filename"});
 77 |     }
 78 | 
 79 | }
 80 | 
 81 | ## Specific exclusions for test scripts:
 82 | my %ok =
 83 |     (yaml => {
 84 |               sub => 'meta_spec_ok',
 85 |               },
 86 |      pod => {
 87 |              sub => 'pod_file_ok pod_coverage_ok',
 88 |              },
 89 |      signature => {
 90 |              sub => 'verify SIGNATURE_OK',
 91 |              },
 92 | );
 93 | for my $f (keys %ok) {
 94 |     for my $ex (keys %{$ok{$f}}) {
 95 |         if ($ex eq 'sub') {
 96 |             for my $foo (split /\s+/ => $ok{$f}{sub}) {
 97 |                 push @{$ok{$f}{OK}} => qr{Subroutine "$foo" (?:is neither|not exported)};
 98 |             }
 99 |         }
100 |         else {
101 |             die "Unknown exception '$ex'\n";
102 |         }
103 |     }
104 | }
105 | 
106 | ## Allow Test::More subroutines
107 | my $tm = join '|' => (qw/skip plan pass fail is ok diag BAIL_OUT/);
108 | my $testmoreok = qr{Subroutine "$tm" is neither};
109 | 
110 | ## Create a new critic for the tests
111 | $critic = Perl::Critic->new(-severity => 1);
112 | 
113 | for my $filename (sort @testfiles) {
114 |     -e $filename or die qq{Could not find "$filename"!};
115 |     my @vio = $critic->critique($filename);
116 |     my $vios = 0;
117 |   VIO: for my $v (@vio) {
118 |         my $d = $v->description();
119 |         (my $policy = $v->policy()) =~ s/Perl::Critic::Policy:://;
120 |         my $source = $v->source();
121 |         my $f = $v->filename();
122 | 
123 |         ## Skip common Test::More subroutines:
124 |         next if $d =~ $testmoreok;
125 | 
126 |         ## Skip other specific items:
127 |         for my $k (sort keys %ok) {
128 |             next unless $f =~ /$k/;
129 |             for (@{$ok{$k}{OK}}) {
130 |                 next VIO if $d =~ $_;
131 |             }
132 |         }
133 | 
134 |         ## Skip included file package warning
135 |         next if $policy =~ /RequireExplicitPackage/ and $filename =~ /setup/;
136 | 
137 |         $vios++;
138 |         my $l = $v->location();
139 |         my $line = $l->[0];
140 |         diag "\nFile: $f (line $line)\n";
141 |         diag "Vio: $d\n";
142 |         diag "Policy: $policy\n";
143 |         diag "Source: $source\n\n";
144 |     }
145 |     if ($vios) {
146 |         fail (qq{Failed Perl::Critic tests for file "$filename": $vios});
147 |     }
148 |     else {
149 |         pass (qq{Passed all Perl::Critic tests for file "$filename"});
150 |     }
151 | }
152 | 
153 | pass ('Finished Perl::Critic testing');
154 | 
155 | done_testing();
156 | 
157 | 


--------------------------------------------------------------------------------
/t/06bytea.t:
--------------------------------------------------------------------------------
  1 | #!perl
  2 | 
  3 | ## Test bytea handling
  4 | 
  5 | use 5.008001;
  6 | use strict;
  7 | use warnings;
  8 | use lib 'blib/lib', 'blib/arch', 't';
  9 | use Test::More;
 10 | use DBI     ':sql_types';
 11 | use DBD::Pg ':pg_types';
 12 | require 'dbdpg_test_setup.pl';
 13 | select(($|=1,select(STDERR),$|=1)[1]);
 14 | 
 15 | my $dbh = connect_database();
 16 | 
 17 | if (! $dbh) {
 18 |     plan skip_all => 'Connection to database failed, cannot continue testing';
 19 | }
 20 | plan tests => 36;
 21 | 
 22 | isnt ($dbh, undef, 'Connect to database for bytea testing');
 23 | 
 24 | my $pgversion = $dbh->{pg_server_version};
 25 | if ($pgversion >= 80100) {
 26 |     $dbh->do('SET escape_string_warning = false');
 27 | }
 28 | 
 29 | my ($sth, $t);
 30 | 
 31 | $sth = $dbh->prepare(q{INSERT INTO dbd_pg_test (id,bytetest,bytearray,testarray2) VALUES (?,?,'{1,2,3}','{5,6,7}')});
 32 | 
 33 | $t='bytea insert test with string containing null and backslashes';
 34 | $sth->bind_param(1, undef, { pg_type => PG_INT4 });
 35 | $sth->bind_param(2, undef, { pg_type => PG_BYTEA });
 36 | ok ($sth->execute(400, 'aa\\bb\\cc\\\0dd\\'), $t);
 37 | 
 38 | $t='bytea insert test with string containing a single quote';
 39 | ok ($sth->execute(401, '\''), $t);
 40 | 
 41 | $t='bytea (second) insert test with string containing a single quote';
 42 | ok ($sth->execute(402, '\''), $t);
 43 | 
 44 | my ($binary_in, $binary_out);
 45 | $t='store binary data in BYTEA column';
 46 | for(my $i=0; $i<256; $i++) { $binary_out .= chr($i); }
 47 | $sth->{pg_server_prepare} = 0;
 48 | ok ($sth->execute(403, $binary_out), $t);
 49 | $sth->{pg_server_prepare} = 1;
 50 | ok ($sth->execute(404, $binary_out), $t);
 51 | 
 52 | $t='store binary data in BYTEA column via SQL_BLOB';
 53 | $sth = $dbh->prepare(q{INSERT INTO dbd_pg_test (id,bytetest,bytearray,testarray2) VALUES (?,?,'{1,2,3}','{5,6,7}')});
 54 | $sth->bind_param(1, undef, { pg_type => PG_INT4 });
 55 | $sth->bind_param(2, undef, SQL_BLOB);
 56 | ok ($sth->execute(405, $binary_out), $t);
 57 | 
 58 | $t='store binary data in BYTEA column via SQL_BINARY';
 59 | $sth = $dbh->prepare(q{INSERT INTO dbd_pg_test (id,bytetest,bytearray,testarray2) VALUES (?,?,'{1,2,3}','{5,6,7}')});
 60 | $sth->bind_param(1, undef, { pg_type => PG_INT4 });
 61 | $sth->bind_param(2, undef, SQL_BINARY);
 62 | ok ($sth->execute(406, $binary_out), $t);
 63 | 
 64 | $t='store binary data in BYTEA column via SQL_VARBINARY';
 65 | $sth = $dbh->prepare(q{INSERT INTO dbd_pg_test (id,bytetest,bytearray,testarray2) VALUES (?,?,'{1,2,3}','{5,6,7}')});
 66 | $sth->bind_param(1, undef, { pg_type => PG_INT4 });
 67 | $sth->bind_param(2, undef, SQL_VARBINARY);
 68 | ok ($sth->execute(407, $binary_out), $t);
 69 | 
 70 | $t='store binary data in BYTEA column via SQL_LONGVARBINARY';
 71 | $sth = $dbh->prepare(q{INSERT INTO dbd_pg_test (id,bytetest,bytearray,testarray2) VALUES (?,?,'{1,2,3}','{5,6,7}')});
 72 | $sth->bind_param(1, undef, { pg_type => PG_INT4 });
 73 | $sth->bind_param(2, undef, SQL_LONGVARBINARY);
 74 | ok ($sth->execute(408, $binary_out), $t);
 75 | 
 76 | if ($pgversion < 90000) {
 77 |     test_outputs(undef);
 78 |     SKIP: { skip 'No BYTEA output format setting before 9.0', 13 }
 79 | }
 80 | else {
 81 |     test_outputs($_) for qw(hex escape);
 82 | }
 83 | 
 84 | $sth->finish();
 85 | 
 86 | cleanup_database($dbh,'test');
 87 | $dbh->disconnect();
 88 | 
 89 | sub test_outputs {
 90 |     my $output = shift;
 91 |     $dbh->do(qq{SET bytea_output = '$output'}) if $output;
 92 | 
 93 |     $t='Received correct text from BYTEA column with backslashes';
 94 |     $t.=" ($output output)" if $output;
 95 |     $sth = $dbh->prepare(q{SELECT bytetest FROM dbd_pg_test WHERE id=?});
 96 |     $sth->execute(400);
 97 |     my $byte = $sth->fetchall_arrayref()->[0][0];
 98 |     is ($byte, 'aa\bb\cc\\\0dd\\', $t);
 99 | 
100 |     $t='Received correct text from BYTEA column with quote';
101 |     $t.=" ($output output)" if $output;
102 |     $sth->execute(402);
103 |     $byte = $sth->fetchall_arrayref()->[0][0];
104 |     is ($byte, '\'', $t);
105 | 
106 |     $t='Ensure proper handling of high bit characters';
107 |     $t.=" ($output output)" if $output;
108 |     $sth->execute(403);
109 |     ($binary_in) = $sth->fetchrow_array();
110 |     cmp_ok ($binary_in, 'eq', $binary_out, $t);
111 |     $sth->execute(404);
112 |     ($binary_in) = $sth->fetchrow_array();
113 |     ok ($binary_in eq $binary_out, $t);
114 |     $sth->execute(405);
115 |     ($binary_in) = $sth->fetchrow_array();
116 |     cmp_ok ($binary_in, 'eq', $binary_out, $t);
117 |     $sth->execute(406);
118 |     ($binary_in) = $sth->fetchrow_array();
119 |     cmp_ok ($binary_in, 'eq', $binary_out, $t);
120 |     $sth->execute(407);
121 |     ($binary_in) = $sth->fetchrow_array();
122 |     cmp_ok ($binary_in, 'eq', $binary_out, $t);
123 |     $sth->execute(408);
124 |     ($binary_in) = $sth->fetchrow_array();
125 |     cmp_ok ($binary_in, 'eq', $binary_out, $t);
126 | 
127 |     $t='quote properly handles bytea strings';
128 |     $t.=" ($output output)" if $output;
129 |     my $string = "abc\123\\def\0ghi";
130 |     my $result = $dbh->quote($string, { pg_type => PG_BYTEA });
131 |     my $E = $pgversion >= 80100 ? q{E} : q{};
132 |     my $expected = qq{${E}'abc\123\\\\\\\\def\\\\000ghi'};
133 |     is ($result, $expected, $t);
134 |     is ($dbh->quote($string, SQL_BLOB), $expected, "$t (SQL_BLOB)");
135 |     is ($dbh->quote($string, SQL_BINARY), $expected, "$t (SQL_BINARY)");
136 |     is ($dbh->quote($string, SQL_VARBINARY), $expected, "$t (SQL_VARBINARY)");
137 |     is ($dbh->quote($string, SQL_LONGVARBINARY), $expected, "$t (SQL_LONGVARBINARY)");
138 |     return;
139 | }
140 | 


--------------------------------------------------------------------------------
/SIGNATURE:
--------------------------------------------------------------------------------
 1 | This file contains message digests of all files listed in MANIFEST,
 2 | signed via the Module::Signature module, version 0.88.
 3 | 
 4 | To verify the content in this distribution, first make sure you have
 5 | Module::Signature installed, then type:
 6 | 
 7 |     % cpansign -v
 8 | 
 9 | It will check each file's integrity, as well as the signature's
10 | validity.  If "==> Signature verified OK! <==" is not displayed,
11 | the distribution may already have been compromised, and you should
12 | not run its Makefile.PL or Build.PL.
13 | 
14 | -----BEGIN PGP SIGNED MESSAGE-----
15 | Hash: RIPEMD160
16 | 
17 | SHA256 e4c6f4cdc9560a09492f196fc9a180867fab12742d7d05052d9842b395c6a9eb .dir-locals.el
18 | SHA256 88f72a6f8c23e8a33060255223170598b145b00a9bfc7bbea5d18b85bf302430 .perlcriticrc
19 | SHA256 56479e9cf7c00a72bc5458593463a5a6e5481f74f3a4be5ef94129e01c3e2f91 CONTRIBUTING.md
20 | SHA256 59b20a7b6c0980d2c383787bcffb0f7f292441023b7ccddb2351a14ef881dbaa Changes
21 | SHA256 d52a34724b2e3c40ffa2b3b378b574b9e3db27bc3132c88e0be3675f93f378a5 LICENSES/artistic.txt
22 | SHA256 ab15fd526bd8dd18a9e77ebc139656bf4d33e97fc7238cd11bf60e2b9b8666c6 LICENSES/gpl-2.0.txt
23 | SHA256 41e641a5fbbcd2feabc78a372b644fa93e31bda4df515db0b22a2418fd10c800 MANIFEST
24 | SHA256 d047d160c71de8982b183a4b43b932b3a88f88be52bd49fd5d2af66656602fed MANIFEST.SKIP
25 | SHA256 ea408ca4c42d8b19bd400fc0badd6c9a404b91c0ff8a33a0e1d33c835b80d53c META.json
26 | SHA256 206b2fb5d4e3f8ff0cc16eb3045a81ba98cc679ddb401829881587a53cc795a8 META.yml
27 | SHA256 1a2b84ad7404b90348a64f297a024d094d0ebde031c8eb61f9d48659b04b6313 Makefile.PL
28 | SHA256 197aa5c474d2fbf54776dad96defe4f7a4911efdaa2f47af301851fd80bf4ac2 Pg.h
29 | SHA256 76e43d92d4ca732ad01a30b48eee9861a1f03c82655436600c8db1d8838aaea1 Pg.pm
30 | SHA256 288554d935bf3ebf3b59639d7300892951fb3cc6718e4b10421489b89b4c0885 Pg.xs
31 | SHA256 c5433360801a6c5a506abd213c62e87073f5cee9b7a77870ab645798b86f9d35 README
32 | SHA256 7a1b8a9b39498d4a004c467a88a7029120ccf55b354e4aeacc3ea8a85886c43d README.dev
33 | SHA256 a1d224603fe3a343ba0a0f40086065c81d57fbebc734b5382b0d359da16bdd94 README.win32
34 | SHA256 f449097b5796005dffa234e0bcf03863ebe89cb5c573cb50211081d790de2009 TODO
35 | SHA256 c181cbc80d47a01829920ac494bf9064d8598dd022eba859788ab5890c7652c4 dbdimp.c
36 | SHA256 f744d04f9b31cc36d21ec3e43cb515777ea36419c4ad810d63db286ffeccabd8 dbdimp.h
37 | SHA256 9e53f7f41aaaf1b540e2784756ef6f16f61b63df0d9956483aded3c49b6e0f48 dbivport.h
38 | SHA256 5c1172530e9804a26bd21a44ad465ea5c0ac103c85c55d23245c214ddb673e06 lib/Bundle/DBD/Pg.pm
39 | SHA256 9d16f85571f49a89b1385afc205cd3e62fc8c18635c797f9b1d9dd6c502e239c quote.c
40 | SHA256 1ee43f02036bbb68c151903c2718c483ed223aff6cc93fb1408a9158adad9136 quote.h
41 | SHA256 49950c2c882018916ef89b59a1707b732064eb3bb6acb6a350111e1dc81000b8 t/00_signature.t
42 | SHA256 4a95e025f903ed2d6a0aa4470f46f075d4692b9a21bd1d316ead19fb9cabd2dd t/00basic.t
43 | SHA256 72fc8705e85bf1d715c97e55d5ad3e05fd5a6fa40810fd3a582185c790a7af1c t/01connect.t
44 | SHA256 50ce2e03b34dfc5e45c0af8f4078825b1ed449d201f165d8d05453762110ae72 t/01constants.t
45 | SHA256 740497cedb0b21ce09c9719f37b54b25dbde7896ce981c86bc4eeb72d5aaa38a t/02attribs.t
46 | SHA256 f73a75dbc930bacef282e5e0d2c4628cb686f067d2f97a3f66af3385ab5462f2 t/03dbmethod.t
47 | SHA256 233aff8341a9964beeee7afedcc7acac81592123c4b27116eb077fb02ca3dca0 t/03smethod.t
48 | SHA256 a3767a1b6e9adf62ec73f9d38b8bca151eb2fd872d42c2f77aeaef72178b1c56 t/04misc.t
49 | SHA256 d30d52695492fbcb2d051c48d0d3afb621b0d5b29d876208b5fd79c5bc50b3fa t/06bytea.t
50 | SHA256 f172234f057e485a8d5838db6986dbda18f4fe81fcf9ad0885728b8aec31b852 t/07copy.t
51 | SHA256 2e50d0d3cea8c90882a06b99537d7aebcb8d8f062a775831d4b07056e832c4c1 t/08async.t
52 | SHA256 13939607c75558e63395d0d77e78ed2485cd97b2e3d6559e72ec45bffdf333e4 t/09arrays.t
53 | SHA256 97254af96ad61b3306b55ea687db6e5439e18a692f763aabc74bebe85e0c04c9 t/10_pg_error_field.t
54 | SHA256 9a4b3ba6e7931c21fdeab0225777de3512f68e58fc98305da5073694c5f84afe t/12placeholders.t
55 | SHA256 982a438ec73b0428c263ed4608d82fd466a1668cfd4095c69d93ae002486368c t/20savepoints.t
56 | SHA256 6bdf1b5d0bdc049bf8ff8a66d36fc41dfaea2d15e8550dc7e19ce152aa73c918 t/30unicode.t
57 | SHA256 16b874ee36dcedc566b6c9b4c8142173e3a6babc660721939756d8a0a7d697f2 t/99cleanup.t
58 | SHA256 ad3ea24155b8147b09be5bb9da35ec150cd001293a0c6b7abd46c4389ca7530a t/dbdpg_test_setup.pl
59 | SHA256 3f53191613dc10d2d30414f7e6e31a3b3486d91fe07ee77d24ea3d6f2eb61bb6 t/lib/App/Info.pm
60 | SHA256 8faf2c2b3ff952ff0721c04ac8e04ec143939592b0d55a135ea15d310144f576 t/lib/App/Info/Handler.pm
61 | SHA256 e3c5a92afea9c568bf9534a0f13e84864bce0899d2d96857bdaba2c2c565d6e8 t/lib/App/Info/Handler/Print.pm
62 | SHA256 e98cd9cf586aaba135ca06d9029d881337843620de4856b19465aa78674d08ab t/lib/App/Info/Handler/Prompt.pm
63 | SHA256 8519856d47937472c0ad078827319400c235a4c9ed7dadb9f3449937416d7922 t/lib/App/Info/RDBMS.pm
64 | SHA256 1a04a802a38fa8ba2cf001deb6bb20e0e4f9705b93d45600329372c26e108803 t/lib/App/Info/RDBMS/PostgreSQL.pm
65 | SHA256 17ffc3a80591fbdddc74bd13a622284e05421c58f773c8deaaad6e0eae417c77 t/lib/App/Info/Request.pm
66 | SHA256 0cc067040c7056734dec93ea399d7b4dbc7d202aa5c081e6030081c5ed726ff6 t/lib/App/Info/Util.pm
67 | SHA256 5af841e58a48b83733859bfba6c40f9f2a813d7fd87006b6022444a0eacd1a6f testme.tmp.pl
68 | SHA256 dfdf9111f01909ab3ecee11cac318f2cd486d71b178f4de1c5e7195c62eb32fd types.c
69 | SHA256 789d430468f518ec7d46114bae5fcb11f08f29bd573999b02712ac8b6e75a72a types.h
70 | SHA256 4628f92764bdb3e2b04bda7f30fc497231fbbf80dfd24cc09ee3df2e6d6d4387 win32.mak
71 | -----BEGIN PGP SIGNATURE-----
72 | 
73 | iF0EAREDAB0WIQQlKd9quPeUB+lERbS8m5BnFJZKyAUCZXEHHgAKCRC8m5BnFJZK
74 | yAuuAKD80u+u+VeXMXOXUHgYXjjQu2DFCgCfQVGYJnMwRpKbe/uvgAw4IxWu+P8=
75 | =Crme
76 | -----END PGP SIGNATURE-----
77 | 


--------------------------------------------------------------------------------
/t/lib/App/Info/Handler/Prompt.pm:
--------------------------------------------------------------------------------
  1 | package App::Info::Handler::Prompt;
  2 | 
  3 | =head1 NAME
  4 | 
  5 | App::Info::Handler::Prompt - Prompting App::Info event handler
  6 | 
  7 | =head1 SYNOPSIS
  8 | 
  9 |   use App::Info::Category::FooApp;
 10 |   use App::Info::Handler::Print;
 11 | 
 12 |   my $prompter = App::Info::Handler::Print->new;
 13 |   my $app = App::Info::Category::FooApp->new( on_unknown => $prompter );
 14 | 
 15 |   # Or...
 16 |   my $app = App::Info::Category::FooApp->new( on_confirm => 'prompt' );
 17 | 
 18 | =head1 DESCRIPTION
 19 | 
 20 | App::Info::Handler::Prompt objects handle App::Info events by printing their
 21 | messages to C<STDOUT> and then accepting a new value from C<STDIN>. The new
 22 | value is validated by any callback supplied by the App::Info concrete subclass
 23 | that triggered the event. If the value is valid, App::Info::Handler::Prompt
 24 | assigns the new value to the event request. If it isn't it prints the error
 25 | message associated with the event request, and then prompts for the data
 26 | again.
 27 | 
 28 | Although designed with unknown and confirm events in mind,
 29 | App::Info::Handler::Prompt handles info and error events as well. It will
 30 | simply print info event messages to C<STDOUT> and print error event messages
 31 | to C<STDERR>. For more interesting info and error event handling, see
 32 | L<App::Info::Handler::Print|App::Info::Handler::Print> and
 33 | L<App::Info::Handler::Carp|App::Info::Handler::Carp>.
 34 | 
 35 | Upon loading, App::Info::Handler::Print registers itself with
 36 | App::Info::Handler, setting up a single string, "prompt", that can be passed
 37 | to an App::Info concrete subclass constructor. This string is a shortcut that
 38 | tells App::Info how to create an App::Info::Handler::Print object for handling
 39 | events.
 40 | 
 41 | =cut
 42 | 
 43 | use strict;
 44 | use App::Info::Handler;
 45 | our $VERSION = '0.57';
 46 | our @ISA = qw(App::Info::Handler);
 47 | 
 48 | # Register ourselves.
 49 | App::Info::Handler->register_handler
 50 |   ('prompt' => sub { __PACKAGE__->new } );
 51 | 
 52 | =head1 INTERFACE
 53 | 
 54 | =head2 Constructor
 55 | 
 56 | =head3 new
 57 | 
 58 |   my $prompter = App::Info::Handler::Prompt->new;
 59 | 
 60 | Constructs a new App::Info::Handler::Prompt object and returns it. No special
 61 | arguments are required.
 62 | 
 63 | =cut
 64 | 
 65 | sub new {
 66 |     my $pkg = shift;
 67 |     my $self = $pkg->SUPER::new(@_);
 68 |     $self->{tty} = -t STDIN && ( -t STDOUT || !( -f STDOUT || -c STDOUT ) );
 69 |     # We're done!
 70 |     return $self;
 71 | }
 72 | 
 73 | my $get_ans = sub {
 74 |     my ($prompt, $tty, $def) = @_;
 75 |     # Print the message.
 76 |     local $| = 1;
 77 |     local $\;
 78 |     print $prompt;
 79 | 
 80 |     # Collect the answer.
 81 |     my $ans;
 82 |     if ($tty) {
 83 |         $ans = <STDIN>;
 84 |         if (defined $ans ) {
 85 |             chomp $ans;
 86 |         } else { # user hit ctrl-D
 87 |             print "\n";
 88 |         }
 89 |     } else {
 90 |         print "$def\n" if defined $def;
 91 |     }
 92 |     return $ans;
 93 | };
 94 | 
 95 | sub handler {
 96 |     my ($self, $req) = @_;
 97 |     my $ans;
 98 |     my $type = $req->type;
 99 |     if ($type eq 'unknown' || $type eq 'confirm') {
100 |         # We'll want to prompt for a new value.
101 |         my $val = $req->value;
102 |         my ($def, $dispdef) = defined $val ? ($val, " [$val] ") : ('', ' ');
103 |         my $msg = $req->message or Carp::croak("No message in request");
104 |         $msg .= $dispdef;
105 | 
106 |         # Get the answer.
107 |         $ans = $get_ans->($msg, $self->{tty}, $def);
108 |         # Just return if they entered an empty string or we couldnt' get an
109 |         # answer.
110 |         return 1 unless defined $ans && $ans ne '';
111 | 
112 |         # Validate the answer.
113 |         my $err = $req->error;
114 |         while (!$req->value($ans)) {
115 |             print "$err: '$ans'\n";
116 |             $ans = $get_ans->($msg, $self->{tty}, $def);
117 |             return 1 unless defined $ans && $ans ne '';
118 |         }
119 | 
120 |     } elsif ($type eq 'info') {
121 |         # Just print the message.
122 |         print STDOUT $req->message, "\n";
123 |     } elsif ($type eq 'error') {
124 |         # Just print the message.
125 |         print STDERR $req->message, "\n";
126 |     } else {
127 |         # This shouldn't happen.
128 |         Carp::croak("Invalid request type '$type'");
129 |     }
130 | 
131 |     # Return true to indicate that we've handled the request.
132 |     return 1;
133 | }
134 | 
135 | 1;
136 | __END__
137 | 
138 | =head1 SUPPORT
139 | 
140 | This module is stored in an open L<GitHub
141 | repository|http://github.com/theory/app-info/>. Feel free to fork and
142 | contribute!
143 | 
144 | Please file bug reports via L<GitHub
145 | Issues|http://github.com/theory/app-info/issues/> or by sending mail to
146 | L<bug-App-Info@rt.cpan.org|mailto:bug-App-Info@rt.cpan.org>.
147 | 
148 | =head1 AUTHOR
149 | 
150 | David E. Wheeler <david@justatheory.com>
151 | 
152 | =head1 SEE ALSO
153 | 
154 | L<App::Info|App::Info> documents the event handling interface.
155 | 
156 | L<App::Info::Handler::Carp|App::Info::Handler::Carp> handles events by
157 | passing their messages Carp module functions.
158 | 
159 | L<App::Info::Handler::Print|App::Info::Handler::Print> handles events by
160 | printing their messages to a file handle.
161 | 
162 | L<App::Info::Handler|App::Info::Handler> describes how to implement custom
163 | App::Info event handlers.
164 | 
165 | =head1 COPYRIGHT AND LICENSE
166 | 
167 | Copyright (c) 2002-2011, David E. Wheeler. Some Rights Reserved.
168 | 
169 | This module is free software; you can redistribute it and/or modify it under the
170 | same terms as Perl itself.
171 | 
172 | =cut
173 | 


--------------------------------------------------------------------------------
/t/lib/App/Info/Handler/Print.pm:
--------------------------------------------------------------------------------
  1 | package App::Info::Handler::Print;
  2 | 
  3 | =head1 NAME
  4 | 
  5 | App::Info::Handler::Print - Print App::Info event messages
  6 | 
  7 | =head1 SYNOPSIS
  8 | 
  9 |   use App::Info::Category::FooApp;
 10 |   use App::Info::Handler::Print;
 11 | 
 12 |   my $stdout = App::Info::Handler::Print->new( fh => 'stdout' );
 13 |   my $app = App::Info::Category::FooApp->new( on_info => $stdout );
 14 | 
 15 |   # Or...
 16 |   my $app = App::Info::Category::FooApp->new( on_error => 'stderr' );
 17 | 
 18 | =head1 DESCRIPTION
 19 | 
 20 | App::Info::Handler::Print objects handle App::Info events by printing their
 21 | messages to a filehandle. This means that if you want event messages to print
 22 | to a file or to a system filehandle, you can easily do it with this class.
 23 | You'll find, however, that App::Info::Handler::Print is most effective for
 24 | info and error events; unknown and prompt events are better handled by event
 25 | handlers that know how to prompt users for data. See
 26 | L<App::Info::Handler::Prompt|App::Info::Handler::Prompt> for an example of
 27 | that functionality.
 28 | 
 29 | Upon loading, App::Info::Handler::Print registers itself with
 30 | App::Info::Handler, setting up a couple of strings that can be passed to an
 31 | App::Info concrete subclass constructor. These strings are shortcuts that
 32 | tell App::Info how to create the proper App::Info::Handler::Print object
 33 | for handling events. The registered strings are:
 34 | 
 35 | =over 4
 36 | 
 37 | =item stdout
 38 | 
 39 | Prints event messages to C<STDOUT>.
 40 | 
 41 | =item stderr
 42 | 
 43 | Prints event messages to C<STDERR>.
 44 | 
 45 | =back
 46 | 
 47 | See the C<new()> constructor below for how to have App::Info::Handler::Print
 48 | print event messages to different filehandle.
 49 | 
 50 | =cut
 51 | 
 52 | use strict;
 53 | use App::Info::Handler;
 54 | our $VERSION = '0.57';
 55 | our @ISA = qw(App::Info::Handler);
 56 | 
 57 | # Register ourselves.
 58 | for my $c (qw(stderr stdout)) {
 59 |     App::Info::Handler->register_handler
 60 |       ($c => sub { __PACKAGE__->new( fh => $c ) } );
 61 | }
 62 | 
 63 | =head1 INTERFACE
 64 | 
 65 | =head2 Constructor
 66 | 
 67 | =head3 new
 68 | 
 69 |   my $stderr_handler = App::Info::Handler::Print->new;
 70 |   $stderr_handler = App::Info::Handler::Print->new( fh => 'stderr' );
 71 |   my $stdout_handler = App::Info::Handler::Print->new( fh => 'stdout' );
 72 |   my $fh = FileHandle->new($file);
 73 |   my $fh_handler = App::Info::Handler::Print->new( fh => $fh );
 74 | 
 75 | Constructs a new App::Info::Handler::Print and returns it. It can take a
 76 | single parameterized argument, C<fh>, which can be any one of the following
 77 | values:
 78 | 
 79 | =over 4
 80 | 
 81 | =item stderr
 82 | 
 83 | Constructs a App::Info::Handler::Print object that prints App::Info event
 84 | messages to C<STDERR>.
 85 | 
 86 | =item stdout
 87 | 
 88 | Constructs a App::Info::Handler::Print object that prints App::Info event
 89 | messages to C<STDOUT>.
 90 | 
 91 | =item FileHandle
 92 | 
 93 | =item GLOB
 94 | 
 95 | Pass in a reference and App::Info::Handler::Print will assume that it's a
 96 | filehandle reference that it can print to. Note that passing in something that
 97 | can't be printed to will trigger an exception when App::Info::Handler::Print
 98 | tries to print to it.
 99 | 
100 | =back
101 | 
102 | If the C<fh> parameter is not passed, C<new()> will default to creating an
103 | App::Info::Handler::Print object that prints App::Info event messages to
104 | C<STDOUT>.
105 | 
106 | =cut
107 | 
108 | sub new {
109 |     my $pkg = shift;
110 |     my $self = $pkg->SUPER::new(@_);
111 |     if (!defined $self->{fh} || $self->{fh} eq 'stderr') {
112 |         # Create a reference to STDERR.
113 |         $self->{fh} = \*STDERR;
114 |     } elsif ($self->{fh} eq 'stdout') {
115 |         # Create a reference to STDOUT.
116 |         $self->{fh} = \*STDOUT;
117 |     } elsif (!ref $self->{fh}) {
118 |         # Assume a reference to a filehandle or else it's invalid.
119 |         Carp::croak("Invalid argument to new(): '$self->{fh}'");
120 |     }
121 |     # We're done!
122 |     return $self;
123 | }
124 | 
125 | ##############################################################################
126 | 
127 | =head3 handler
128 | 
129 | This method is called by App::Info to print out the message from events.
130 | 
131 | =cut
132 | 
133 | sub handler {
134 |     my ($self, $req) = @_;
135 |     print {$self->{fh}} $req->message, "\n";
136 |     # Return true to indicate that we've handled the request.
137 |     return 1;
138 | }
139 | 
140 | 1;
141 | __END__
142 | 
143 | =head1 SUPPORT
144 | 
145 | This module is stored in an open L<GitHub
146 | repository|http://github.com/theory/app-info/>. Feel free to fork and
147 | contribute!
148 | 
149 | Please file bug reports via L<GitHub
150 | Issues|http://github.com/theory/app-info/issues/> or by sending mail to
151 | L<bug-App-Info@rt.cpan.org|mailto:bug-App-Info@rt.cpan.org>.
152 | 
153 | =head1 AUTHOR
154 | 
155 | David E. Wheeler <david@justatheory.com>
156 | 
157 | =head1 SEE ALSO
158 | 
159 | L<App::Info|App::Info> documents the event handling interface.
160 | 
161 | L<App::Info::Handler::Carp|App::Info::Handler::Carp> handles events by
162 | passing their messages Carp module functions.
163 | 
164 | L<App::Info::Handler::Prompt|App::Info::Handler::Prompt> offers event handling
165 | more appropriate for unknown and confirm events.
166 | 
167 | L<App::Info::Handler|App::Info::Handler> describes how to implement custom
168 | App::Info event handlers.
169 | 
170 | =head1 COPYRIGHT AND LICENSE
171 | 
172 | Copyright (c) 2002-2011, David E. Wheeler. Some Rights Reserved.
173 | 
174 | This module is free software; you can redistribute it and/or modify it under the
175 | same terms as Perl itself.
176 | 
177 | =cut
178 | 


--------------------------------------------------------------------------------
/LICENSES/artistic.txt:
--------------------------------------------------------------------------------
  1 |    The Artistic License
  2 |    August 15, 1997
  3 | 
  4 |   Preamble
  5 | 
  6 |    The intent of this document is to state the conditions under which a
  7 |    Package may be copied, such that the Copyright Holder maintains some
  8 |    semblance of artistic control over the development of the package,
  9 |    while giving the users of the package the right to use and distribute
 10 |    the Package in a more-or-less customary fashion, plus the right to make
 11 |    reasonable modifications.
 12 | 
 13 |   Definitions
 14 | 
 15 |      "Package" refers to the collection of files distributed by the
 16 |      Copyright Holder, and derivatives of that collection of files
 17 |      created through textual modification.
 18 | 
 19 |      "Standard Version" refers to such a Package if it has not been
 20 |      modified, or has been modified in accordance with the wishes of the
 21 |      Copyright Holder as specified below.
 22 | 
 23 |      "Copyright Holder" is whoever is named in the copyright or
 24 |      copyrights for the package.
 25 | 
 26 |      "You" is you, if you're thinking about copying or distributing this
 27 |      Package.
 28 | 
 29 |      "Reasonable copying fee" is whatever you can justify on the basis of
 30 |      media cost, duplication charges, time of people involved, and so on.
 31 |      (You will not be required to justify it to the Copyright Holder, but
 32 |      only to the computing community at large as a market that must bear
 33 |      the fee.)
 34 | 
 35 |      "Freely Available" means that no fee is charged for the item itself,
 36 |      though there may be fees involved in handling the item. It also
 37 |      means that recipients of the item may redistribute it under the same
 38 |      conditions they received it.
 39 | 
 40 |     1. You may make and give away verbatim copies of the source form of
 41 |        the Standard Version of this Package without restriction, provided
 42 |        that you duplicate all of the original copyright notices and
 43 |        associated disclaimers.
 44 |     2. You may apply bug fixes, portability fixes and other modifications
 45 |        derived from the Public Domain or from the Copyright Holder. A
 46 |        Package modified in such a way shall still be considered the
 47 |        Standard Version.
 48 |     3. You may otherwise modify your copy of this Package in any way,
 49 |        provided that you insert a prominent notice in each changed file
 50 |        stating how and when you changed that file, and provided that you
 51 |        do at least ONE of the following:
 52 |          a. place your modifications in the Public Domain or otherwise
 53 |             make them Freely Available, such as by posting said
 54 |             modifications to Usenet or an equivalent medium, or placing
 55 |             the modifications on a major archive site such as
 56 |             uunet.uu.net, or by allowing the Copyright Holder to include
 57 |             your modifications in the Standard Version of the Package.
 58 |          b. use the modified Package only within your corporation or
 59 |             organization.
 60 |          c. rename any non-standard executables so the names do not
 61 |             conflict with standard executables, which must also be
 62 |             provided, and provide a separate manual page for each
 63 |             non-standard executable that clearly documents how it differs
 64 |             from the Standard Version.
 65 |          d. make other distribution arrangements with the Copyright
 66 |             Holder.
 67 |     4. You may distribute the programs of this Package in object code or
 68 |        executable form, provided that you do at least ONE of the
 69 |        following:
 70 |          a. distribute a Standard Version of the executables and library
 71 |             files, together with instructions (in the manual page or
 72 |             equivalent) on where to get the Standard Version.
 73 |          b. accompany the distribution with the machine-readable source of
 74 |             the Package with your modifications.
 75 |          c. give non-standard executables non-standard names, and clearly
 76 |             document the differences in manual pages (or equivalent),
 77 |             together with instructions on where to get the Standard
 78 |             Version.
 79 |          d. make other distribution arrangements with the Copyright
 80 |             Holder.
 81 |     5. You may charge a reasonable copying fee for any distribution of
 82 |        this Package. You may charge any fee you choose for support of this
 83 |        Package. You may not charge a fee for this Package itself. However,
 84 |        you may distribute this Package in aggregate with other (possibly
 85 |        commercial) programs as part of a larger (possibly commercial)
 86 |        software distribution provided that you do not advertise this
 87 |        Package as a product of your own. You may embed this Package's
 88 |        interpreter within an executable of yours (by linking); this shall
 89 |        be construed as a mere form of aggregation, provided that the
 90 |        complete Standard Version of the interpreter is so embedded.
 91 |     6. The scripts and library files supplied as input to or produced as
 92 |        output from the programs of this Package do not automatically fall
 93 |        under the copyright of this Package, but belong to whomever
 94 |        generated them, and may be sold commercially, and may be aggregated
 95 |        with this Package. If such scripts or library files are aggregated
 96 |        with this Package via the so-called "undump" or "unexec" methods of
 97 |        producing a binary executable image, then distribution of such an
 98 |        image shall neither be construed as a distribution of this Package
 99 |        nor shall it fall under the restrictions of Paragraphs 3 and 4,
100 |        provided that you do not represent such an executable image as a
101 |        Standard Version of this Package.
102 |     7. C subroutines (or comparably compiled subroutines in other
103 |        languages) supplied by you and linked into this Package in order to
104 |        emulate subroutines and variables of the language defined by this
105 |        Package shall not be considered part of this Package, but are the
106 |        equivalent of input as in Paragraph 6, provided these subroutines
107 |        do not change the language in any way that would cause it to fail
108 |        the regression tests for the language.
109 |     8. Aggregation of this Package with a commercial distribution is
110 |        always permitted provided that the use of this Package is embedded;
111 |        that is, when no overt attempt is made to make this Package's
112 |        interfaces visible to the end user of the commercial distribution.
113 |        Such use shall not be construed as a distribution of this Package.
114 |     9. The name of the Copyright Holder may not be used to endorse or
115 |        promote products derived from this software without specific prior
116 |        written permission.
117 |    10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
118 |        WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES
119 |        OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
120 | 
121 |                                    The End
122 | 


--------------------------------------------------------------------------------
/.perlcriticrc:
--------------------------------------------------------------------------------
  1 | verbose = %f [%p] %m at line %l, column %c.  (Severity: %s)\n
  2 | profile-strictness = quiet
  3 | exclude = Mardem
  4 | 
  5 | [Documentation::PodSpelling]
  6 | stop_words = ActiveKids afterwards arrayref arrayrefs attr autocommit AutoCommit AutoInactiveDestroy backend bitmask bool boolean Bunce bytea CachedKids cancelled ChildHandles ChopBlanks CompatMode CursorName datatype Datatype datatypes dbd DBD dbdpg dbh DBI deallocation deallocated dev dr DSN enum ErrCount errstr fd FetchHashKeyName filename func getfd getline github HandleError HandleSetErr hashref hashrefs InactiveDestroy JSON largeobject len libpq LongReadLen LongTruncOk lseg Mergl Momjian Mullane nullable NULLABLE Oid OID onwards param ParamTypes ParamValues perl Perlish PgBouncer pgbuiltin pgend pglibpq pglogin pgprefix pgquote PGSERVICE PGSERVICEFILE pgsql pgstart PGSYSCONFDIR PID Postgres PostgreSQL PQexecParams PQexecPrepared PrintError PrintWarn pseudotype RaiseError README ReadOnly RowCache RowCacheSize RowsInCache runtime Sabino savepoint savepoints Savepoints schemas ShowErrorStatement SQL SQLSTATE SSL sslmode STDERR STDIN STDOUT subdirectory tablename tablespace tablespaces TaintIn TaintOut TraceLevel tuple typename undef username Username UTF varchar
  7 | 
  8 | [-Bangs::ProhibitBitwiseOperators]
  9 | [-Bangs::ProhibitCommentedOutCode]
 10 | [-Bangs::ProhibitDebuggingModules]
 11 | [-Bangs::ProhibitFlagComments]
 12 | [-Bangs::ProhibitNumberedNames]
 13 | [-Bangs::ProhibitVagueNames]
 14 | [-BuiltinFunctions::ProhibitBooleanGrep]
 15 | [-BuiltinFunctions::ProhibitComplexMappings]
 16 | [-BuiltinFunctions::ProhibitStringyEval]
 17 | [-BuiltinFunctions::RequireBlockGrep]
 18 | [-ClassHierarchies::ProhibitExplicitISA]
 19 | [-CodeLayout::ProhibitHashBarewords]
 20 | [-CodeLayout::ProhibitParensWithBuiltins]
 21 | [-CodeLayout::ProhibitQuotedWordLists]
 22 | [-CodeLayout::ProhibitSpaceIndentation]
 23 | [-CodeLayout::RequireASCII]
 24 | [-CodeLayout::RequireBreakBeforeOperator]
 25 | [-CodeLayout::RequireKRBracing]
 26 | [-CodeLayout::RequireSpaceAroundBinaryOperators]
 27 | [-CodeLayout::RequireTidyCode]
 28 | [-CodeLayout::RequireTrailingCommaAtNewline]
 29 | [-CodeLayout::RequireUseUTF8]
 30 | [-CodeLayout::TabIndentSpaceAlign]
 31 | [-CognitiveComplexity::ProhibitExcessCognitiveComplexity]
 32 | [-Community::Each]
 33 | [-Community::EmptyReturn]
 34 | [-Community::PackageMatchesFilename]
 35 | [-Community::WhileDiamondDefaultAssignment]
 36 | [-Compatibility::PodMinimumVersion]
 37 | [-ControlStructures::ProhibitCascadingIfElse]
 38 | [-ControlStructures::ProhibitCStyleForLoops]
 39 | [-ControlStructures::ProhibitDeepNests]
 40 | [-ControlStructures::ProhibitMultipleSubscripts]
 41 | [-ControlStructures::ProhibitPostfixControls]
 42 | [-Documentation::RequireLinkedURLs]
 43 | [-Documentation::RequirePod]
 44 | [-Documentation::RequirePodSections]
 45 | [-Documentation::RequirePODUseEncodingUTF8]
 46 | [-Editor::RequireEmacsFileVariables]
 47 | [-ErrorHandling::RequireCarping]
 48 | [-ErrorHandling::RequireCheckingReturnValueOfEval]
 49 | [-Freenode::Each]
 50 | [-Freenode::EmptyReturn]
 51 | [-Freenode::PackageMatchesFilename]
 52 | [-Freenode::StrictWarnings]
 53 | [-Freenode::WhileDiamondDefaultAssignment]
 54 | [-InputOutput::ProhibitBacktickOperators]
 55 | [-InputOutput::ProhibitOneArgSelect]
 56 | [-InputOutput::RequireBriefOpen]
 57 | [-InputOutput::RequireCheckedClose]
 58 | [-InputOutput::RequireCheckedSyscalls]
 59 | [-Lax::ProhibitComplexMappings::LinesNotStatements]
 60 | [-Lax::ProhibitEmptyQuotes::ExceptAsFallback]
 61 | [-Lax::ProhibitStringyEval::ExceptForRequire]
 62 | [-Lax::RequireEndWithTrueConst]
 63 | [-Lax::RequireExplicitPackage::ExceptForPragmata]
 64 | [-logicLAB::ProhibitShellDispatch]
 65 | [-logicLAB::ProhibitUseLib]
 66 | [-logicLAB::RequireParamsValidate]
 67 | [-logicLAB::RequireSheBang]
 68 | [-logicLAB::RequireVersionFormat]
 69 | [-Miscellanea::ProhibitUnrestrictedNoCritic]
 70 | [-Miscellanea::ProhibitUselessNoCritic]
 71 | [-Miscellanea::RequireRcsKeywords]
 72 | [-Modules::ProhibitAutomaticExportation] 
 73 | [-Modules::ProhibitExcessMainComplexity]
 74 | [-Modules::ProhibitMultiplePackages]
 75 | [-Modules::RequireBarewordIncludes]
 76 | [-Modules::RequireEndWithOne]
 77 | [-Modules::RequireExplicitInclusion]
 78 | [-Modules::RequireExplicitPackage]
 79 | [-OTRS::ProhibitDumper]
 80 | [-OTRS::ProhibitLocaltime]
 81 | [-OTRS::ProhibitLowPrecedenceOps]
 82 | [-OTRS::ProhibitOpen]
 83 | [-OTRS::ProhibitRequire]
 84 | [-OTRS::RequireCamelCase]
 85 | [-OTRS::RequireParensWithMethods]
 86 | [-ProhibitImplicitImport]
 87 | [-ProhibitOrReturn]
 88 | [-References::ProhibitDoubleSigils]
 89 | [-RegularExpressions::ProhibitCaptureWithoutTest]
 90 | [-RegularExpressions::ProhibitComplexRegexes]
 91 | [-RegularExpressions::ProhibitEnumeratedClasses]
 92 | [-RegularExpressions::ProhibitEscapedMetacharacters]
 93 | [-RegularExpressions::ProhibitFixedStringMatches]
 94 | [-RegularExpressions::RequireDefault]
 95 | [-RegularExpressions::RequireDotMatchAnything]
 96 | [-RegularExpressions::RequireExtendedFormatting]
 97 | [-RegularExpressions::RequireExtendedFormattingExceptForSplit]
 98 | [-RegularExpressions::RequireLineBoundaryMatching]
 99 | [-Reneeb::ProhibitBlockEval]
100 | [-Subroutines::ProhibitAmbiguousFunctionCalls]
101 | [-Subroutines::ProhibitCallsToUndeclaredSubs]
102 | [-Subroutines::ProhibitCallsToUnexportedSubs]
103 | [-Subroutines::ProhibitExcessComplexity]
104 | [-Subroutines::ProhibitExplicitReturnUndef]
105 | [-Subroutines::ProhibitExportingUndeclaredSubs]
106 | [-Subroutines::ProhibitManyArgs]
107 | [-Subroutines::ProtectPrivateSubs]
108 | [-Subroutines::RequireArgUnpacking]
109 | [-TestingAndDebugging::ProhibitNoWarnings]
110 | [-TestingAndDebugging::RequireTestLabels]
111 | [-Tics::ProhibitLongLines]
112 | [-Tics::ProhibitManyArrows]
113 | [-TooMuchCode::ProhibitDuplicateLiteral]
114 | [-TooMuchCode::ProhibitDuplicateSub]
115 | [-TooMuchCode::ProhibitUnusedConstant]
116 | [-ValuesAndExpressions::PreventSQLInjection]
117 | [-ValuesAndExpressions::ProhibitAccessOfPrivateData]
118 | [-ValuesAndExpressions::ProhibitCommaSeparatedStatements]
119 | [-ValuesAndExpressions::ProhibitConstantPragma]
120 | [-ValuesAndExpressions::ProhibitEmptyQuotes]
121 | [-ValuesAndExpressions::ProhibitImplicitNewlines]
122 | [-ValuesAndExpressions::ProhibitMagicNumbers]
123 | [-ValuesAndExpressions::ProhibitMixedBooleanOperators]
124 | [-ValuesAndExpressions::ProhibitNoisyQuotes]
125 | [-ValuesAndExpressions::ProhibitNoisyQuotes]
126 | [-ValuesAndExpressions::RequireConstantOnLeftSideOfEquality]
127 | [-ValuesAndExpressions::RequireInterpolationOfMetachars]
128 | [-ValuesAndExpressions::RequireNumberSeparators]
129 | [-ValuesAndExpressions::RequireNumericVersion]
130 | [-ValuesAndExpressions::RestrictLongStrings]
131 | [-Variables::ProhibitConditionalDeclarations]
132 | [-Variables::ProhibitLocalVars]
133 | [-Variables::ProhibitPackageVars]
134 | [-Variables::ProhibitPunctuationVars]
135 | [-Variables::RequireHungarianNotation]
136 | [-Variables::RequireInitializationForLocalVars]
137 | [-Variables::RequireLocalizedPunctuationVars]
138 | 
139 | ## Mostly needed for the test files
140 | [-BuiltinFunctions::ProhibitSleepViaSelect]
141 | [-ErrorHandling::RequireUseOfExceptions]
142 | [-Modules::PerlMinimumVersion]
143 | [-Modules::RequirePerlVersion]
144 | [-Modules::RequireVersionVar]
145 | [-ValuesAndExpressions::ProhibitEscapedCharacters]
146 | 
147 | ## Does not seem to work, but here anyway:
148 | [-NamingConventions::Capitalization]
149 | 
150 | [Perlsecret]
151 | allow_secrets = Bang Bang, Venus, Key of Truth
152 | 


--------------------------------------------------------------------------------
/t/00_release.t:
--------------------------------------------------------------------------------
  1 | #!perl
  2 | 
  3 | ## Make sure the version number is consistent in all places
  4 | ## Check on the format of the Changes file
  5 | 
  6 | use 5.010;
  7 | use strict;
  8 | use warnings;
  9 | use lib 'blib/lib', 'blib/arch', 't';
 10 | use Data::Dumper;
 11 | use Test::More;
 12 | use feature 'unicode_strings';
 13 | 
 14 | if (! $ENV{RELEASE_TESTING}) {
 15 |     plan (skip_all =>  'Test skipped unless environment variable RELEASE_TESTING is set');
 16 | }
 17 | plan tests => 3;
 18 | 
 19 | my $vre = qr{([0-9]+\.[0-9]+\.[0-9]+\_?[0-9]*)};
 20 | 
 21 | my %filelist = (
 22 |     'dbdimp.c'             => [1, [ qr{ping test v$vre},        ]],
 23 |     'META.yml'             => [3, [ qr{version\s*:\s*$vre},     ]],
 24 |     'META.json'            => [3, [ qr{"version" : "$vre"},     ]],
 25 |     'Pg.pm'                => [4, [ qr{VERSION = qv\('$vre'},
 26 |                                     qr{realversion = qv\('$vre'},
 27 |                                     qr{documents version $vre},
 28 |                                     qr{ping test v$vre},        ]],
 29 |     'lib/Bundle/DBD/Pg.pm' => [1, [ qr{VERSION = '$vre'},       ]],
 30 |     'Makefile.PL'          => [1, [ qr{VERSION = '$vre'},       ]],
 31 |     'README'               => [1, [ qr{is version $vre},
 32 |                                     qr{TEST VERSION \($vre},    ]],
 33 |     'Changes'              => [1, [ qr{^(?:Version )*$vre},     ]],
 34 | );
 35 | 
 36 | my %v;
 37 | my $goodversion = 1;
 38 | my $goodcopies = 1;
 39 | my $lastversion = '?';
 40 | 
 41 | ## Walk through each file and slurp out the version numbers
 42 | ## Make sure that the version number matches
 43 | ## Verify the total number of version instances in each file as well
 44 | 
 45 | for my $file (sort keys %filelist) {
 46 |     my ($expected,$regexlist) = @{ $filelist{$file} };
 47 | 
 48 |     my $instances = 0;
 49 |     open my $fh, '<', $file or die qq{Could not open "$file": $!\n};
 50 |   SLURP: while (<$fh>) {
 51 |         for my $regex (@{ $regexlist }) {
 52 |             if (/$regex/) {
 53 |                 my $foundversion = $1;
 54 |                 push @{$v{$file}} => [$foundversion, $.];
 55 |                 if ($lastversion =~ /[0-9]/ and $foundversion ne $lastversion) {
 56 |                     $goodversion = 0;
 57 |                 }
 58 |                 $lastversion = $foundversion;
 59 |                 $instances++;
 60 |                 last SLURP if $file eq 'Changes'; ## Only the top version please
 61 |             }
 62 |         }
 63 |     }
 64 |     close $fh or warn qq{Could not close "$file": $!\n};
 65 | 
 66 |     if ($file eq 'README' and $lastversion =~ /_/) {
 67 |         ## Beta gets two mentions in README
 68 |         $expected++;
 69 |     }
 70 | 
 71 |     if ($instances != $expected) {
 72 |         $goodcopies = 0;
 73 |         diag "Version instance mismatch for $file: expected $expected, found $instances";
 74 |     }
 75 | 
 76 | }
 77 | 
 78 | 
 79 | if ($goodcopies) {
 80 |     pass ('All files had the expected number of version strings');
 81 | }
 82 | else {
 83 |     fail ('All files did not have the expected number of version strings');
 84 | }
 85 | 
 86 | if ($goodversion) {
 87 |     pass ("All version numbers are the same ($lastversion)");
 88 | }
 89 | else {
 90 |     fail ('All version numbers were not the same!');
 91 |     for my $filename (sort keys %v) {
 92 |         for my $glob (@{$v{$filename}}) {
 93 |             my ($ver,$line) = @$glob;
 94 |             diag "File: $filename. Line: $line. Version: $ver\n";
 95 |         }
 96 |     }
 97 | }
 98 | 
 99 | my $changes_file_ok = 1;
100 | open my $fh, '<', 'Changes' or die "Could not find the 'Changes' file\n";
101 | my $month = '(January|February|March|April|May|June|July|August|September|October|November|December)'; ## no critic (Variables::ProhibitUnusedVarsStricter)
102 | my ($lastline1, $lastline2, $lastline3) = ('','','');
103 | my $seen_a_version = 0;
104 | while (<$fh>) {
105 |     chomp;
106 |     if (/\bVersion/) {
107 |         next if /unreleased/;
108 |         next if ! $seen_a_version++;
109 | 
110 |         if ($lastline1 =~ /\w/ or $lastline2 =~ /\w/ or $lastline3 !~ /\w/) {
111 |             diag "Changes file fails double spacing before: $_\n";
112 |             $changes_file_ok = 0;
113 |         }
114 | 
115 |         if (! /^Version [0-9]\.[0-9][\.0-9]* /) {
116 |             diag "Changes file version failure: $_\n";
117 |             $changes_file_ok = 0;
118 |         }
119 |         if (! /^Version [0-9]\.[0-9][\.0-9]*  \S/) {
120 |             diag "Changes file spacing failure: $_\n";
121 |             $changes_file_ok = 0;
122 |         }
123 |         if (! /^Version [0-9]\.[0-9][\.0-9]*  \(released $month [0-9][0-9]*, [0-9][0-9][0-9][0-9]\)$/) {
124 |             diag "Changes file release date failure: $_\n";
125 |             $changes_file_ok = 0;
126 |         }
127 |     }
128 |     if (/\w/ and $lastline1 =~ /^Version ([0-9].[0-9][\.0-9]+)/) {
129 |         diag "Changes file does not have space after version $1\n";
130 |         $changes_file_ok = 0;
131 |     }
132 |     $lastline3 = $lastline2;
133 |     $lastline2 = $lastline1;
134 |     $lastline1 = $_;
135 | }
136 | 
137 | ## Check for standardized entries
138 | seek $fh, 0, 0;
139 | $. = 0;
140 | while (<$fh>) {
141 |     chomp;
142 |     next if ! /\w/;
143 |     next if /^RT refers to/;
144 |     next if /^Version [0-9]+\.[0-9]+/;
145 |     next if /^Version \?\?/;
146 |     next if /SYSTEM VIEW/;
147 |     next if /^Changes for/;
148 | 
149 |     my $extra = '(?: and other places)*';
150 | 
151 |     ## RT tickets - three spaces, parens
152 |     next if /^   \(RT ticket \#[0-9]+$extra\)$/;
153 |     ## Two tickets
154 |     next if /^   \(RT tickets \#[0-9]+ and \#[0-9]+\)$/;
155 |     ## Three or more tickets
156 |     next if /^   \(RT tickets \#[0-9]+(?:[, \#0-9])*\)$/;
157 | 
158 |     ## Github issues and pull requests - three spaces, parens
159 |     next if /^   \(Github (?:issue|pull request) #[0-9]+\)$/;
160 | 
161 |     ## Debian issue
162 |     next if /^   \(Debian bug \#[0-9]+\)$/;
163 | 
164 |     ## Should not have any bug tracking keywords now
165 |     if (/RT/ or /github/i or /cpan/i or /debian /i) {
166 |         ## Allow a few exceptions
167 |         if (! /dbdpg.git/ and ! /META/ and ! /cpan\.org/ and ! /Github user/ and ! /Github CI/) {
168 |             fail ("Found mention of bug tracker at wrong place at line $.: $_\n");
169 |             next;
170 |         }
171 |     }
172 | 
173 |     ## Authors - three spaces, bracketed names
174 |     next if /^   \[[A-Z][\w\. \P{IsLower}]+\]$/;
175 | 
176 |     ## Authors - three spaces, email
177 |     next if /^   \[\w[\w\.\-]+ at \w+[\w \.]+\]$/;
178 | 
179 |     ## Spotted by
180 |     next if /^   \[spotted by .*?\]$/;
181 | 
182 |     if (/\[(?![x0-9])/ or /(?=[y0-9])\]/) {
183 |         fail ("Found a brace at line $.: $_\n");
184 |         next;
185 |     }
186 | 
187 |     ## Start of an item
188 |     next if /^ \- [A-Z]\w+/;
189 | 
190 |     ## Continuation line - new sentence
191 |     next if /^   [A-Z][A-Za-z]/; ## Do not want to match RT or CPAN though
192 | 
193 |     ## Continuation line - same sentence
194 |     next if /^     [a-z]/;
195 | 
196 |     die "Unknown line at $. of Changes file: $_\n";
197 | 
198 | }
199 | 
200 | 
201 | close $fh;
202 | 
203 | if ($changes_file_ok) {
204 |     pass (q{The 'Changes' file is in the correct format});
205 | }
206 | else {
207 |     fail (q{The 'Changes' file does not have the correct format});
208 | }
209 | 
210 | 
211 | 
212 | exit;
213 | 
214 | 


--------------------------------------------------------------------------------
/dbdpg_test_postgres_versions.pl:
--------------------------------------------------------------------------------
  1 | #!/usr/bin/env perl
  2 | 
  3 | ## Test combinations of Postgres for DBD::Pg
  4 | ## Usage: $0 <postgresdir> [-t specific_test_file] [-c compile_version] [-r run_version] [--setup versions]
  5 | 
  6 | ## Usage:
  7 | ## Create Postgres 11,12,13,14, and 15 directories in $ENV{HOME}/pg/:
  8 | ## perl dbdpg_test_postgres_versions.pl --setup 11,12,13,14,15
  9 | ## Test all combinations of the same:
 10 | ## perl dbdpg_test_postgres_versions.pl
 11 | ## Only run for versions 12 and up:
 12 | ## perl dbdpg_test_postgres_versions.pl --minversion 11
 13 | ## Same, but do not run head
 14 | ## perl dbdpg_test_postgres_versions.pl --minversion 11 --nohead
 15 | ## Add in the current HEAD branch, recreating if already there:
 16 | ## perl dbdpg_test_postgres_versions.pl --setup head --force
 17 | ## Test DBD::Pg compiled against head and run against Postgres 11:
 18 | ## perl dbdpg_test_postgres_versions.pl -c head -r 11
 19 | 
 20 | 
 21 | use 5.008001;
 22 | use strict;
 23 | use warnings;
 24 | use autodie;
 25 | use Cwd;
 26 | use File::Spec::Functions;
 27 | use Getopt::Long qw/ GetOptions /;
 28 | use Data::Dumper; $Data::Dumper::Sortkeys = 1;
 29 | use Time::HiRes qw/ gettimeofday tv_interval /;
 30 | use List::Util qw/ shuffle /;
 31 | 
 32 | our $VERSION = 1.5;
 33 | 
 34 | my %arg = (
 35 |     quiet => 0,
 36 |     minversion => '',
 37 |     nohead => 0,
 38 | );
 39 | 
 40 | GetOptions
 41 |  (
 42 |    \%arg,
 43 |    'verbose',
 44 |    'quiet',
 45 |    'testfile=s',
 46 |    'compileversion=s',
 47 |    'runversion=s',
 48 |    'wipe',
 49 |    'setup=s',
 50 |    'minversion=s',
 51 |    'nohead',
 52 | );
 53 | 
 54 | my $testfile = $arg{testfile} || $ENV{DBDPG_TEST_FILE} || '';
 55 | my $compileversion = $arg{compileversion} || $ENV{DBDPG_COMPILE_VERSION} || '';
 56 | my $runversion = $arg{runversion} || $ENV{DBDPG_RUN_VERSION} || '';
 57 | 
 58 | my $basedir = shift || "$ENV{HOME}/pg";
 59 | 
 60 | setup_postgres_dirs() if $arg{setup};
 61 | 
 62 | my $dh;
 63 | opendir $dh, $basedir;
 64 | my @versions = grep { /^[1-9][0-9]$/ or /^head$/i } readdir $dh;
 65 | closedir $dh;
 66 | if ($arg{minversion} =~ /^[0-9]+$/) {
 67 |     @versions = grep { ! /^[0-9]+$/ or $_ >= $arg{minversion} } @versions;
 68 | }
 69 | if ($arg{nohead}) {
 70 |     @versions = grep { ! /head/ } @versions;
 71 | }
 72 | 
 73 | ## Sanity check:
 74 | for my $lver (@versions) {
 75 |     my $libdir = "$basedir/$lver/lib";
 76 |     -d $libdir or die qq{Could not find directory: $libdir\n};
 77 | }
 78 | 
 79 | if ($arg{wipe}) {
 80 |     opendir $dh, 'tmp';
 81 |     for my $file (grep { /^alltest\.dbdpg.+\.log$/ } readdir $dh) {
 82 |         unlink "tmp/$file";
 83 |     }
 84 | }
 85 | 
 86 | my $summaryfile = 'tmp/summary.testallversions.log';
 87 | open my $sfh, ($arg{wipe} ? '>' : '>>'), $summaryfile;
 88 | printf {$sfh} "\nSTARTED $0 at %s\n\n", scalar localtime;
 89 | 
 90 | sub note {
 91 |     my $message = shift or die;
 92 |     chomp $message;
 93 |     $arg{quiet} or print "$message\n";
 94 |     print {$sfh} "$message\n";
 95 |     return;
 96 | }
 97 | 
 98 | my $debug_loop = 0;
 99 | for my $lib_version (shuffle @versions) {
100 | 
101 |     next if $compileversion and $compileversion !~ /\b$lib_version\b/;
102 | 
103 |     my $lib_dir = "$basedir/$lib_version";
104 | 
105 |     for my $target_version (shuffle @versions) {
106 | 
107 |         next if $runversion and $runversion !~ /\b$target_version\b/;
108 | 
109 |         my $target_dir = "$basedir/$target_version";
110 | 
111 |         my $readme = 'README.testdatabase';
112 |         unlink $readme if -e $readme;
113 | 
114 |         my $testdbdir = 'dbdpg_test_database';
115 |         if (-d $testdbdir) {
116 |             system("/bin/rm -fr $testdbdir");
117 |         }
118 | 
119 |         my $outfile = "tmp/alltest.dbdpg.$lib_version.vs.$target_version.log";
120 |         note "Testing compile $lib_version against target $target_version: results stored in $outfile";
121 | 
122 |         open my $fh, '>', $outfile;
123 |         printf {$fh} "STARTED $lib_version vs $target_version: %s\n\n", scalar localtime;
124 |         my $start_time = [gettimeofday];
125 | 
126 |         system "perl t/99cleanup.t >> $outfile";
127 | 
128 |         my $COM = "LD_LIBRARY_PATH=$lib_dir/lib POSTGRES_LIB= POSTGRES_INCLUDE= POSTGRES_HOME=$lib_dir perl Makefile.PL 2>&1 >> $outfile";
129 |         note "--> $COM";
130 |         print {$fh} "***\nRUN: $COM\n***\n\n\n";
131 |         print {$fh} qx{$COM};
132 | 
133 |         $COM = "LD_LIBRARY_PATH=$lib_dir/lib DBDPG_TEST_ALWAYS_ENV=0 AUTHOR_TESTING=0 TEST_SIGNATURE=0 DBDPG_INITDB=$target_dir/bin/initdb make test TEST_VERBOSE=1 2>&1 >> $outfile";
134 |         $testfile and $COM =~ s/make test/make test TEST_FILES=$testfile/;
135 |         note "--> $COM";
136 |         print {$fh} "***\nRUN: $COM\n***\n\n\n";
137 |         print {$fh} qx{$COM};
138 | 
139 |         my $final_time = sprintf '%d seconds', tv_interval($start_time);
140 |         print {$fh} "\nTIME: $final_time\n";
141 |         close $fh;
142 | 
143 |         my $final_line = qx{tail -1 $outfile};
144 |         chomp $final_line;
145 |         my $date = scalar localtime;
146 |         if ($final_line !~ /Result/) {
147 |             $final_line = "Result: FAIL $final_line";
148 |         }
149 |         note "--> $final_line $lib_version vs $target_version ($date) ($final_time)\n\n";
150 | 
151 |         if ($debug_loop++ > 300) {
152 |             die "Leaving at loop $debug_loop\n";
153 |         }
154 | 
155 |         ## Just in case we want to catch something
156 |         if ($final_line =~ /FAIL/) {
157 |             warn "Got a failure. Hit Enter to continue, or break out to examine it\n";
158 |             <STDIN>;
159 |         }
160 | 
161 |         sleep 1;
162 | 
163 |     }
164 | }
165 | 
166 | close $sfh;
167 | exit;
168 | 
169 | sub setup_postgres_dirs {
170 | 
171 |     ## Create Postgres directories for one or more versions
172 |     my $versions = $arg{setup};
173 | 
174 |     warn "Setup for version: $versions on dir $basedir\n";
175 | 
176 |     ## Must have a head
177 |     my $giturl = 'https://github.com/postgres/postgres.git';
178 |     my $dir = catfile($basedir, 'pg_github');
179 |     if (-e $dir) {
180 |         chdir $dir;
181 |         system 'git checkout --quiet master';
182 |         system "git pull --quiet -X theirs origin master";
183 |     }
184 |     else {
185 |         system "git clone $giturl $dir";
186 |     }
187 |     ## Grab a list of all tags
188 |     my $old_dir = getcwd();
189 |     chdir($dir);
190 |     my @taglist = qx{git tag -l};
191 |     my %maxversion = (head => ['master','master']);
192 |     for my $entry (@taglist) {
193 |         chomp $entry;
194 |         if ($entry =~ /^REL_?(\d_\d)_(\d+)$/ or $entry =~ /^REL_?(\d\d)_(\d+)$/) {
195 |             my ($major,$revision) = ($1,$2);
196 |             $major =~ y/_/./;
197 |             $maxversion{$major} = [$entry,$revision] if ! exists $maxversion{$major}
198 |                 or $maxversion{$major}->[1] < $revision;
199 |         }
200 |     }
201 | 
202 |     for my $version (split /\s*,\s*/ => lc $arg{setup}) {
203 |         exists $maxversion{$version} or die "Cannot find a tag for Postgres version $version\n";
204 |         my $newdir = catfile($basedir, $version);
205 |         my $install = 0;
206 |         if (-e $newdir) {
207 |             print "Directory already exists: $newdir\n";
208 |             ## However, there may be a newer version!
209 |             my ($existing_revision) = qx{$newdir/bin/psql --version} =~ /\.(\d+)$/;
210 |             if ($existing_revision < $maxversion{$version}->[1]) {
211 |                 printf "For version %s, have revision %d but need %s\n",
212 |                     $version, $existing_revision, $maxversion{$version}->[1];
213 |                 $install = 1;
214 |             }
215 |             else {
216 |                 print "We appear to have the latest revision: $existing_revision\n";
217 |             }
218 |         }
219 |         else {
220 |             $install = 1;
221 |         }
222 | 
223 |         if ($install) {
224 |             chdir($dir);
225 |             my $tag = $maxversion{$version}->[0];
226 |             system "git checkout $tag";
227 |             system 'git clean -fdx';
228 |             my $COM = "./configure --prefix=$newdir --quiet";
229 |             if ($version =~ /^\d/ and $version <= 9.0) {
230 |                 $COM .= ' CFLAGS="-Wno-aggressive-loop-optimizations -O0"';
231 |             }
232 |             print "Running: $COM\n";
233 |             system $COM;
234 |             system 'make install';
235 |         }
236 |     }
237 | 
238 |     exit;
239 | 
240 | } ## end of setup_postgres_dirs
241 | 


--------------------------------------------------------------------------------
/t/99_pod.t:
--------------------------------------------------------------------------------
  1 | #!perl
  2 | 
  3 | ## Check our Pod, requires Test::Pod
  4 | ## Also done if available: Test::Pod::Coverage
  5 | 
  6 | use 5.008001;
  7 | use strict;
  8 | use warnings;
  9 | use Test::More;
 10 | select(($|=1,select(STDERR),$|=1)[1]);
 11 | 
 12 | if (! $ENV{AUTHOR_TESTING}) {
 13 |     plan (skip_all =>  'Test skipped unless environment variable AUTHOR_TESTING is set');
 14 | }
 15 | 
 16 | plan tests => 19;
 17 | 
 18 | my $PODVERSION = '0.95';
 19 | eval {
 20 |     require Test::Pod;
 21 |     Test::Pod->import;
 22 | };
 23 | 
 24 | my @pm_files = qw{
 25 | Pg.pm
 26 | lib/Bundle/DBD/Pg.pm
 27 | t/lib/App/Info.pm
 28 | t/lib/App/Info/RDBMS/PostgreSQL.pm
 29 | t/lib/App/Info/Util.pm
 30 | t/lib/App/Info/Request.pm
 31 | t/lib/App/Info/Handler.pm
 32 | t/lib/App/Info/Handler/Prompt.pm
 33 | t/lib/App/Info/RDBMS.pm
 34 | };
 35 | 
 36 | SKIP: {
 37 |     if ($@ or $Test::Pod::VERSION < $PODVERSION) {
 38 |         skip ("Test::Pod $PODVERSION is required", 9);
 39 |     }
 40 |     for my $filename (@pm_files) {
 41 |         pod_file_ok($filename);
 42 |     }
 43 | }
 44 | 
 45 | ## We won't require everyone to have this, so silently move on if not found
 46 | my $PODCOVERVERSION = '1.04';
 47 | eval {
 48 |     require Test::Pod::Coverage;
 49 |     Test::Pod::Coverage->import;
 50 | };
 51 | SKIP: {
 52 | 
 53 |     if ($@ or $Test::Pod::Coverage::VERSION < $PODCOVERVERSION) {
 54 |         skip ("Test::Pod::Coverage $PODCOVERVERSION is required", 1);
 55 |     }
 56 | 
 57 |     my $trusted_names  =
 58 |         [
 59 |          qr{^CLONE$},
 60 |          qr{^driver$},
 61 |          qr{^constant$},
 62 |          ## Auto-generated from types.c:
 63 |          qr{PG_ACLITEM},
 64 |          qr{PG_ACLITEMARRAY},
 65 |          qr{PG_ANY},
 66 |          qr{PG_ANYARRAY},
 67 |          qr{PG_ANYCOMPATIBLE},
 68 |          qr{PG_ANYCOMPATIBLEARRAY},
 69 |          qr{PG_ANYCOMPATIBLEMULTIRANGE},
 70 |          qr{PG_ANYCOMPATIBLENONARRAY},
 71 |          qr{PG_ANYCOMPATIBLERANGE},
 72 |          qr{PG_ANYELEMENT},
 73 |          qr{PG_ANYENUM},
 74 |          qr{PG_ANYMULTIRANGE},
 75 |          qr{PG_ANYNONARRAY},
 76 |          qr{PG_ANYRANGE},
 77 |          qr{PG_BIT},
 78 |          qr{PG_BITARRAY},
 79 |          qr{PG_BOOL},
 80 |          qr{PG_BOOLARRAY},
 81 |          qr{PG_BOX},
 82 |          qr{PG_BOXARRAY},
 83 |          qr{PG_BPCHAR},
 84 |          qr{PG_BPCHARARRAY},
 85 |          qr{PG_BYTEA},
 86 |          qr{PG_BYTEAARRAY},
 87 |          qr{PG_CHAR},
 88 |          qr{PG_CHARARRAY},
 89 |          qr{PG_CID},
 90 |          qr{PG_CIDARRAY},
 91 |          qr{PG_CIDR},
 92 |          qr{PG_CIDRARRAY},
 93 |          qr{PG_CIRCLE},
 94 |          qr{PG_CIRCLEARRAY},
 95 |          qr{PG_CSTRING},
 96 |          qr{PG_CSTRINGARRAY},
 97 |          qr{PG_DATE},
 98 |          qr{PG_DATEARRAY},
 99 |          qr{PG_DATEMULTIRANGE},
100 |          qr{PG_DATEMULTIRANGEARRAY},
101 |          qr{PG_DATERANGE},
102 |          qr{PG_DATERANGEARRAY},
103 |          qr{PG_EVENT_TRIGGER},
104 |          qr{PG_FDW_HANDLER},
105 |          qr{PG_FLOAT4},
106 |          qr{PG_FLOAT4ARRAY},
107 |          qr{PG_FLOAT8},
108 |          qr{PG_FLOAT8ARRAY},
109 |          qr{PG_GTSVECTOR},
110 |          qr{PG_GTSVECTORARRAY},
111 |          qr{PG_INDEX_AM_HANDLER},
112 |          qr{PG_INET},
113 |          qr{PG_INETARRAY},
114 |          qr{PG_INT2},
115 |          qr{PG_INT2ARRAY},
116 |          qr{PG_INT2VECTOR},
117 |          qr{PG_INT2VECTORARRAY},
118 |          qr{PG_INT4},
119 |          qr{PG_INT4ARRAY},
120 |          qr{PG_INT4MULTIRANGE},
121 |          qr{PG_INT4MULTIRANGEARRAY},
122 |          qr{PG_INT4RANGE},
123 |          qr{PG_INT4RANGEARRAY},
124 |          qr{PG_INT8},
125 |          qr{PG_INT8ARRAY},
126 |          qr{PG_INT8MULTIRANGE},
127 |          qr{PG_INT8MULTIRANGEARRAY},
128 |          qr{PG_INT8RANGE},
129 |          qr{PG_INT8RANGEARRAY},
130 |          qr{PG_INTERNAL},
131 |          qr{PG_INTERVAL},
132 |          qr{PG_INTERVALARRAY},
133 |          qr{PG_JSON},
134 |          qr{PG_JSONARRAY},
135 |          qr{PG_JSONB},
136 |          qr{PG_JSONBARRAY},
137 |          qr{PG_JSONPATH},
138 |          qr{PG_JSONPATHARRAY},
139 |          qr{PG_LANGUAGE_HANDLER},
140 |          qr{PG_LINE},
141 |          qr{PG_LINEARRAY},
142 |          qr{PG_LSEG},
143 |          qr{PG_LSEGARRAY},
144 |          qr{PG_MACADDR},
145 |          qr{PG_MACADDR8},
146 |          qr{PG_MACADDR8ARRAY},
147 |          qr{PG_MACADDRARRAY},
148 |          qr{PG_MONEY},
149 |          qr{PG_MONEYARRAY},
150 |          qr{PG_NAME},
151 |          qr{PG_NAMEARRAY},
152 |          qr{PG_NUMERIC},
153 |          qr{PG_NUMERICARRAY},
154 |          qr{PG_NUMMULTIRANGE},
155 |          qr{PG_NUMMULTIRANGEARRAY},
156 |          qr{PG_NUMRANGE},
157 |          qr{PG_NUMRANGEARRAY},
158 |          qr{PG_OID},
159 |          qr{PG_OIDARRAY},
160 |          qr{PG_OIDVECTOR},
161 |          qr{PG_OIDVECTORARRAY},
162 |          qr{PG_PATH},
163 |          qr{PG_PATHARRAY},
164 |          qr{PG_PG_ATTRIBUTE},
165 |          qr{PG_PG_ATTRIBUTEARRAY},
166 |          qr{PG_PG_BRIN_BLOOM_SUMMARY},
167 |          qr{PG_PG_BRIN_MINMAX_MULTI_SUMMARY},
168 |          qr{PG_PG_CLASS},
169 |          qr{PG_PG_CLASSARRAY},
170 |          qr{PG_PG_DDL_COMMAND},
171 |          qr{PG_PG_DEPENDENCIES},
172 |          qr{PG_PG_LSN},
173 |          qr{PG_PG_LSNARRAY},
174 |          qr{PG_PG_MCV_LIST},
175 |          qr{PG_PG_NDISTINCT},
176 |          qr{PG_PG_NODE_TREE},
177 |          qr{PG_PG_PROC},
178 |          qr{PG_PG_PROCARRAY},
179 |          qr{PG_PG_SNAPSHOT},
180 |          qr{PG_PG_SNAPSHOTARRAY},
181 |          qr{PG_PG_TYPE},
182 |          qr{PG_PG_TYPEARRAY},
183 |          qr{PG_POINT},
184 |          qr{PG_POINTARRAY},
185 |          qr{PG_POLYGON},
186 |          qr{PG_POLYGONARRAY},
187 |          qr{PG_RECORD},
188 |          qr{PG_RECORDARRAY},
189 |          qr{PG_REFCURSOR},
190 |          qr{PG_REFCURSORARRAY},
191 |          qr{PG_REGCLASS},
192 |          qr{PG_REGCLASSARRAY},
193 |          qr{PG_REGCOLLATION},
194 |          qr{PG_REGCOLLATIONARRAY},
195 |          qr{PG_REGCONFIG},
196 |          qr{PG_REGCONFIGARRAY},
197 |          qr{PG_REGDICTIONARY},
198 |          qr{PG_REGDICTIONARYARRAY},
199 |          qr{PG_REGNAMESPACE},
200 |          qr{PG_REGNAMESPACEARRAY},
201 |          qr{PG_REGOPER},
202 |          qr{PG_REGOPERARRAY},
203 |          qr{PG_REGOPERATOR},
204 |          qr{PG_REGOPERATORARRAY},
205 |          qr{PG_REGPROC},
206 |          qr{PG_REGPROCARRAY},
207 |          qr{PG_REGPROCEDURE},
208 |          qr{PG_REGPROCEDUREARRAY},
209 |          qr{PG_REGROLE},
210 |          qr{PG_REGROLEARRAY},
211 |          qr{PG_REGTYPE},
212 |          qr{PG_REGTYPEARRAY},
213 |          qr{PG_TABLE_AM_HANDLER},
214 |          qr{PG_TEXT},
215 |          qr{PG_TEXTARRAY},
216 |          qr{PG_TID},
217 |          qr{PG_TIDARRAY},
218 |          qr{PG_TIME},
219 |          qr{PG_TIMEARRAY},
220 |          qr{PG_TIMESTAMP},
221 |          qr{PG_TIMESTAMPARRAY},
222 |          qr{PG_TIMESTAMPTZ},
223 |          qr{PG_TIMESTAMPTZARRAY},
224 |          qr{PG_TIMETZ},
225 |          qr{PG_TIMETZARRAY},
226 |          qr{PG_TRIGGER},
227 |          qr{PG_TSMULTIRANGE},
228 |          qr{PG_TSMULTIRANGEARRAY},
229 |          qr{PG_TSM_HANDLER},
230 |          qr{PG_TSQUERY},
231 |          qr{PG_TSQUERYARRAY},
232 |          qr{PG_TSRANGE},
233 |          qr{PG_TSRANGEARRAY},
234 |          qr{PG_TSTZMULTIRANGE},
235 |          qr{PG_TSTZMULTIRANGEARRAY},
236 |          qr{PG_TSTZRANGE},
237 |          qr{PG_TSTZRANGEARRAY},
238 |          qr{PG_TSVECTOR},
239 |          qr{PG_TSVECTORARRAY},
240 |          qr{PG_TXID_SNAPSHOT},
241 |          qr{PG_TXID_SNAPSHOTARRAY},
242 |          qr{PG_UNKNOWN},
243 |          qr{PG_UUID},
244 |          qr{PG_UUIDARRAY},
245 |          qr{PG_VARBIT},
246 |          qr{PG_VARBITARRAY},
247 |          qr{PG_VARCHAR},
248 |          qr{PG_VARCHARARRAY},
249 |          qr{PG_VOID},
250 |          qr{PG_XID},
251 |          qr{PG_XID8},
252 |          qr{PG_XID8ARRAY},
253 |          qr{PG_XIDARRAY},
254 |          qr{PG_XML},
255 |          qr{PG_XMLARRAY},
256 | 
257 |         ];
258 | 
259 |     my $t='DBD::Pg pod coverage okay';
260 |     pod_coverage_ok ('DBD::Pg', {trustme => $trusted_names}, $t);
261 | }
262 | 
263 | ## Now some things that are not covered by the above tests
264 | 
265 | for my $filename (@pm_files) {
266 |     open my $fh, '<', $filename or die qq{Could not open "$filename": $!\n};
267 |     while (<$fh>) {
268 |         last if /^=/;
269 |     }
270 |     next if ! defined $_; ## no critic
271 |     ## Assume the rest is POD.
272 |     my $passed = 1;
273 |     while (<$fh>) {
274 |         if (/C<[^<].+[<>].+[^>]>\b/) {
275 |             $passed = 0;
276 |             diag "Failed POD escaping on line $. of $filename\n";
277 |             diag $_;
278 |         }
279 |     }
280 |     close $fh or warn qq{Could not close "$filename": $!\n};
281 |     if ($passed) {
282 |         pass ("File $filename has no POD errors");
283 |     }
284 |     else {
285 |         fail ("File $filename had at least one POD error");
286 |     }
287 | }
288 | 


--------------------------------------------------------------------------------
/t/99_lint.t:
--------------------------------------------------------------------------------
  1 | #!perl
  2 | 
  3 | ## Various code cleanup checks
  4 | 
  5 | use 5.008001;
  6 | use strict;
  7 | use warnings;
  8 | use Test::More;
  9 | use File::Find;
 10 | 
 11 | my (@testfiles,@perlfiles,@cfiles,@headerfiles,%fileslurp,$t);
 12 | 
 13 | if (! $ENV{AUTHOR_TESTING}) {
 14 |     plan (skip_all =>  'Test skipped unless environment variable AUTHOR_TESTING is set');
 15 | }
 16 | 
 17 | $ENV{LANG} = 'C';
 18 | find (sub { push @cfiles      => $File::Find::name if /^[^.].+\.c$/ and $_ ne 'Pg.c' and $File::Find::dir !~ /tmp/; }, '.');
 19 | find (sub { push @headerfiles => $File::Find::name if /^[^.].+\.h$/ and $_ ne 'dbivport.h' and $File::Find::dir !~ /tmp/; }, '.');
 20 | find (sub { push @testfiles   => $File::Find::name if /^[^.]\w+\.(t|pl)$/; }, 't');
 21 | find (sub { push @perlfiles   => $File::Find::name if /^[^.].+\.(pm|pl|t)$/ and $File::Find::dir !~ /tmp/; }, '.');
 22 | 
 23 | ##
 24 | ## Load all Test::More calls into memory
 25 | ##
 26 | my $testmore = 0;
 27 | for my $file (@testfiles) {
 28 |     open my $fh, '<', $file or die qq{Could not open "$file": $!\n};
 29 |     my $line;
 30 |     while (defined($line = <$fh>)) {
 31 |         last if $line =~ /__DATA__/; ## perlcritic.t
 32 |         for my $func (qw/ok isnt pass fail cmp cmp_ok is_deeply unlike like/) { ## no skip
 33 |             next if $line !~ /\b$func\b/;
 34 |             next if $line =~ /$func \w/; ## e.g. 'skip these tests'
 35 |             next if $line =~ /[\$\%]$func/; ## e.g. $ok %ok
 36 |             next if $line =~ /['"][^'"]*$func/; ## e.g. 'like' in quotes
 37 |             $fileslurp{$file}{$.}{$func} = $line;
 38 |             $testmore++;
 39 |         }
 40 |     }
 41 |     close $fh or die qq{Could not close "$file": $!\n};
 42 | }
 43 | 
 44 | ok (@testfiles, 'Found files in test directory');
 45 | 
 46 | ##
 47 | ## Make sure the README.dev mentions all files used, and jives with the MANIFEST
 48 | ##
 49 | my $file = 'README.dev';
 50 | open my $fh, '<', $file or die qq{Could not open "$file": $!\n};
 51 | my $point = 1;
 52 | my %devfile;
 53 | while (<$fh>) {
 54 |     chomp;
 55 |     if (1 == $point) {
 56 |         next unless /File List/;
 57 |         $point = 2;
 58 |         next;
 59 |     }
 60 |     last if /= Compiling/;
 61 |     if (m{^([\w\./-]+) \- }) {
 62 |         $devfile{$1} = $.;
 63 |         next;
 64 |     }
 65 |     if (m{^(t/.+)}) {
 66 |         $devfile{$1} = $.;
 67 |     }
 68 | }
 69 | close $fh or die qq{Could not close "$file": $!\n};
 70 | 
 71 | $file = 'MANIFEST';
 72 | my %manfile;
 73 | open $fh, '<', $file or die qq{Could not open "$file": $!\n};
 74 | while (<$fh>) {
 75 |     next unless /^(\S.+)/;
 76 |     $manfile{$1} = $.;
 77 | }
 78 | close $fh or die qq{Could not close "$file": $!\n};
 79 | 
 80 | $file = 'MANIFEST.SKIP';
 81 | open $fh, '<', $file or die qq{Could not open "$file": $!\n};
 82 | while (<$fh>) {
 83 |     next unless m{^(t/.*)};
 84 |     $manfile{$1} = $.;
 85 | }
 86 | close $fh or die qq{Could not close "$file": $!\n};
 87 | 
 88 | ##
 89 | ## Everything in MANIFEST[.SKIP] should also be in README.dev
 90 | ##
 91 | for my $file (sort keys %manfile) {
 92 |     if (!exists $devfile{$file}) {
 93 |         fail qq{File "$file" is in MANIFEST but not in README.dev\n};
 94 |     }
 95 | }
 96 | 
 97 | ##
 98 | ## Everything in README.dev should also be in MANIFEST, except special files
 99 | ##
100 | my %derived = map { $_, 1 } qw/Makefile Pg.c README.testdatabase dbdpg_test_database dbdpg_test_postgres_versions.pl/;
101 | for my $file (sort keys %devfile) {
102 |     if (!exists $manfile{$file} and !exists $derived{$file}) {
103 |         fail qq{File "$file" is in README.dev but not in MANIFEST\n};
104 |     }
105 |     if (exists $manfile{$file} and exists $derived{$file}) {
106 |         fail qq{File "$file" is derived and should not be in MANIFEST\n};
107 |     }
108 | }
109 | 
110 | ##
111 | ## Make sure all Test::More function calls are standardized
112 | ##
113 | for my $file (sort keys %fileslurp) {
114 |     for my $linenum (sort {$a <=> $b} keys %{$fileslurp{$file}}) {
115 |         for my $func (sort keys %{$fileslurp{$file}{$linenum}}) {
116 |             $t=qq{Test::More method "$func" is in standard format inside $file at line $linenum};
117 |             my $line = $fileslurp{$file}{$linenum}{$func};
118 |             ## Must be at start of line (optional whitespace and comment), a space, a paren, and something interesting
119 |             next if $line =~ /\w+ fail/;
120 |             next if $line =~ /defined \$expected \? like/;
121 |             like ($line, qr{^\s*#?$func \(['\S]}, $t);
122 |         }
123 |     }
124 | }
125 | 
126 | ##
127 | ## Check C and Perl files for errant tabs
128 | ##
129 | for my $file (@cfiles, @headerfiles, @perlfiles) {
130 |     my $tabfail = 0;
131 |     open my $fh, '<', $file or die "Could not open $file: $!\n";
132 |     while (<$fh>) {
133 |         $tabfail++ if /\t/;
134 |     }
135 |     close $fh;
136 |     if ($tabfail) {
137 |         fail (qq{File "$file" contains one or more tabs: $tabfail});
138 |     }
139 |     else {
140 |         pass (qq{File "$file" has no tabs});
141 |     }
142 | }
143 | 
144 | ##
145 | ## Make sure all Perl files request the same minimum version of Perl
146 | ##
147 | my $firstversion = 0;
148 | my %ver;
149 | for my $file (@perlfiles) {
150 | 
151 |     ## The App::Info items do not need this check
152 |     next if $file =~ m{/App/Info};
153 | 
154 |     ## Skip this one for now, it needs slightly higher version
155 |     next if $file =~ /00_release/;
156 | 
157 |     open my $fh, '<', $file or die "Could not open $file: $!\n";
158 |     my $minversion = 0;
159 |     while (<$fh>) {
160 |         if (/^use ([0-9]+\.[0-9]+);$/) {
161 |             $minversion = $1;
162 |             $firstversion ||= $minversion;
163 |             $ver{$file} = $minversion;
164 |             last;
165 |         }
166 |     }
167 | 
168 |     close $fh;
169 |     if ($minversion) {
170 |         pass (qq{Found a minimum Perl version of $minversion for the file $file});
171 |     }
172 |     else {
173 |         fail (qq{Failed to find a minimum Perl version for the file $file});
174 |     }
175 | }
176 | 
177 | for my $file (sort keys %ver) {
178 |     my $version = $ver{$file};
179 |     if ($version eq $firstversion) {
180 |         pass(qq{Correct minimum Perl version ($firstversion) for file $file});
181 |     }
182 |     else {
183 |         fail(qq{Wrong minimum Perl version ($version is not $firstversion) for file $file});
184 |     }
185 | }
186 | 
187 | ##
188 | ## Check for stale or duplicated spelling words
189 | ##
190 | $file = 't/99_spellcheck.t';
191 | open $fh, '<', $file or die "Could not open $file: $!\n";
192 | 1 while <$fh> !~ /__DATA__/;
193 | my %word;
194 | my $dupes = 0;
195 | while (<$fh>) {
196 |     next if /^#/ or /^\s*$/;
197 |     chomp;
198 |     $dupes++ if $word{$_}++;
199 | }
200 | 
201 | $t = q{Number of duplicate spelling word entries is zero};
202 | is ($dupes, 0, $t);
203 | 
204 | for my $file (qw{
205 |     README Changes TODO README.dev README.win32 CONTRIBUTING.md
206 |     Pg.pm Pg.xs dbdimp.c quote.c Makefile.PL Pg.h types.c dbdimp.h
207 |     t/03dbmethod.t t/03smethod.t t/12placeholders.t t/01constants.t t/99_yaml.t
208 |     testme.tmp.pl dbdpg_test_postgres_versions.pl
209 | }) {
210 |     open $fh, '<', $file or die "Could not open $file: $!\n";
211 |     while (<$fh>) {
212 |         s{([A-Za-z][A-Za-z']+)}{(my $x = $1) =~ s/'$//; delete $word{$x}; ' '}ge;
213 |     }
214 | }
215 | 
216 | $t = q{Number of unused spelling words is zero};
217 | my $unused_words = keys %word;
218 | is ($unused_words, 0, $t);
219 | 
220 | my $stop = 0;
221 | for my $x (sort keys %word) {
222 |     diag "Unused: $x\n";
223 |     last if $stop++ > 10;
224 | }
225 | 
226 | ##
227 | ## Make sure all ENV calls in Perl files are known words
228 | ##
229 | my $good_var_names = '
230 | DBI_DSN DBI_USER DBI_PASS
231 | DBDPG_INITDB DBDPG_DEBUG DBDPG_NOCLEANUP DBDPG_TESTINITDB DBDPG_TEST_ALWAYS_ENV DBDPG_TEST_NOHELPFILE DBDPG_TEMPDIR
232 | POSTGRES_HOME PGDATABASE PGINITDB
233 | LANG USER
234 | AUTHOR_TESTING RELEASE_TESTING TEST_CRITIC_SKIPNONTEST TEST_OUTPUT TEST_SIGNATURE
235 | ';
236 | my %valid_env = map { $_=>1 } split /\s+/ => $good_var_names;
237 | my %bad_env;
238 | for my $file (@testfiles) {
239 |     open my $fh, '<', $file or die qq{Could not open "$file": $!\n};
240 |     while (<$fh>) {
241 |         while (/\$ENV\{([^\$].*?)\}/g) {
242 |             $bad_env{$1}++ if ! exists $valid_env{$1};
243 |         }
244 |     }
245 | }
246 | 
247 | $t = q{All ENV{} calls are to known words};
248 | %bad_env ? fail($t) : pass($t);
249 | for my $word (sort keys %bad_env) {
250 |     diag "Invalid ENV: $word\n";
251 | }
252 | 
253 | $t = q{Verify the copyright year is up to date};
254 | my $current_year = 1900 +(localtime)[5];
255 | 
256 | for my $file (qw{README Pg.pm Pg.xs Pg.h dbdimp.c dbdimp.h quote.c types.c}) {
257 |     open $fh, '<', $file or die "Could not open $file: $!\n";
258 |     while (<$fh>) {
259 |         next unless /Copyright(.+)Greg/;
260 |         my $years = $1;
261 |         if ($years !~ /\b$current_year\b/) {
262 |             fail qq{File "$file" has the wrong copyright year: expected $current_year};
263 |         }
264 |     }
265 | }
266 | pass $t;
267 | 
268 | 
269 | done_testing();
270 | 


--------------------------------------------------------------------------------
/t/01keywords.t:
--------------------------------------------------------------------------------
  1 | #!perl
  2 | 
  3 | use 5.008001;
  4 | use strict;
  5 | use warnings;
  6 | use lib 'blib/lib', 'blib/arch', 't';
  7 | use Test::More;
  8 | select(($|=1,select(STDERR),$|=1)[1]);
  9 | 
 10 | use DBD::Pg ();
 11 | 
 12 | for (
 13 | # BEGIN GENERATED KEYWORDS
 14 |   'abort',
 15 |   'absent',
 16 |   'absolute',
 17 |   'access',
 18 |   'action',
 19 |   'add',
 20 |   'admin',
 21 |   'after',
 22 |   'aggregate',
 23 |   'all',
 24 |   'also',
 25 |   'alter',
 26 |   'always',
 27 |   'analyse',
 28 |   'analyze',
 29 |   'and',
 30 |   'any',
 31 |   'array',
 32 |   'as',
 33 |   'asc',
 34 |   'asensitive',
 35 |   'assertion',
 36 |   'assignment',
 37 |   'asymmetric',
 38 |   'at',
 39 |   'atomic',
 40 |   'attach',
 41 |   'attribute',
 42 |   'authorization',
 43 |   'backward',
 44 |   'before',
 45 |   'begin',
 46 |   'between',
 47 |   'bigint',
 48 |   'binary',
 49 |   'bit',
 50 |   'boolean',
 51 |   'both',
 52 |   'breadth',
 53 |   'by',
 54 |   'cache',
 55 |   'call',
 56 |   'called',
 57 |   'cascade',
 58 |   'cascaded',
 59 |   'case',
 60 |   'cast',
 61 |   'catalog',
 62 |   'chain',
 63 |   'char',
 64 |   'character',
 65 |   'characteristics',
 66 |   'check',
 67 |   'checkpoint',
 68 |   'class',
 69 |   'close',
 70 |   'cluster',
 71 |   'coalesce',
 72 |   'collate',
 73 |   'collation',
 74 |   'column',
 75 |   'columns',
 76 |   'comment',
 77 |   'comments',
 78 |   'commit',
 79 |   'committed',
 80 |   'compression',
 81 |   'concurrently',
 82 |   'configuration',
 83 |   'conflict',
 84 |   'connection',
 85 |   'constraint',
 86 |   'constraints',
 87 |   'content',
 88 |   'continue',
 89 |   'conversion',
 90 |   'copy',
 91 |   'cost',
 92 |   'create',
 93 |   'cross',
 94 |   'csv',
 95 |   'cube',
 96 |   'current',
 97 |   'current_catalog',
 98 |   'current_date',
 99 |   'current_role',
100 |   'current_schema',
101 |   'current_time',
102 |   'current_timestamp',
103 |   'current_user',
104 |   'cursor',
105 |   'cycle',
106 |   'data',
107 |   'database',
108 |   'day',
109 |   'deallocate',
110 |   'dec',
111 |   'decimal',
112 |   'declare',
113 |   'default',
114 |   'defaults',
115 |   'deferrable',
116 |   'deferred',
117 |   'definer',
118 |   'delete',
119 |   'delimiter',
120 |   'delimiters',
121 |   'depends',
122 |   'depth',
123 |   'desc',
124 |   'detach',
125 |   'dictionary',
126 |   'disable',
127 |   'discard',
128 |   'distinct',
129 |   'do',
130 |   'document',
131 |   'domain',
132 |   'double',
133 |   'drop',
134 |   'each',
135 |   'else',
136 |   'enable',
137 |   'encoding',
138 |   'encrypted',
139 |   'end',
140 |   'enum',
141 |   'escape',
142 |   'event',
143 |   'except',
144 |   'exclude',
145 |   'excluding',
146 |   'exclusive',
147 |   'execute',
148 |   'exists',
149 |   'explain',
150 |   'expression',
151 |   'extension',
152 |   'external',
153 |   'extract',
154 |   'false',
155 |   'family',
156 |   'fetch',
157 |   'filter',
158 |   'finalize',
159 |   'first',
160 |   'float',
161 |   'following',
162 |   'for',
163 |   'force',
164 |   'foreign',
165 |   'format',
166 |   'forward',
167 |   'freeze',
168 |   'from',
169 |   'full',
170 |   'function',
171 |   'functions',
172 |   'generated',
173 |   'global',
174 |   'grant',
175 |   'granted',
176 |   'greatest',
177 |   'group',
178 |   'grouping',
179 |   'groups',
180 |   'handler',
181 |   'having',
182 |   'header',
183 |   'hold',
184 |   'hour',
185 |   'identity',
186 |   'if',
187 |   'ilike',
188 |   'immediate',
189 |   'immutable',
190 |   'implicit',
191 |   'import',
192 |   'in',
193 |   'include',
194 |   'including',
195 |   'increment',
196 |   'indent',
197 |   'index',
198 |   'indexes',
199 |   'inherit',
200 |   'inherits',
201 |   'initially',
202 |   'inline',
203 |   'inner',
204 |   'inout',
205 |   'input',
206 |   'insensitive',
207 |   'insert',
208 |   'instead',
209 |   'int',
210 |   'integer',
211 |   'intersect',
212 |   'interval',
213 |   'into',
214 |   'invoker',
215 |   'is',
216 |   'isnull',
217 |   'isolation',
218 |   'join',
219 |   'json',
220 |   'json_array',
221 |   'json_arrayagg',
222 |   'json_object',
223 |   'json_objectagg',
224 |   'json_scalar',
225 |   'json_serialize',
226 |   'key',
227 |   'keys',
228 |   'label',
229 |   'language',
230 |   'large',
231 |   'last',
232 |   'lateral',
233 |   'leading',
234 |   'leakproof',
235 |   'least',
236 |   'left',
237 |   'level',
238 |   'like',
239 |   'limit',
240 |   'listen',
241 |   'load',
242 |   'local',
243 |   'localtime',
244 |   'localtimestamp',
245 |   'location',
246 |   'lock',
247 |   'locked',
248 |   'logged',
249 |   'mapping',
250 |   'match',
251 |   'matched',
252 |   'materialized',
253 |   'maxvalue',
254 |   'merge',
255 |   'method',
256 |   'minute',
257 |   'minvalue',
258 |   'mode',
259 |   'month',
260 |   'move',
261 |   'name',
262 |   'names',
263 |   'national',
264 |   'natural',
265 |   'nchar',
266 |   'new',
267 |   'next',
268 |   'nfc',
269 |   'nfd',
270 |   'nfkc',
271 |   'nfkd',
272 |   'no',
273 |   'none',
274 |   'normalize',
275 |   'normalized',
276 |   'not',
277 |   'nothing',
278 |   'notify',
279 |   'notnull',
280 |   'nowait',
281 |   'null',
282 |   'nullif',
283 |   'nulls',
284 |   'numeric',
285 |   'object',
286 |   'of',
287 |   'off',
288 |   'offset',
289 |   'oids',
290 |   'old',
291 |   'on',
292 |   'only',
293 |   'operator',
294 |   'option',
295 |   'options',
296 |   'or',
297 |   'order',
298 |   'ordinality',
299 |   'others',
300 |   'out',
301 |   'outer',
302 |   'over',
303 |   'overlaps',
304 |   'overlay',
305 |   'overriding',
306 |   'owned',
307 |   'owner',
308 |   'parallel',
309 |   'parameter',
310 |   'parser',
311 |   'partial',
312 |   'partition',
313 |   'passing',
314 |   'password',
315 |   'placing',
316 |   'plans',
317 |   'policy',
318 |   'position',
319 |   'preceding',
320 |   'precision',
321 |   'prepare',
322 |   'prepared',
323 |   'preserve',
324 |   'primary',
325 |   'prior',
326 |   'privileges',
327 |   'procedural',
328 |   'procedure',
329 |   'procedures',
330 |   'program',
331 |   'publication',
332 |   'quote',
333 |   'range',
334 |   'read',
335 |   'real',
336 |   'reassign',
337 |   'recheck',
338 |   'recursive',
339 |   'ref',
340 |   'references',
341 |   'referencing',
342 |   'refresh',
343 |   'reindex',
344 |   'relative',
345 |   'release',
346 |   'rename',
347 |   'repeatable',
348 |   'replace',
349 |   'replica',
350 |   'reset',
351 |   'restart',
352 |   'restrict',
353 |   'return',
354 |   'returning',
355 |   'returns',
356 |   'revoke',
357 |   'right',
358 |   'role',
359 |   'rollback',
360 |   'rollup',
361 |   'routine',
362 |   'routines',
363 |   'row',
364 |   'rows',
365 |   'rule',
366 |   'savepoint',
367 |   'scalar',
368 |   'schema',
369 |   'schemas',
370 |   'scroll',
371 |   'search',
372 |   'second',
373 |   'security',
374 |   'select',
375 |   'sequence',
376 |   'sequences',
377 |   'serializable',
378 |   'server',
379 |   'session',
380 |   'session_user',
381 |   'set',
382 |   'setof',
383 |   'sets',
384 |   'share',
385 |   'show',
386 |   'similar',
387 |   'simple',
388 |   'skip',
389 |   'smallint',
390 |   'snapshot',
391 |   'some',
392 |   'sql',
393 |   'stable',
394 |   'standalone',
395 |   'start',
396 |   'statement',
397 |   'statistics',
398 |   'stdin',
399 |   'stdout',
400 |   'storage',
401 |   'stored',
402 |   'strict',
403 |   'strip',
404 |   'subscription',
405 |   'substring',
406 |   'support',
407 |   'symmetric',
408 |   'sysid',
409 |   'system',
410 |   'system_user',
411 |   'table',
412 |   'tables',
413 |   'tablesample',
414 |   'tablespace',
415 |   'temp',
416 |   'template',
417 |   'temporary',
418 |   'text',
419 |   'then',
420 |   'ties',
421 |   'time',
422 |   'timestamp',
423 |   'to',
424 |   'trailing',
425 |   'transaction',
426 |   'transform',
427 |   'treat',
428 |   'trigger',
429 |   'trim',
430 |   'true',
431 |   'truncate',
432 |   'trusted',
433 |   'type',
434 |   'types',
435 |   'uescape',
436 |   'unbounded',
437 |   'uncommitted',
438 |   'unencrypted',
439 |   'union',
440 |   'unique',
441 |   'unknown',
442 |   'unlisten',
443 |   'unlogged',
444 |   'until',
445 |   'update',
446 |   'user',
447 |   'using',
448 |   'vacuum',
449 |   'valid',
450 |   'validate',
451 |   'validator',
452 |   'value',
453 |   'values',
454 |   'varchar',
455 |   'variadic',
456 |   'varying',
457 |   'verbose',
458 |   'version',
459 |   'view',
460 |   'views',
461 |   'volatile',
462 |   'when',
463 |   'where',
464 |   'whitespace',
465 |   'window',
466 |   'with',
467 |   'within',
468 |   'without',
469 |   'work',
470 |   'wrapper',
471 |   'write',
472 |   'xml',
473 |   'xmlattributes',
474 |   'xmlconcat',
475 |   'xmlelement',
476 |   'xmlexists',
477 |   'xmlforest',
478 |   'xmlnamespaces',
479 |   'xmlparse',
480 |   'xmlpi',
481 |   'xmlroot',
482 |   'xmlserialize',
483 |   'xmltable',
484 |   'year',
485 |   'yes',
486 |   'zone',
487 | # END GENERATED KEYWORDS
488 | ) {
489 |   # This tests only positive results.
490 |   # Negative results should be foolproof, because is_keyword always ends with a strcmp()
491 |   ok (DBD::Pg::db::_is_keyword($_), $_);
492 | }
493 | # ...but why not test just one negative result
494 | ok (!DBD::Pg::db::_is_keyword('notakeyword'), 'notakeyword');
495 | 
496 | done_testing;
497 | 


--------------------------------------------------------------------------------
/Pg.h:
--------------------------------------------------------------------------------
  1 | /*
  2 |    Copyright (c) 2000-2024 Greg Sabino Mullane and others: see the Changes file
  3 |    Copyright (c) 1997-2000 Edmund Mergl
  4 |    Portions Copyright (c) 1994-1997 Tim Bunce
  5 | 
  6 |    You may distribute under the terms of either the GNU General Public
  7 |    License or the Artistic License, as specified in the Perl README file.
  8 | 
  9 | */
 10 | 
 11 | #include <wchar.h>
 12 | 
 13 | #ifdef WIN32
 14 | #if (!defined(_MSC_VER) || (_MSC_VER < 1900))
 15 | static int errno;
 16 | #endif
 17 | #include <string.h>
 18 | #define strcasecmp(s1,s2) stricmp((s1), (s2))
 19 | #else
 20 | #include <strings.h>
 21 | #endif
 22 | 
 23 | #define DBDPG_TRUE (bool)1
 24 | #define DBDPG_FALSE (bool)0
 25 | #define PG_ASYNC 1
 26 | #define PG_OLDQUERY_CANCEL 2
 27 | #define PG_OLDQUERY_WAIT 4
 28 | #define PG_UNKNOWN_VERSION 0
 29 | 
 30 | /* Force preprocessors to use this variable. Default to something valid yet noticeable */
 31 | #ifndef PGLIBVERSION
 32 | #define PGLIBVERSION 80009
 33 | #endif
 34 | 
 35 | #include "libpq-fe.h"
 36 | 
 37 | #ifndef INV_READ
 38 | #define INV_READ 0x00040000
 39 | #endif
 40 | #ifndef INV_WRITE
 41 | #define INV_WRITE 0x00020000
 42 | #endif
 43 | 
 44 | #ifndef PGRES_COPY_BOTH
 45 | #define PGRES_COPY_BOTH 8
 46 | #endif
 47 | 
 48 | #ifdef BUFSIZ
 49 | #undef BUFSIZ
 50 | #endif
 51 | /* this should improve I/O performance for large objects */
 52 | #define BUFSIZ 32768
 53 | 
 54 | #define NEED_DBIXS_VERSION 93
 55 | 
 56 | #define PERL_NO_GET_CONTEXT
 57 | 
 58 | #include <DBIXS.h>      /* installed by the DBI module */
 59 | 
 60 | #include <dbivport.h>   /* DBI portability macros */
 61 | 
 62 | #include <dbd_xsh.h>    /* installed by the DBI module */
 63 | 
 64 | DBISTATE_DECLARE;
 65 | 
 66 | #include "types.h"
 67 | #include "dbdimp.h"
 68 | #include "quote.h"
 69 | 
 70 | #define TLEVEL_slow     (DBIS->debug & DBIc_TRACE_LEVEL_MASK)
 71 | #define TFLAGS_slow     (DBIS->debug & DBIc_TRACE_FLAGS_MASK)
 72 | 
 73 | #define TSQL            (TFLAGS_slow & 256) /* Defined in DBI */
 74 | 
 75 | #define FLAGS_LIBPQ    0x01000000
 76 | #define FLAGS_START    0x02000000
 77 | #define FLAGS_END      0x04000000
 78 | #define FLAGS_PREFIX   0x08000000
 79 | #define FLAGS_LOGIN    0x10000000
 80 | 
 81 | #define TFLIBPQ_slow      (TFLAGS_slow & FLAGS_LIBPQ)
 82 | #define TFSTART_slow      (TFLAGS_slow & FLAGS_START)
 83 | #define TFEND_slow        (TFLAGS_slow & FLAGS_END)
 84 | #define TFPREFIX_slow     (TFLAGS_slow & FLAGS_PREFIX)
 85 | #define TFLOGIN_slow      (TFLAGS_slow & FLAGS_LOGIN)
 86 | 
 87 | #define TRACE1_slow       (TLEVEL_slow >= 1) /* Avoid using directly: DBI only */
 88 | #define TRACE2_slow       (TLEVEL_slow >= 2) /* Avoid using directly: DBI only */
 89 | #define TRACE3_slow       (TLEVEL_slow >= 3) /* Basic debugging */
 90 | #define TRACE4_slow       (TLEVEL_slow >= 4) /* More detailed debugging */
 91 | #define TRACE5_slow       (TLEVEL_slow >= 5) /* Very detailed debugging */
 92 | #define TRACE6_slow       (TLEVEL_slow >= 6)
 93 | #define TRACE7_slow       (TLEVEL_slow >= 7)
 94 | #define TRACE8_slow       (TLEVEL_slow >= 8)
 95 | 
 96 | #define TLIBPQ_slow       (TRACE5_slow || TFLIBPQ_slow)
 97 | #define TSTART_slow       (TRACE4_slow || TFSTART_slow) /* Start of a major function */
 98 | #define TEND_slow         (TRACE4_slow || TFEND_slow)   /* End of a major function   */
 99 | #define TLOGIN_slow       (TRACE5_slow || TFLOGIN_slow) /* Connect and disconnect    */
100 | 
101 | #define TRACEWARN_slow    (TRACE1_slow) /* Non-fatal but serious problems */
102 | 
103 | /* Do we show a "dbdpg: " header? */
104 | #define THEADER_slow      (TFPREFIX_slow) ? "dbdpg: " : ""
105 | 
106 | #define TRC (void)PerlIO_printf
107 | 
108 | /* Fancy stuff for tracing of commonly used libpq functions */
109 | #define TRACE_XX                   if (TLIBPQ_slow) TRC(DBILOGFP,
110 | /* XXX every use of every one of these costs at least one call to DBIS
111 |  * and possibly +1 for DBILOGFP and another for THEADER_slow!
112 |  * A better approach may be something like DBD::Oracle's
113 |  * http://cpansearch.perl.org/src/PYTHIAN/DBD-Oracle-1.42/ocitrace.h
114 |  * #define PGfooBar_log_stat(imp_xxh, stat, a,b,c) ... where imp_xxh
115 |  * is used to determine the logging and stat holds the result.
116 |  * That makes the code uncluttered and gives good flexibility.
117 |  */
118 | #define TRACE_PQBACKENDPID         TRACE_XX "%sPQbackendPID\n",          THEADER_slow)
119 | #define TRACE_PQCANCEL             TRACE_XX "%sPQcancel\n",              THEADER_slow)
120 | #define TRACE_PQCLEAR              TRACE_XX "%sPQclear\n",               THEADER_slow)
121 | #define TRACE_PQCMDSTATUS          TRACE_XX "%sPQcmdStatus\n",           THEADER_slow)
122 | #define TRACE_PQCMDTUPLES          TRACE_XX "%sPQcmdTuples\n",           THEADER_slow)
123 | #define TRACE_PQCONNECTDB          TRACE_XX "%sPQconnectdb\n",           THEADER_slow)
124 | #define TRACE_PQCONSUMEINPUT       TRACE_XX "%sPQconsumeInput\n",        THEADER_slow)
125 | #define TRACE_PQDB                 TRACE_XX "%sPQdb\n",                  THEADER_slow)
126 | #define TRACE_PQENDCOPY            TRACE_XX "%sPQendcopy\n",             THEADER_slow)
127 | #define TRACE_PQERRORMESSAGE       TRACE_XX "%sPQerrorMessage\n",        THEADER_slow)
128 | #define TRACE_PQEXEC               TRACE_XX "%sPQexec\n",                THEADER_slow)
129 | #define TRACE_PQEXECPARAMS         TRACE_XX "%sPQexecParams\n",          THEADER_slow)
130 | #define TRACE_PQEXECPREPARED       TRACE_XX "%sPQexecPrepared\n",        THEADER_slow)
131 | #define TRACE_PQFINISH             TRACE_XX "%sPQfinish\n",              THEADER_slow)
132 | #define TRACE_PQFMOD               TRACE_XX "%sPQfmod\n",                THEADER_slow)
133 | #define TRACE_PQFNAME              TRACE_XX "%sPQfname\n",               THEADER_slow)
134 | #define TRACE_PQFREECANCEL         TRACE_XX "%sPQfreeCancel\n",          THEADER_slow)
135 | #define TRACE_PQFREEMEM            TRACE_XX "%sPQfreemem\n",             THEADER_slow)
136 | #define TRACE_PQFSIZE              TRACE_XX "%sPQfsize\n",               THEADER_slow)
137 | #define TRACE_PQFTABLECOL          TRACE_XX "%sPQftableCol\n",           THEADER_slow)
138 | #define TRACE_PQFTABLE             TRACE_XX "%sPQftable\n",              THEADER_slow)
139 | #define TRACE_PQFTYPE              TRACE_XX "%sPQftype\n",               THEADER_slow)
140 | #define TRACE_PQGETCANCEL          TRACE_XX "%sPQgetCancel\n",           THEADER_slow)
141 | #define TRACE_PQGETCOPYDATA        TRACE_XX "%sPQgetCopyData\n",         THEADER_slow)
142 | #define TRACE_PQGETISNULL          TRACE_XX "%sPQgetisnull\n",           THEADER_slow)
143 | #define TRACE_PQGETRESULT          TRACE_XX "%sPQgetResult\n",           THEADER_slow)
144 | #define TRACE_PQGETLENGTH          TRACE_XX "%sPQgetLength\n",           THEADER_slow)
145 | #define TRACE_PQGETVALUE           TRACE_XX "%sPQgetvalue\n",            THEADER_slow)
146 | #define TRACE_PQHOST               TRACE_XX "%sPQhost\n",                THEADER_slow)
147 | #define TRACE_PQISBUSY             TRACE_XX "%sPQisBusy\n",              THEADER_slow)
148 | #define TRACE_PQNFIELDS            TRACE_XX "%sPQnfields\n",             THEADER_slow)
149 | #define TRACE_PQNOTIFIES           TRACE_XX "%sPQnotifies\n",            THEADER_slow)
150 | #define TRACE_PQNTUPLES            TRACE_XX "%sPQntuples\n",             THEADER_slow)
151 | #define TRACE_PQOIDVALUE           TRACE_XX "%sPQoidValue\n",            THEADER_slow)
152 | #define TRACE_PQOPTIONS            TRACE_XX "%sPQoptions\n",             THEADER_slow)
153 | #define TRACE_PQPARAMETERSTATUS    TRACE_XX "%sPQparameterStatus\n",     THEADER_slow)
154 | #define TRACE_PQPASS               TRACE_XX "%sPQpass\n",                THEADER_slow)
155 | #define TRACE_PQPORT               TRACE_XX "%sPQport\n",                THEADER_slow)
156 | #define TRACE_PQPREPARE            TRACE_XX "%sPQprepare\n",             THEADER_slow)
157 | #define TRACE_PQPROTOCOLVERSION    TRACE_XX "%sPQprotocolVersion\n",     THEADER_slow)
158 | #define TRACE_PQPUTCOPYDATA        TRACE_XX "%sPQputCopyData\n",         THEADER_slow)
159 | #define TRACE_PQPUTCOPYEND         TRACE_XX "%sPQputCopyEnd\n",          THEADER_slow)
160 | #define TRACE_PQRESULTERRORFIELD   TRACE_XX "%sPQresultErrorField\n",    THEADER_slow)
161 | #define TRACE_PQRESULTSTATUS       TRACE_XX "%sPQresultStatus\n",        THEADER_slow)
162 | #define TRACE_PQSENDQUERY          TRACE_XX "%sPQsendQuery\n",           THEADER_slow)
163 | #define TRACE_PQSENDQUERYPARAMS    TRACE_XX "%sPQsendQueryParams\n",     THEADER_slow)
164 | #define TRACE_PQSENDQUERYPREPARED  TRACE_XX "%sPQsendQueryPrepared\n",   THEADER_slow)
165 | #define TRACE_PQSERVERVERSION      TRACE_XX "%sPQserverVersion\n",       THEADER_slow)
166 | #define TRACE_PQSETERRORVERBOSITY  TRACE_XX "%sPQsetErrorVerbosity\n",   THEADER_slow)
167 | #define TRACE_PQSETNOTICEPROCESSOR TRACE_XX "%sPQsetNoticeProcessor\n",  THEADER_slow)
168 | #define TRACE_PQSOCKET             TRACE_XX "%sPQsocket\n",              THEADER_slow)
169 | #define TRACE_PQSTATUS             TRACE_XX "%sPQstatus\n",              THEADER_slow)
170 | #define TRACE_PQTRACE              TRACE_XX "%sPQtrace\n",               THEADER_slow)
171 | #define TRACE_PQTRANSACTIONSTATUS  TRACE_XX "%sPQtransactionStatus\n",   THEADER_slow)
172 | #define TRACE_PQUNTRACE            TRACE_XX "%sPQuntrace\n",             THEADER_slow)
173 | #define TRACE_PQUSER               TRACE_XX "%sPQuser\n",                THEADER_slow)
174 | 
175 | /* end of Pg.h */
176 | 


--------------------------------------------------------------------------------
/t/01connect.t:
--------------------------------------------------------------------------------
  1 | #!perl
  2 | 
  3 | ## Make sure we can connect and disconnect cleanly
  4 | ## All tests are stopped if we cannot make the first connect
  5 | 
  6 | use 5.008001;
  7 | use strict;
  8 | use warnings;
  9 | use lib 'blib/lib', 'blib/arch', 't';
 10 | use DBI;
 11 | use DBD::Pg;
 12 | use Test::More;
 13 | require 'dbdpg_test_setup.pl';
 14 | select(($|=1,select(STDERR),$|=1)[1]);
 15 | 
 16 | ## Define this here in case we get to the END block before a connection is made.
 17 | our ($t, $pgversion, $pglibversion, $pgvstring, $pgdefport, $helpconnect, $dbh, $connerror, %setting);
 18 | BEGIN {
 19 |     ($pgversion,$pglibversion,$pgvstring,$pgdefport) = ('?','?','?','?');
 20 | }
 21 | 
 22 | ($helpconnect,$connerror,$dbh) = connect_database();
 23 | 
 24 | if (! defined $dbh or $connerror) {
 25 |     plan skip_all => 'Connection to database failed, cannot continue testing';
 26 | }
 27 | plan tests => 30;
 28 | 
 29 | pass ('Established a connection to the database');
 30 | 
 31 | $pgversion    = $dbh->{pg_server_version};
 32 | $pglibversion = $dbh->{pg_lib_version};
 33 | $pgdefport    = $dbh->{pg_default_port};
 34 | $pgvstring    = $dbh->selectall_arrayref('SELECT VERSION()')->[0][0];
 35 | 
 36 | ok ($dbh->disconnect(), 'Disconnect from the database');
 37 | 
 38 | # Connect two times. From this point onward, do a simpler connection check
 39 | $t=q{Second database connection attempt worked};
 40 | (undef,$connerror,$dbh) = connect_database();
 41 | is ($connerror, '', $t);
 42 | if ($connerror ne '') {
 43 |     BAIL_OUT 'Second connection to database failed, bailing out';
 44 | }
 45 | 
 46 | ## Grab some important values used for debugging
 47 | my @vals = qw/array_nulls backslash_quote server_encoding client_encoding standard_conforming_strings/;
 48 | my $SQL = 'SELECT name,setting FROM pg_settings WHERE name IN (' .
 49 |     (join ',' => map { qq{'$_'} } @vals) . ')';
 50 | for (@{$dbh->selectall_arrayref($SQL)}) {
 51 |     my ($name, $value) = @$_;
 52 |     ## Skip 'normal' settings
 53 |     next if $name eq 'array_nulls' and $value eq 'on';
 54 |     next if $name eq 'standard_conforming_strings' and $value eq 'on';
 55 |     next if $name eq 'backslash_quote' and $value ne 'off';
 56 |     next if $name =~ /encoding/ and $value eq 'UTF8';
 57 |     $setting{$name} = $value;
 58 | }
 59 | 
 60 | my $dbh2 = connect_database();
 61 | 
 62 | pass ('Connected with second database handle');
 63 | 
 64 | my $sth = $dbh->prepare('SELECT 123');
 65 | ok ($dbh->disconnect(), 'Disconnect with first database handle');
 66 | ok ($dbh2->disconnect(), 'Disconnect with second database handle');
 67 | ok ($dbh2->disconnect(), 'Disconnect again with second database handle');
 68 | 
 69 | eval {
 70 |  $sth->execute();
 71 | };
 72 | ok ($@, 'Execute fails on a disconnected statement');
 73 | 
 74 | # Try out various connection options
 75 | $ENV{DBI_DSN} ||= '';
 76 | SKIP: {
 77 |     my $alias = qr{(database|db|dbname)};
 78 |     if ($ENV{DBI_DSN} !~ /$alias\s*=\s*\S+/) {
 79 |         skip ('DBI_DSN contains no database option, so skipping connection tests', 8);
 80 |     }
 81 | 
 82 |     $t=q{Connect with invalid option fails};
 83 |     my $err;
 84 |     (undef,$err,$dbh) = connect_database({ dbreplace => 'dbbarf', nocreate => 1 });
 85 |     like ($err, qr{DBI connect.+failed:}, $t);
 86 | 
 87 |     for my $opt (qw/db dbname database/) {
 88 |         $t=qq{Connect using string '$opt' works};
 89 |         $dbh and $dbh->disconnect();
 90 |         (undef,$err,$dbh) = connect_database({dbreplace => $opt});
 91 |         $err =~ s/(Previous failure).*/$1/;
 92 |         is ($err, '', $t);
 93 |     }
 94 | 
 95 |     $t=q{Connect with forced uppercase 'DBI:' works};
 96 |     my ($testdsn,$testuser,undef,$su,$uid,$testdir,$pg_ctl,$initdb,$error,$version) ## no critic (Variables::ProhibitUnusedVarsStricter)
 97 |         = get_test_settings();
 98 |     $testdsn =~ s/^dbi/DBI/i;
 99 |     my $ldbh = DBI->connect($testdsn, $testuser, $ENV{DBI_PASS},
100 |         {RaiseError => 1, PrintError => 0, AutoCommit => 0});
101 |     ok (ref $ldbh, $t);
102 |     $ldbh->disconnect();
103 | 
104 |     $t=q{Connect with mixed case 'DbI:' works};
105 |     $testdsn =~ s/^dbi/DbI/i;
106 |     $ldbh = DBI->connect($testdsn, $testuser, $ENV{DBI_PASS},
107 |         {RaiseError => 1, PrintError => 0, AutoCommit => 0});
108 |     ok (ref $ldbh, $t);
109 |     $ldbh->disconnect();
110 | 
111 |   SKIP: {
112 |         if ($pglibversion <  100000) {
113 |             skip ('Multiple host names requies libpq >= 10', 1);
114 |         }
115 |         $t=q{Connect with multiple host names works};
116 |         $testdsn =~ s/host=/host=foo.invalid,/;
117 |         $ldbh = DBI->connect($testdsn, $testuser, $ENV{DBI_PASS},
118 |             {RaiseError => 1, PrintError => 0, AutoCommit => 0});
119 |         ok (ref $ldbh, $t);
120 |         $ldbh->do('select 1');
121 |         $ldbh->disconnect();
122 |     }
123 |     if ($ENV{DBI_DSN} =~ /$alias\s*=\s*\"/) {
124 |         skip ('DBI_DSN already contains quoted database, no need for explicit test', 1);
125 |     }
126 |     $t=q{Connect using a quoted database argument};
127 |     eval {
128 |         $dbh and $dbh->disconnect();
129 |         (undef,$err,$dbh) = connect_database({dbquotes => 1, nocreate => 1});
130 |     };
131 |     is ($@, q{}, $t);
132 | 
133 |   SKIP: {
134 |         my @names = ('foo', 'foo bar', ';foo;bar;', 'foo\'bar', 'foo\\\'bar',
135 |                      'foo\';bar\';', '\\foo\\');
136 |         if ($pgversion < 90000) {
137 |             skip ('applicaiton_name requires PostgreSQL >= 9.0', @names * 2);
138 |         }
139 | 
140 |         for my $application_name (@names) {
141 |             $t=qq{Connect with application_name=$application_name};
142 |             (my $escaped_name = $application_name) =~ s/(['\\])/\\$1/g;
143 |             my $adbh = DBI->connect("$testdsn;application_name='$escaped_name'", $testuser, $ENV{DBI_PASS},
144 |                                     {RaiseError => 0, PrintError => 0});
145 |             ok (ref $adbh, $t) or diag $DBI::errstr;
146 |             my $returned_name = $adbh && $adbh->selectrow_array('show application_name');
147 |             $t=q{application_name roundtrip};
148 |             is ($returned_name, $application_name, $t);
149 |             $adbh && $adbh->disconnect;
150 |         }
151 |     }
152 | }
153 | 
154 | END {
155 |     my $pv = sprintf('%vd', $^V);
156 |     my $schema = 'dbd_pg_testschema';
157 |     my $dsn = exists $ENV{DBI_DSN} ? $ENV{DBI_DSN} : '?';
158 | 
159 |     ## Don't show current dir to the world via CPAN::Reporter results
160 |     $dsn =~ s{host=/.*(dbdpg_test_database/data/socket)}{host=<pwd>/$1};
161 | 
162 |     my $ver = defined $DBD::Pg::VERSION ? $DBD::Pg::VERSION : '?';
163 |     my $user = exists $ENV{DBI_USER} ? $ENV{DBI_USER} : '<not set>';
164 |     my $offset = 27;
165 | 
166 |     my $extra = '';
167 |     for (sort qw/HOST HOSTADDR PORT DATABASE USER PASSWORD PASSFILE OPTIONS REALM
168 |                  REQUIRESSL KRBSRVNAME CONNECT_TIMEOUT SERVICE SSLMODE SYSCONFDIR
169 |                  CLIENTENCODING/) {
170 |         my $name = "PG$_";
171 |         if (exists $ENV{$name} and defined $ENV{$name}) {
172 |             $extra .= sprintf "\n%-*s $ENV{$name}", $offset, $name;
173 |         }
174 |     }
175 |     for my $name (qw/DBI_DRIVER DBI_AUTOPROXY LANG/) {
176 |         if (exists $ENV{$name} and defined $ENV{$name} and $ENV{$name}) {
177 |             $extra .= sprintf "\n%-*s $ENV{$name}", $offset, $name;
178 |         }
179 |     }
180 | 
181 |     for my $name (grep { /^DBDPG/ } sort keys %ENV) {
182 |         $extra .= sprintf "\n%-*s $ENV{$name}", $offset, $name;
183 |     }
184 | 
185 |     for my $name (qw/ RELEASE_TESTING AUTHOR_TESTING /) {
186 |         if (exists $ENV{$name} and defined $ENV{$name}) {
187 |             $extra .= sprintf "\n%-*s $ENV{$name}", $offset, $name;
188 |         }
189 |     }
190 | 
191 |     ## More helpful stuff
192 |     for (sort keys %setting) {
193 |         $extra .= sprintf "\n%-*s %s", $offset, $_, $setting{$_};
194 |     }
195 | 
196 |     if ($helpconnect) {
197 |         $extra .= sprintf "\n%-*s ", $offset, 'Adjusted:';
198 |         if ($helpconnect & 1) {
199 |             $extra .= 'DBI_DSN ';
200 |         }
201 |         if ($helpconnect & 4) {
202 |             $extra .= 'DBI_USER';
203 |         }
204 |         if ($helpconnect & 8) {
205 |             $extra .= 'DBI_USERx2';
206 |         }
207 |         if ($helpconnect & 16) {
208 |             $extra .= 'initdb';
209 |         }
210 |     }
211 | 
212 |     if (defined $connerror and length $connerror) {
213 |         $connerror =~ s/.+?failed: ([^\n]+).*/$1/s;
214 |         $connerror =~ s{\n at t/dbdpg.*}{}m;
215 |         if ($connerror =~ /create semaphores/) {
216 |             $connerror =~ s/.*(FATAL.*?)HINT.*/$1/sm;
217 |         }
218 |         $extra .= "\nError was: $connerror";
219 |     }
220 | 
221 |     diag
222 |         "\nDBI                         Version $DBI::VERSION\n".
223 |         "DBD::Pg                     Version $ver\n".
224 |         "Perl                        Version $pv\n".
225 |         "OS                          $^O\n".
226 |         "PostgreSQL (compiled)       $pglibversion\n".
227 |         "PostgreSQL (target)         $pgversion\n".
228 |         "PostgreSQL (reported)       $pgvstring\n".
229 |         "Default port                $pgdefport\n".
230 |         "DBI_DSN                     $dsn\n".
231 |         "DBI_USER                    $user\n".
232 |         "Test schema                 $schema$extra\n";
233 | 
234 |     if ($extra =~ /Error was/ and $extra !~ /probably not available/) {
235 |         BAIL_OUT "Cannot continue: connection failed\n";
236 |     }
237 | }
238 | 


--------------------------------------------------------------------------------
/t/lib/App/Info/Request.pm:
--------------------------------------------------------------------------------
  1 | package App::Info::Request;
  2 | 
  3 | =head1 NAME
  4 | 
  5 | App::Info::Request - App::Info event handler request object
  6 | 
  7 | =head1 SYNOPSIS
  8 | 
  9 |   # In an App::Info::Handler subclass:
 10 |   sub handler {
 11 |       my ($self, $req) = @_;
 12 |       print "Event Type:  ", $req->type;
 13 |       print "Message:     ", $req->message;
 14 |       print "Error:       ", $req->error;
 15 |       print "Value:       ", $req->value;
 16 |   }
 17 | 
 18 | =head1 DESCRIPTION
 19 | 
 20 | Objects of this class are passed to the C<handler()> method of App::Info event
 21 | handlers. Generally, this class will be of most interest to App::Info::Handler
 22 | subclass implementers.
 23 | 
 24 | The L<event triggering methods|App::Info/"Events"> in App::Info each construct
 25 | a new App::Info::Request object and initialize it with their arguments. The
 26 | App::Info::Request object is then the sole argument passed to the C<handler()>
 27 | method of any and all App::Info::Handler objects in the event handling chain.
 28 | Thus, if you'd like to create your own App::Info event handler, this is the
 29 | object you need to be familiar with. Consult the
 30 | L<App::Info::Handler|App::Info::Handler> documentation for details on creating
 31 | custom event handlers.
 32 | 
 33 | Each of the App::Info event triggering methods constructs an
 34 | App::Info::Request object with different attribute values. Be sure to consult
 35 | the documentation for the L<event triggering methods|App::Info/"Events"> in
 36 | App::Info, where the values assigned to the App::Info::Request object are
 37 | documented. Then, in your event handler subclass, check the value returned by
 38 | the C<type()> method to determine what type of event request you're handling
 39 | to handle the request appropriately.
 40 | 
 41 | =cut
 42 | 
 43 | use strict;
 44 | use Carp;
 45 | our $VERSION = '0.57';
 46 | 
 47 | ##############################################################################
 48 | 
 49 | =head1 INTERFACE
 50 | 
 51 | The following sections document the App::Info::Request interface.
 52 | 
 53 | =head2 Constructor
 54 | 
 55 | =head3 new
 56 | 
 57 |   my $req = App::Info::Request->new(%params);
 58 | 
 59 | This method is used internally by App::Info to construct new
 60 | App::Info::Request objects to pass to event handler objects. Generally, you
 61 | won't need to use it, other than perhaps for testing custom App::Info::Handler
 62 | classes.
 63 | 
 64 | The parameters to C<new()> are passed as a hash of named parameters that
 65 | correspond to their like-named methods. The supported parameters are:
 66 | 
 67 | =over 4
 68 | 
 69 | =item type
 70 | 
 71 | =item message
 72 | 
 73 | =item error
 74 | 
 75 | =item value
 76 | 
 77 | =item callback
 78 | 
 79 | =back
 80 | 
 81 | See the object methods documentation below for details on these object
 82 | attributes.
 83 | 
 84 | =cut
 85 | 
 86 | sub new {
 87 |     my $pkg = shift;
 88 | 
 89 |     # Make sure we've got a hash of arguments.
 90 |     Carp::croak("Odd number of parameters in call to " . __PACKAGE__ .
 91 |                 "->new() when named parameters expected" ) if @_ % 2;
 92 |     my %params = @_;
 93 | 
 94 |     # Validate the callback.
 95 |     if ($params{callback}) {
 96 |         Carp::croak("Callback parameter '$params{callback}' is not a code ",
 97 |                     "reference")
 98 |             unless UNIVERSAL::isa($params{callback}, 'CODE');
 99 |     } else {
100 |         # Otherwise just assign a default approve callback.
101 |         $params{callback} = sub { 1 };
102 |     }
103 | 
104 |     # Validate type parameter.
105 |     if (my $t = $params{type}) {
106 |         Carp::croak("Invalid handler type '$t'")
107 |           unless $t eq 'error' or $t eq 'info' or $t eq 'unknown'
108 |           or $t eq 'confirm';
109 |     } else {
110 |         $params{type} = 'info';
111 |     }
112 | 
113 |     # Return the request object.
114 |     bless \%params, ref $pkg || $pkg;
115 | }
116 | 
117 | ##############################################################################
118 | 
119 | =head2 Object Methods
120 | 
121 | =head3 key
122 | 
123 |   my $key = $req->key;
124 | 
125 | Returns the key stored in the App::Info::Request object. The key is used by
126 | the App::Info subclass to uniquely identify the information it is harvesting,
127 | such as the path to an executable. It might be used by request handlers,
128 | for example, to see if an option was passed on the command-line.
129 | 
130 | =cut
131 | 
132 | sub key { $_[0]->{key} }
133 | 
134 | ##############################################################################
135 | 
136 | =head3 message
137 | 
138 |   my $message = $req->message;
139 | 
140 | Returns the message stored in the App::Info::Request object. The message is
141 | typically informational, or an error message, or a prompt message.
142 | 
143 | =cut
144 | 
145 | sub message { $_[0]->{message} }
146 | 
147 | ##############################################################################
148 | 
149 | =head3 error
150 | 
151 |   my $error = $req->error;
152 | 
153 | Returns any error message associated with the App::Info::Request object. The
154 | error message is typically there to display for users when C<callback()>
155 | returns false.
156 | 
157 | =cut
158 | 
159 | sub error { $_[0]->{error} }
160 | 
161 | ##############################################################################
162 | 
163 | =head3 type
164 | 
165 |   my $type = $req->type;
166 | 
167 | Returns a string representing the type of event that triggered this request.
168 | The types are the same as the event triggering methods defined in App::Info.
169 | As of this writing, the supported types are:
170 | 
171 | =over
172 | 
173 | =item info
174 | 
175 | =item error
176 | 
177 | =item unknown
178 | 
179 | =item confirm
180 | 
181 | =back
182 | 
183 | Be sure to consult the App::Info documentation for more details on the event
184 | types.
185 | 
186 | =cut
187 | 
188 | sub type { $_[0]->{type} }
189 | 
190 | ##############################################################################
191 | 
192 | =head3 callback
193 | 
194 |   if ($req->callback($value)) {
195 |       print "Value '$value' is valid.\n";
196 |   } else {
197 |       print "Value '$value' is not valid.\n";
198 |   }
199 | 
200 | Executes the callback anonymous subroutine supplied by the App::Info concrete
201 | base class that triggered the event. If the callback returns false, then
202 | C<$value> is invalid. If the callback returns true, then C<$value> is valid
203 | and can be assigned via the C<value()> method.
204 | 
205 | Note that the C<value()> method itself calls C<callback()> if it was passed a
206 | value to assign. See its documentation below for more information.
207 | 
208 | =cut
209 | 
210 | sub callback {
211 |     my $self = shift;
212 |     my $code = $self->{callback};
213 |     local $_ = $_[0];
214 |     $code->(@_);
215 | }
216 | 
217 | ##############################################################################
218 | 
219 | =head3 value
220 | 
221 |   my $value = $req->value;
222 |   if ($req->value($value)) {
223 |       print "Value '$value' successfully assigned.\n";
224 |   } else {
225 |       print "Value '$value' not successfully assigned.\n";
226 |   }
227 | 
228 | When called without an argument, C<value()> simply returns the value currently
229 | stored by the App::Info::Request object. Typically, the value is the default
230 | value for a confirm event, or a value assigned to an unknown event.
231 | 
232 | When passed an argument, C<value()> attempts to store the the argument as a
233 | new value. However, C<value()> calls C<callback()> on the new value, and if
234 | C<callback()> returns false, then C<value()> returns false and does not store
235 | the new value. If C<callback()> returns true, on the other hand, then
236 | C<value()> goes ahead and stores the new value and returns true.
237 | 
238 | =cut
239 | 
240 | sub value {
241 |     my $self = shift;
242 |     if ($#_ >= 0) {
243 |         # grab the value.
244 |         my $value = shift;
245 |         # Validate the value.
246 |         if ($self->callback($value)) {
247 |             # The value is good. Assign it and return true.
248 |             $self->{value} = $value;
249 |             return 1;
250 |         } else {
251 |             # Invalid value. Return false.
252 |             return;
253 |         }
254 |     }
255 |     # Just return the value.
256 |     return $self->{value};
257 | }
258 | 
259 | 1;
260 | __END__
261 | 
262 | =head1 SUPPORT
263 | 
264 | This module is stored in an open L<GitHub
265 | repository|http://github.com/theory/app-info/>. Feel free to fork and
266 | contribute!
267 | 
268 | Please file bug reports via L<GitHub
269 | Issues|http://github.com/theory/app-info/issues/> or by sending mail to
270 | L<bug-App-Info@rt.cpan.org|mailto:bug-App-Info@rt.cpan.org>.
271 | 
272 | =head1 AUTHOR
273 | 
274 | David E. Wheeler <david@justatheory.com>
275 | 
276 | =head1 SEE ALSO
277 | 
278 | L<App::Info|App::Info> documents the event triggering methods and how they
279 | construct App::Info::Request objects to pass to event handlers.
280 | 
281 | L<App::Info::Handler:|App::Info::Handler> documents how to create custom event
282 | handlers, which must make use of the App::Info::Request object passed to their
283 | C<handler()> object methods.
284 | 
285 | The following classes subclass App::Info::Handler, and thus offer good
286 | exemplars for using App::Info::Request objects when handling events.
287 | 
288 | =over 4
289 | 
290 | =item L<App::Info::Handler::Carp|App::Info::Handler::Carp>
291 | 
292 | =item L<App::Info::Handler::Print|App::Info::Handler::Print>
293 | 
294 | =item L<App::Info::Handler::Prompt|App::Info::Handler::Prompt>
295 | 
296 | =back
297 | 
298 | =head1 COPYRIGHT AND LICENSE
299 | 
300 | Copyright (c) 2002-2011, David E. Wheeler. Some Rights Reserved.
301 | 
302 | This module is free software; you can redistribute it and/or modify it under the
303 | same terms as Perl itself.
304 | 
305 | =cut
306 | 


--------------------------------------------------------------------------------
/types.h:
--------------------------------------------------------------------------------
  1 | /*
  2 | Do not edit this file directly - it is generated by types.c
  3 | */
  4 | 
  5 | typedef struct sql_type_info {
  6 |     int     type_id;
  7 |     char*   type_name;
  8 |     bool    bind_ok;
  9 |     char    array_delimiter;
 10 |     char*   arrayout;
 11 |     char*   (*quote)();
 12 |     void    (*dequote)();
 13 |     union   {
 14 |             int pg;
 15 |             int sql;
 16 |     } type;
 17 |     int     svtype;
 18 | } sql_type_info_t;
 19 | 
 20 | sql_type_info_t* pg_type_data(int);
 21 | sql_type_info_t* sql_type_data(int);
 22 | 
 23 | #define                        PG_ACLITEM  1033
 24 | #define                            PG_ANY  2276
 25 | #define                  PG_ANYCOMPATIBLE  5077
 26 | #define        PG_ANYCOMPATIBLEMULTIRANGE  4538
 27 | #define             PG_ANYCOMPATIBLERANGE  5080
 28 | #define                     PG_ANYELEMENT  2283
 29 | #define                        PG_ANYENUM  3500
 30 | #define                  PG_ANYMULTIRANGE  4537
 31 | #define                       PG_ANYRANGE  3831
 32 | #define                            PG_BIT  1560
 33 | #define                           PG_BOOL  16
 34 | #define                            PG_BOX  603
 35 | #define                         PG_BPCHAR  1042
 36 | #define                          PG_BYTEA  17
 37 | #define                           PG_CHAR  18
 38 | #define                            PG_CID  29
 39 | #define                           PG_CIDR  650
 40 | #define                         PG_CIRCLE  718
 41 | #define                        PG_CSTRING  2275
 42 | #define                           PG_DATE  1082
 43 | #define                 PG_DATEMULTIRANGE  4535
 44 | #define                      PG_DATERANGE  3912
 45 | #define                  PG_EVENT_TRIGGER  3838
 46 | #define                    PG_FDW_HANDLER  3115
 47 | #define                         PG_FLOAT4  700
 48 | #define                         PG_FLOAT8  701
 49 | #define                      PG_GTSVECTOR  3642
 50 | #define               PG_INDEX_AM_HANDLER  325
 51 | #define                           PG_INET  869
 52 | #define                           PG_INT2  21
 53 | #define                     PG_INT2VECTOR  22
 54 | #define                           PG_INT4  23
 55 | #define                 PG_INT4MULTIRANGE  4451
 56 | #define                      PG_INT4RANGE  3904
 57 | #define                           PG_INT8  20
 58 | #define                 PG_INT8MULTIRANGE  4536
 59 | #define                      PG_INT8RANGE  3926
 60 | #define                       PG_INTERNAL  2281
 61 | #define                       PG_INTERVAL  1186
 62 | #define                           PG_JSON  114
 63 | #define                          PG_JSONB  3802
 64 | #define                       PG_JSONPATH  4072
 65 | #define               PG_LANGUAGE_HANDLER  2280
 66 | #define                           PG_LINE  628
 67 | #define                           PG_LSEG  601
 68 | #define                        PG_MACADDR  829
 69 | #define                       PG_MACADDR8  774
 70 | #define                          PG_MONEY  790
 71 | #define                           PG_NAME  19
 72 | #define                        PG_NUMERIC  1700
 73 | #define                  PG_NUMMULTIRANGE  4532
 74 | #define                       PG_NUMRANGE  3906
 75 | #define                            PG_OID  26
 76 | #define                      PG_OIDVECTOR  30
 77 | #define                           PG_PATH  602
 78 | #define                   PG_PG_ATTRIBUTE  75
 79 | #define          PG_PG_BRIN_BLOOM_SUMMARY  4600
 80 | #define   PG_PG_BRIN_MINMAX_MULTI_SUMMARY  4601
 81 | #define                       PG_PG_CLASS  83
 82 | #define                 PG_PG_DDL_COMMAND  32
 83 | #define                PG_PG_DEPENDENCIES  3402
 84 | #define                         PG_PG_LSN  3220
 85 | #define                    PG_PG_MCV_LIST  5017
 86 | #define                   PG_PG_NDISTINCT  3361
 87 | #define                   PG_PG_NODE_TREE  194
 88 | #define                        PG_PG_PROC  81
 89 | #define                    PG_PG_SNAPSHOT  5038
 90 | #define                        PG_PG_TYPE  71
 91 | #define                          PG_POINT  600
 92 | #define                        PG_POLYGON  604
 93 | #define                         PG_RECORD  2249
 94 | #define                      PG_REFCURSOR  1790
 95 | #define                       PG_REGCLASS  2205
 96 | #define                   PG_REGCOLLATION  4191
 97 | #define                      PG_REGCONFIG  3734
 98 | #define                  PG_REGDICTIONARY  3769
 99 | #define                   PG_REGNAMESPACE  4089
100 | #define                        PG_REGOPER  2203
101 | #define                    PG_REGOPERATOR  2204
102 | #define                        PG_REGPROC  24
103 | #define                   PG_REGPROCEDURE  2202
104 | #define                        PG_REGROLE  4096
105 | #define                        PG_REGTYPE  2206
106 | #define               PG_TABLE_AM_HANDLER  269
107 | #define                           PG_TEXT  25
108 | #define                            PG_TID  27
109 | #define                           PG_TIME  1083
110 | #define                      PG_TIMESTAMP  1114
111 | #define                    PG_TIMESTAMPTZ  1184
112 | #define                         PG_TIMETZ  1266
113 | #define                        PG_TRIGGER  2279
114 | #define                   PG_TSMULTIRANGE  4533
115 | #define                    PG_TSM_HANDLER  3310
116 | #define                        PG_TSQUERY  3615
117 | #define                        PG_TSRANGE  3908
118 | #define                 PG_TSTZMULTIRANGE  4534
119 | #define                      PG_TSTZRANGE  3910
120 | #define                       PG_TSVECTOR  3614
121 | #define                  PG_TXID_SNAPSHOT  2970
122 | #define                        PG_UNKNOWN  705
123 | #define                           PG_UUID  2950
124 | #define                         PG_VARBIT  1562
125 | #define                        PG_VARCHAR  1043
126 | #define                           PG_VOID  2278
127 | #define                            PG_XID  28
128 | #define                           PG_XID8  5069
129 | #define                            PG_XML  142
130 | #define                   PG_ACLITEMARRAY  1034
131 | #define                       PG_ANYARRAY  2277
132 | #define             PG_ANYCOMPATIBLEARRAY  5078
133 | #define          PG_ANYCOMPATIBLENONARRAY  5079
134 | #define                    PG_ANYNONARRAY  2776
135 | #define                       PG_BITARRAY  1561
136 | #define                      PG_BOOLARRAY  1000
137 | #define                       PG_BOXARRAY  1020
138 | #define                    PG_BPCHARARRAY  1014
139 | #define                     PG_BYTEAARRAY  1001
140 | #define                      PG_CHARARRAY  1002
141 | #define                       PG_CIDARRAY  1012
142 | #define                      PG_CIDRARRAY  651
143 | #define                    PG_CIRCLEARRAY  719
144 | #define                   PG_CSTRINGARRAY  1263
145 | #define                      PG_DATEARRAY  1182
146 | #define            PG_DATEMULTIRANGEARRAY  6155
147 | #define                 PG_DATERANGEARRAY  3913
148 | #define                    PG_FLOAT4ARRAY  1021
149 | #define                    PG_FLOAT8ARRAY  1022
150 | #define                 PG_GTSVECTORARRAY  3644
151 | #define                      PG_INETARRAY  1041
152 | #define                      PG_INT2ARRAY  1005
153 | #define                PG_INT2VECTORARRAY  1006
154 | #define                      PG_INT4ARRAY  1007
155 | #define            PG_INT4MULTIRANGEARRAY  6150
156 | #define                 PG_INT4RANGEARRAY  3905
157 | #define                      PG_INT8ARRAY  1016
158 | #define            PG_INT8MULTIRANGEARRAY  6157
159 | #define                 PG_INT8RANGEARRAY  3927
160 | #define                  PG_INTERVALARRAY  1187
161 | #define                      PG_JSONARRAY  199
162 | #define                     PG_JSONBARRAY  3807
163 | #define                  PG_JSONPATHARRAY  4073
164 | #define                      PG_LINEARRAY  629
165 | #define                      PG_LSEGARRAY  1018
166 | #define                  PG_MACADDR8ARRAY  775
167 | #define                   PG_MACADDRARRAY  1040
168 | #define                     PG_MONEYARRAY  791
169 | #define                      PG_NAMEARRAY  1003
170 | #define                   PG_NUMERICARRAY  1231
171 | #define             PG_NUMMULTIRANGEARRAY  6151
172 | #define                  PG_NUMRANGEARRAY  3907
173 | #define                       PG_OIDARRAY  1028
174 | #define                 PG_OIDVECTORARRAY  1013
175 | #define                      PG_PATHARRAY  1019
176 | #define              PG_PG_ATTRIBUTEARRAY  270
177 | #define                  PG_PG_CLASSARRAY  273
178 | #define                    PG_PG_LSNARRAY  3221
179 | #define                   PG_PG_PROCARRAY  272
180 | #define               PG_PG_SNAPSHOTARRAY  5039
181 | #define                   PG_PG_TYPEARRAY  210
182 | #define                     PG_POINTARRAY  1017
183 | #define                   PG_POLYGONARRAY  1027
184 | #define                    PG_RECORDARRAY  2287
185 | #define                 PG_REFCURSORARRAY  2201
186 | #define                  PG_REGCLASSARRAY  2210
187 | #define              PG_REGCOLLATIONARRAY  4192
188 | #define                 PG_REGCONFIGARRAY  3735
189 | #define             PG_REGDICTIONARYARRAY  3770
190 | #define              PG_REGNAMESPACEARRAY  4090
191 | #define                   PG_REGOPERARRAY  2208
192 | #define               PG_REGOPERATORARRAY  2209
193 | #define                   PG_REGPROCARRAY  1008
194 | #define              PG_REGPROCEDUREARRAY  2207
195 | #define                   PG_REGROLEARRAY  4097
196 | #define                   PG_REGTYPEARRAY  2211
197 | #define                      PG_TEXTARRAY  1009
198 | #define                       PG_TIDARRAY  1010
199 | #define                      PG_TIMEARRAY  1183
200 | #define                 PG_TIMESTAMPARRAY  1115
201 | #define               PG_TIMESTAMPTZARRAY  1185
202 | #define                    PG_TIMETZARRAY  1270
203 | #define              PG_TSMULTIRANGEARRAY  6152
204 | #define                   PG_TSQUERYARRAY  3645
205 | #define                   PG_TSRANGEARRAY  3909
206 | #define            PG_TSTZMULTIRANGEARRAY  6153
207 | #define                 PG_TSTZRANGEARRAY  3911
208 | #define                  PG_TSVECTORARRAY  3643
209 | #define             PG_TXID_SNAPSHOTARRAY  2949
210 | #define                      PG_UUIDARRAY  2951
211 | #define                    PG_VARBITARRAY  1563
212 | #define                   PG_VARCHARARRAY  1015
213 | #define                      PG_XID8ARRAY  271
214 | #define                       PG_XIDARRAY  1011
215 | #define                       PG_XMLARRAY  143
216 | 
217 | 


--------------------------------------------------------------------------------
/t/30unicode.t:
--------------------------------------------------------------------------------
  1 | #!perl
  2 | 
  3 | ## Test everything related to Unicode.
  4 | ## At the moment, this basically means testing the UTF8 client_encoding
  5 | ## and $dbh->{pg_enable_utf8} bits
  6 | 
  7 | use 5.008001;
  8 | use strict;
  9 | use warnings;
 10 | use lib 'blib/lib', 'blib/arch', 't';
 11 | use utf8; ## no critic (TooMuchCode::ProhibitUnnecessaryUTF8Pragma)
 12 | use charnames ':full';
 13 | use Encode qw(encode_utf8);
 14 | use Data::Dumper;
 15 | use Test::More;
 16 | use open qw/ :std :encoding(utf8) /;
 17 | require 'dbdpg_test_setup.pl';
 18 | select(($|=1,select(STDERR),$|=1)[1]);
 19 | 
 20 | my $dbh = connect_database();
 21 | 
 22 | if (! $dbh) {
 23 |     plan skip_all => 'Connection to database failed, cannot continue testing';
 24 | }
 25 | 
 26 | isnt ($dbh, undef, 'Connect to database for unicode testing');
 27 | 
 28 | 
 29 | my @tests;
 30 | 
 31 | my $server_encoding = $dbh->selectrow_array('SHOW server_encoding');
 32 | my $client_encoding = $dbh->selectrow_array('SHOW client_encoding');
 33 | 
 34 | # Beware, characters used for testing need to be known to Unicode version 4.0.0,
 35 | # which is what perl 5.8.1 shipped with.
 36 | foreach (
 37 |     [ascii => 'Ada Lovelace'],
 38 |     ['latin 1 range' => "\N{LATIN CAPITAL LETTER E WITH ACUTE}milie du Ch\N{LATIN SMALL LETTER A WITH CIRCUMFLEX}telet"],
 39 |     # I'm finding it awkward to continue the theme of female mathematicians
 40 |     ['base plane' => "Interrobang\N{INTERROBANG}"],
 41 |     ['astral plane' => "\N{MUSICAL SYMBOL CRESCENDO}"],
 42 |      ) {
 43 |     my ($range, $text) = @$_;
 44 |     my $name_d = my $name_u = $text;
 45 |     utf8::upgrade($name_u);
 46 |     # Before 5.12.0 the text to the left of => gets to be SvUTF8() under use utf8;
 47 |     # even if it's plain ASCII. This would confuse what we test for below.
 48 |     push @tests, (
 49 |         [upgraded => $range => 'text' => $name_u],
 50 |         [upgraded => $range => 'text[]' => [$name_u]],
 51 |     );
 52 |     if (utf8::downgrade($name_d, 1)) {
 53 |         push @tests, (
 54 |             [downgraded => $range => 'text' => $name_d],
 55 |             [downgraded => $range => 'text[]' => [$name_d]],
 56 |             [mixed => $range => 'text[]' => [$name_d,$name_u]],
 57 |         );
 58 |     }
 59 | }
 60 | 
 61 | my %ranges = (
 62 |     UTF8 => qr/.*/,
 63 |     LATIN1 => qr/\A(?:ascii|latin 1 range)\z/,
 64 | );
 65 | 
 66 | eval { $dbh->do('DROP TABLE dbd_pg_test_unicode') };
 67 | $dbh->commit();
 68 | $dbh->do('CREATE TABLE dbd_pg_test_unicode(t TEXT)');
 69 | 
 70 | foreach (@tests) {
 71 |     my ($state, $range, $type, $value) = @$_;
 72 |  SKIP:
 73 |     foreach my $test (
 74 |         {
 75 |             qtype => 'placeholder',
 76 |             sql => "SELECT ?::$type",
 77 |             args => [$value],
 78 |         },
 79 |         (($type eq 'text') ? (
 80 |             {
 81 |                 qtype => 'interpolated',
 82 |                 sql => "SELECT '$value'::$type",
 83 |             },
 84 |             {
 85 |                 qtype => 'interpolated insert',
 86 |                 sql => "INSERT INTO dbd_pg_test_unicode VALUES ('$value'::$type)",
 87 |             },
 88 |             # Test that what we send is the same as the database's idea of characters:
 89 |             {
 90 |                 qtype => 'placeholder length',
 91 |                 sql => "SELECT length(?::$type)",
 92 |                 args => [$value],
 93 |                 want => length($value),
 94 |             },
 95 |             {
 96 |                 qtype => 'placeholder length insert',
 97 |                 sql => "INSERT INTO dbd_pg_test_unicode VALUES (length(?::$type))",
 98 |                 args => [$value],
 99 |                 want => length($value),
100 |             },
101 |             {
102 |                 qtype => 'interpolated length',
103 |                 sql => "SELECT length('$value'::$type)",
104 |                 want => length($value),
105 |             },
106 |             {
107 |                 qtype => 'interpolated length insert',
108 |                 sql => "INSERT INTO dbd_pg_test_unicode VALUES (length('$value'::$type))",
109 |                 want => length($value),
110 |             },
111 |         ):()),
112 |     ) {
113 |         skip "Can't do $range tests with server_encoding='$server_encoding'", 1
114 |             if $range !~ ($ranges{$server_encoding} || qr/\A(?:ascii)\z/);
115 | 
116 |         skip 'Cannot perform range tests if client_encoding is not UTF8', 1
117 |             if $client_encoding ne 'UTF8';
118 | 
119 |         foreach my $enable_utf8 (1, 0, -1) {
120 |             my $desc = "$state $range UTF-8 $test->{qtype} $type (pg_enable_utf8=$enable_utf8)";
121 |             my @args = @{$test->{args} || []};
122 |             my $want = exists $test->{want} ? $test->{want} : $value;
123 |             if (!$enable_utf8) {
124 |                 $want = ref $want ? [ map encode_utf8($_), @{$want} ] ## no critic
125 |                     : encode_utf8($want);
126 |             }
127 | 
128 |             is(utf8::is_utf8($test->{sql}), ($state eq 'upgraded'), "$desc query has correct flag")
129 |                 if $test->{qtype} =~ /^interpolated/;
130 |             if ($state ne 'mixed') {
131 |                 foreach my $arg (map { ref($_) ? @{$_} : $_ } @args) { ## no critic
132 |                     is(utf8::is_utf8($arg), ($state eq 'upgraded'), "$desc arg has correct flag")
133 |                 }
134 |             }
135 |             $dbh->{pg_enable_utf8} = $enable_utf8;
136 | 
137 |             ## Skip pg_enable_utf=0 for now
138 |             if (0 == $enable_utf8) {
139 |                 if ($range eq 'latin 1 range' or $range eq 'base plane' or $range eq 'astral plane') {
140 |                     pass ("Skipping test of pg_enable_utf=0 with $range");
141 |                     next;
142 |                 }
143 |             }
144 | 
145 | 
146 |             my $sth = $dbh->prepare($test->{sql});
147 |             eval {
148 |                 $sth->execute(@args);
149 |             };
150 |             if ($@) {
151 |                 diag "Failure: enable_utf8=$enable_utf8, SQL=$test->{sql}, range=$range\n";
152 |                 die $@;
153 |             }
154 |             else {
155 |                 if ($test->{qtype} =~ /insert/) {
156 |                     $dbh->commit();
157 |                     $sth = $dbh->prepare('SELECT * FROM dbd_pg_test_unicode');
158 |                     $sth->execute();
159 |                 }
160 |                 my $result = $sth->fetchall_arrayref->[0][0];
161 |                 is_deeply ($result, $want, "$desc via prepare+execute+fetchall returns proper value");
162 |                 if ($test->{qtype} !~ /length/) {
163 |                     # Whilst XS code can set SVf_UTF8 on an IV, the core's SV
164 |                     # copying code doesn't copy it. So we can't assume that numeric
165 |                     # values we see "out here" still have it set. Hence skip this
166 |                     # test for the SQL length() tests.
167 |                     is (utf8::is_utf8($_), !!$enable_utf8, "$desc via prepare+execute+fetchall returns string with correct UTF-8 flag")
168 |                         for (ref $result ? @{$result} : $result);
169 |                 }
170 |             }
171 |             if ($test->{qtype} =~ /insert/) {
172 |                 $dbh->do('DELETE FROM dbd_pg_test_unicode');
173 |                 $dbh->commit();
174 |             }
175 | 
176 | 
177 |             my $result;
178 |             if ($test->{qtype} =~ /insert/) {
179 |                 eval { $dbh->do($test->{sql}, undef, @args) };
180 |                 if (not $@) {
181 |                     $dbh->commit();
182 |                     $result = eval { $dbh->selectall_arrayref('SELECT * FROM dbd_pg_test_unicode')->[0][0] };
183 |                 }
184 |             } else {
185 |                 $result = eval { $dbh->selectall_arrayref($test->{sql}, undef, @args)->[0][0] };
186 |             }
187 |             if ($@) {
188 |                 diag "Failure: enable_utf8=$enable_utf8, SQL=$test->{sql}, range=$range\n";
189 |                 die $@;
190 |             }
191 |             else {
192 |                 is_deeply ($result, $want, "$desc via do/selectall returns proper value");
193 |                 if ($test->{qtype} !~ /length/) {
194 |                     # Whilst XS code can set SVf_UTF8 on an IV, the core's SV
195 |                     # copying code doesn't copy it. So we can't assume that numeric
196 |                     # values we see "out here" still have it set. Hence skip this
197 |                     # test for the SQL length() tests.
198 |                     is (utf8::is_utf8($_), !!$enable_utf8, "$desc via do/selectall returns string with correct UTF-8 flag")
199 |                         for (ref $result ? @{$result} : $result);
200 |                 }
201 |             }
202 |             if ($test->{qtype} =~ /insert/) {
203 |                 $dbh->do('DELETE FROM dbd_pg_test_unicode');
204 |                 $dbh->commit();
205 |             }
206 |         }
207 |     }
208 | }
209 | 
210 | my %ord_max = (
211 |     LATIN1 => 255,
212 |     UTF8 => 2**31,
213 | );
214 | 
215 | # Test that what we get is the same as the database's idea of characters:
216 | for my $name ('LATIN CAPITAL LETTER N',
217 |               'LATIN SMALL LETTER E WITH ACUTE',
218 |               'CURRENCY SIGN',
219 |               # Has a different code point in Unicode, Windows 1252 and ISO-8859-15
220 |               'EURO SIGN',
221 |               'POUND SIGN',
222 |               'YEN SIGN',
223 |               # Has a different code point in Unicode and Windows 1252
224 |               'LATIN CAPITAL LETTER S WITH CARON',
225 |               'SNOWMAN',
226 |               # U+1D196 should be 1 character, not a surrogate pair
227 |               'MUSICAL SYMBOL TR',
228 |           ) {
229 |     my $ord = charnames::vianame($name);
230 |   SKIP:
231 |     foreach my $enable_utf8 (1, 0, -1) {
232 |         my $desc = sprintf "chr(?) for U+%04X $name, \$enable_utf8=$enable_utf8", $ord;
233 |         skip "Pg < 8.3 has broken $desc", 1
234 |             if $ord > 127 && $dbh->{pg_server_version} < 80300;
235 |         skip "Cannot do $desc with server_encoding='$server_encoding'", 1
236 |             if $ord > ($ord_max{$server_encoding} || 127);
237 |         $dbh->{pg_enable_utf8} = $enable_utf8;
238 |          my $sth = $dbh->prepare('SELECT chr(?)');
239 |         $sth->execute($ord);
240 |         my $result = $sth->fetchall_arrayref->[0][0];
241 |         if (!$enable_utf8) {
242 |             # We asked for UTF-8 octets to arrive in Perl-space.
243 |             # Check this, and convert them to character(s).
244 |             # If we didn't, the next two tests are meaningless, so skip them.
245 |             is(utf8::decode($result), 1, "Got valid UTF-8 for $desc")
246 |                 or next;
247 |         }
248 |         is (length $result, 1, "Got 1 character for $desc");
249 |         is (ord $result, $ord, "Got correct character for $desc");
250 |     }
251 | }
252 | 
253 | $dbh->do('DROP TABLE dbd_pg_test_unicode');
254 | $dbh->commit();
255 | cleanup_database($dbh,'test');
256 | $dbh->disconnect();
257 | 
258 | done_testing();
259 | 
260 | 


--------------------------------------------------------------------------------
/t/08async.t:
--------------------------------------------------------------------------------
  1 | #!perl
  2 | 
  3 | ## Test asynchronous queries
  4 | 
  5 | use 5.008001;
  6 | use strict;
  7 | use warnings;
  8 | use lib 'blib/lib', 'blib/arch', 't';
  9 | use Test::More;
 10 | use Time::HiRes qw/sleep/;
 11 | use DBD::Pg ':async';
 12 | require 'dbdpg_test_setup.pl';
 13 | select(($|=1,select(STDERR),$|=1)[1]);
 14 | 
 15 | my $dbh = connect_database();
 16 | 
 17 | if (! $dbh) {
 18 |     plan skip_all => 'Connection to database failed, cannot continue testing';
 19 | }
 20 | 
 21 | plan tests => 67;
 22 | 
 23 | isnt ($dbh, undef, 'Connect to database for async testing');
 24 | 
 25 | my ($t,$sth,$res);
 26 | my $pgversion = $dbh->{pg_server_version};
 27 | 
 28 | ## First, test out do() in all its variants
 29 | 
 30 | $t=q{Method do() works as expected with no args };
 31 | eval {
 32 |     $res = $dbh->do('SELECT 123');
 33 | };
 34 | is ($@, q{}, $t);
 35 | is ($res, 1, $t);
 36 | 
 37 | $t=q{Method do() works as expected with an unused attribute };
 38 | eval {
 39 |     $res = $dbh->do('SELECT 123', {pg_nosuch => 'arg'});
 40 | };
 41 | is ($@, q{}, $t);
 42 | is ($res, 1, $t);
 43 | 
 44 | $t=q{Method do() works as expected with an unused attribute and a non-prepared param };
 45 | eval {
 46 |     $res = $dbh->do('SET random_page_cost TO ?', undef, '2.2');
 47 | };
 48 | is ($@, q{}, $t);
 49 | is ($res, '0E0', $t);
 50 | 
 51 | $t=q{Method do() works as expected with an unused attribute and multiple real bind params };
 52 | eval {
 53 |     $res = $dbh->do('SELECT count(*) FROM pg_class WHERE reltuples IN (?,?,?)', undef, 1,2,3);
 54 | };
 55 | is ($@, q{}, $t);
 56 | is ($res, 1, $t);
 57 | 
 58 | $t=q{Cancelling a non-async do() query gives an error };
 59 | eval {
 60 |     $res = $dbh->pg_cancel();
 61 | };
 62 | like ($@, qr{No asynchronous query is running}, $t);
 63 | 
 64 | $t=q{Method do() works as expected with an asychronous flag };
 65 | eval {
 66 |     $res = $dbh->do('SELECT 123', {pg_async => PG_ASYNC});
 67 | };
 68 | is ($@, q{}, $t);
 69 | is ($res, '0E0', $t);
 70 | 
 71 | $t=q{Database attribute "async_status" returns 1 after async query};
 72 | $res = $dbh->{pg_async_status};
 73 | is ($res, +1, $t);
 74 | 
 75 | sleep 1;
 76 | $t=q{Cancelling an async do() query works };
 77 | eval {
 78 |     $res = $dbh->pg_cancel();
 79 | };
 80 | is ($@, q{}, $t);
 81 | 
 82 | $t=q{Database method pg_cancel returns a false value when cancellation works but finished};
 83 | is ($res, q{}, $t);
 84 | 
 85 | $t=q{Database attribute "async_status" returns -1 after pg_cancel};
 86 | $res = $dbh->{pg_async_status};
 87 | is ($res, -1, $t);
 88 | 
 89 | $t=q{Running do() after a cancelled query works};
 90 | eval {
 91 |     $res = $dbh->do('SELECT 123');
 92 | };
 93 | is ($@, q{}, $t);
 94 | 
 95 | $t=q{Database attribute "async_status" returns 0 after normal query run};
 96 | $res = $dbh->{pg_async_status};
 97 | is ($res, 0, $t);
 98 | 
 99 | $t=q{Method pg_ready() fails after a non-async query};
100 | eval {
101 |     $dbh->pg_ready();
102 | };
103 | like ($@, qr{No async}, $t);
104 | 
105 | $res = $dbh->do('SELECT 123', {pg_async => PG_ASYNC});
106 | $t=q{Method pg_ready() works after a non-async query};
107 | ## Sleep a sub-second to make sure the server has caught up
108 | sleep 0.2;
109 | eval {
110 |     $res = $dbh->pg_ready();
111 | };
112 | is ($@, q{}, $t);
113 | 
114 | $t=q{Database method pg_ready() returns 1 after a completed async do()};
115 | is ($res, 1, $t);
116 | 
117 | $res = $dbh->pg_ready();
118 | $t=q{Database method pg_ready() returns true when called a second time};
119 | is ($res, 1, $t);
120 | 
121 | $t=q{Database method pg_ready() returns 1 after a completed async do()};
122 | is ($res, 1, $t);
123 | $t=q{Cancelling an async do() query works };
124 | eval {
125 |     $res = $dbh->pg_cancel();
126 | };
127 | is ($@, q{}, $t);
128 | $t=q{Database method pg_cancel() returns expected false value for completed value};
129 | is ($res, q{}, $t);
130 | 
131 | $t=q{Method do() runs after pg_cancel has cleared the async query};
132 | eval {
133 |     $dbh->do('SELECT 456');
134 | };
135 | is ($@, q{}, $t);
136 | 
137 | $dbh->do(q{SELECT 'async2'}, {pg_async => PG_ASYNC});
138 | 
139 | $t=q{Method do() fails when async query has not been cleared};
140 | eval {
141 |     $dbh->do(q{SELECT 'async_blocks'});
142 | };
143 | like ($@, qr{previous async}, $t);
144 | 
145 | $t=q{Database method pg_result works as expected};
146 | eval {
147 |     $res = $dbh->pg_result();
148 | };
149 | is ($@, q{}, $t);
150 | 
151 | $t=q{Database method pg_result() returns correct value};
152 | is ($res, 1, $t);
153 | 
154 | $t=q{Database method pg_result() fails when called twice};
155 | eval {
156 |     $dbh->pg_result();
157 | };
158 | like ($@, qr{No async}, $t);
159 | 
160 | $t=q{Database method pg_cancel() fails when called after pg_result()};
161 | eval {
162 |     $dbh->pg_cancel();
163 | };
164 | like ($@, qr{No async}, $t);
165 | 
166 | $t=q{Database method pg_ready() fails when called after pg_result()};
167 | eval {
168 |     $dbh->pg_ready();
169 | };
170 | like ($@, qr{No async}, $t);
171 | 
172 | $t=q{Database method do() works after pg_result()};
173 | eval {
174 |     $dbh->do('SELECT 123');
175 | };
176 | is ($@, q{}, $t);
177 | 
178 | SKIP: {
179 | 
180 |     if ($pgversion < 80200) {
181 |         skip ('Need pg_sleep() to perform rest of async tests: your Postgres is too old', 14);
182 |     }
183 | 
184 |     eval {
185 |         $dbh->do('SELECT pg_sleep(0)');
186 |     };
187 |     is ($@, q{}, 'Calling pg_sleep works as expected');
188 | 
189 |     my $time = time();
190 |     eval {
191 |         $res = $dbh->do('SELECT pg_sleep(2)', {pg_async => PG_ASYNC});
192 |     };
193 |     $time = time()-$time;
194 |     $t = q{Database method do() returns right away when in async mode};
195 |     cmp_ok ($time, '<=', 1, $t);
196 | 
197 |     $t=q{Method pg_ready() returns false when query is still running};
198 |     $res = $dbh->pg_ready();
199 |     is ($res, 0, $t);
200 | 
201 |     pass ('Sleeping to allow query to finish');
202 |     sleep(3);
203 |     $t=q{Method pg_ready() returns true when query is finished};
204 |     $res = $dbh->pg_ready();
205 |     ok ($res, $t);
206 | 
207 |     $t=q{Method do() will not work if async query not yet cleared};
208 |     eval {
209 |         $dbh->do('SELECT pg_sleep(2)', {pg_async => PG_ASYNC});
210 |     };
211 |     like ($@, qr{previous async}, $t);
212 | 
213 |     $t=q{Database method pg_cancel() works while async query is running};
214 |     eval {
215 |         $res = $dbh->pg_cancel();
216 |     };
217 |     is ($@, q{}, $t);
218 |     $t=q{Database method pg_cancel returns false when query has already finished};
219 |     ok (!$res, $t);
220 | 
221 |     $t=q{Database method pg_result() fails after async query has been cancelled};
222 |     eval {
223 |         $res = $dbh->pg_result();
224 |     };
225 |     like ($@, qr{No async}, $t);
226 | 
227 |     $t=q{Database method do() cancels the previous async when requested};
228 |     eval {
229 |         $res = $dbh->do('SELECT pg_sleep(2)', {pg_async => PG_ASYNC + PG_OLDQUERY_CANCEL});
230 |     };
231 |     is ($@, q{}, $t);
232 | 
233 |     $t=q{Database method pg_result works when async query is still running};
234 |     eval {
235 |         $res = $dbh->pg_result();
236 |     };
237 |     is ($@, q{}, $t);
238 | 
239 |     ## Now throw in some execute after the do()
240 |     $sth = $dbh->prepare('SELECT 567');
241 | 
242 |     $t = q{Running execute after async do() gives an error};
243 |     $dbh->do('SELECT pg_sleep(2)', {pg_async => PG_ASYNC});
244 |     eval {
245 |         $res = $sth->execute();
246 |     };
247 |     like ($@, qr{previous async}, $t);
248 | 
249 |     $t = q{Running execute after async do() works when told to cancel};
250 |     $sth = $dbh->prepare('SELECT 678', {pg_async => PG_OLDQUERY_CANCEL});
251 |     eval {
252 |         $sth->execute();
253 |     };
254 |     is ($@, q{}, $t);
255 | 
256 |     $t = q{Running execute after async do() works when told to wait};
257 |     $dbh->do('SELECT pg_sleep(2)', {pg_async => PG_ASYNC});
258 |     $sth = $dbh->prepare('SELECT 678', {pg_async => PG_OLDQUERY_WAIT});
259 |     eval {
260 |         $sth->execute();
261 |     };
262 |     is ($@, q{}, $t);
263 | 
264 |     $sth->finish();
265 | 
266 | } ## end of pg_sleep skip
267 | 
268 | 
269 | $t=q{Method execute() works when prepare has PG_ASYNC flag};
270 | $sth = $dbh->prepare('SELECT 123', {pg_async => PG_ASYNC});
271 | eval {
272 |     $sth->execute();
273 | };
274 | is ($@, q{}, $t);
275 | 
276 | $t=q{Database attribute "async_status" returns 1 after prepare async};
277 | $res = $dbh->{pg_async_status};
278 | is ($res, 1, $t);
279 | 
280 | $t=q{Method do() fails when previous async prepare has been executed};
281 | eval {
282 |     $dbh->do('SELECT 123');
283 | };
284 | like ($@, qr{previous async}, $t);
285 | 
286 | $t=q{Method execute() fails when previous async prepare has been executed};
287 | eval {
288 |     $sth->execute();
289 | };
290 | like ($@, qr{previous async}, $t);
291 | 
292 | $t=q{Database method pg_cancel works if async query has already finished};
293 | sleep 0.5;
294 | eval {
295 |     $res = $sth->pg_cancel();
296 | };
297 | is ($@, q{}, $t);
298 | 
299 | $t=q{Statement method pg_cancel() returns a false value when cancellation works but finished};
300 | is ($res, q{}, $t);
301 | 
302 | $t=q{Method do() fails when previous execute async has not been cleared};
303 | $sth->execute();
304 | $sth->finish(); ## Ideally, this would clear out the async, but it cannot at the moment
305 | eval {
306 |     $dbh->do('SELECT 345');
307 | };
308 | like ($@, qr{previous async}, $t);
309 | 
310 | $dbh->pg_cancel;
311 | 
312 | $t=q{Directly after pg_cancel(), pg_async_status is -1};
313 | is ($dbh->{pg_async_status}, -1, $t);
314 | 
315 | $t=q{Method execute() works when prepare has PG_ASYNC flag};
316 | $sth->execute();
317 | 
318 | $t=q{After async execute, pg_async_status is 1};
319 | is ($dbh->{pg_async_status}, 1, $t);
320 | 
321 | $t=q{Method pg_result works after a prepare/execute call};
322 | eval {
323 |     $res = $dbh->pg_result;
324 | };
325 | is ($@, q{}, $t);
326 | 
327 | $t=q{Method pg_result() returns expected result after prepare/execute select};
328 | is ($res, 1, $t);
329 | 
330 | $t=q{Method fetchall_arrayref works after pg_result};
331 | eval {
332 |     $res = $sth->fetchall_arrayref();
333 | };
334 | is ($@, q{}, $t);
335 | 
336 | $t=q{Method fetchall_arrayref returns correct result after pg_result};
337 | is_deeply ($res, [[123]], $t);
338 | 
339 | $dbh->do('CREATE TABLE dbd_pg_test5(id INT, t TEXT)');
340 | $dbh->commit();
341 | $sth->execute();
342 | 
343 | $t=q{Method prepare() works when passed in PG_OLDQUERY_CANCEL};
344 | 
345 | my $sth2;
346 | my $SQL = 'INSERT INTO dbd_pg_test5(id) SELECT 123 UNION SELECT 456';
347 | eval {
348 |     $sth2 = $dbh->prepare($SQL, {pg_async => PG_ASYNC + PG_OLDQUERY_CANCEL});
349 | };
350 | is ($@, q{}, $t);
351 | 
352 | $t=q{Fetch on cancelled statement handle fails};
353 | eval {
354 |     $sth->fetch();
355 | };
356 | like ($@, qr{no statement executing}, $t);
357 | 
358 | $t=q{Method execute works after async + cancel prepare};
359 | eval {
360 |     $sth2->execute();
361 | };
362 | is ($@, q{}, $t);
363 | 
364 | $t=q{Statement method pg_result works on async statement handle};
365 | eval {
366 |     $res = $sth2->pg_result();
367 | };
368 | is ($@, q{}, $t);
369 | 
370 | $t=q{Statement method pg_result returns correct result after execute};
371 | is ($res, 2, $t);
372 | 
373 | $sth2->execute();
374 | 
375 | $t=q{Database method pg_result works on async statement handle};
376 | eval {
377 |     $res = $sth2->pg_result();
378 | };
379 | is ($@, q{}, $t);
380 | $t=q{Database method pg_result returns correct result after execute};
381 | is ($res, 2, $t);
382 | 
383 | $dbh->do('DROP TABLE dbd_pg_test5');
384 | 
385 | ## TODO: More pg_sleep tests with execute
386 | 
387 | cleanup_database($dbh,'test');
388 | $dbh->disconnect;
389 | 
390 | 


--------------------------------------------------------------------------------
/t/lib/App/Info/Handler.pm:
--------------------------------------------------------------------------------
  1 | package App::Info::Handler;
  2 | 
  3 | =head1 NAME
  4 | 
  5 | App::Info::Handler - App::Info event handler base class
  6 | 
  7 | =head1 SYNOPSIS
  8 | 
  9 |   use App::Info::Category::FooApp;
 10 |   use App::Info::Handler;
 11 | 
 12 |   my $app = App::Info::Category::FooApp->new( on_info => ['default'] );
 13 | 
 14 | =head1 DESCRIPTION
 15 | 
 16 | This class defines the interface for subclasses that wish to handle events
 17 | triggered by App::Info concrete subclasses. The different types of events
 18 | triggered by App::Info can all be handled by App::Info::Handler (indeed, by
 19 | default they're all handled by a single App::Info::Handler object), and
 20 | App::Info::Handler subclasses may be designed to handle whatever events they
 21 | wish.
 22 | 
 23 | If you're interested in I<using> an App::Info event handler, this is probably
 24 | not the class you should look at, since all it does is define a simple handler
 25 | that does nothing with an event. Look to the L<App::Info::Handler
 26 | subclasses|"SEE ALSO"> included in this distribution to do more interesting
 27 | things with App::Info events.
 28 | 
 29 | If, on the other hand, you're interested in implementing your own event
 30 | handlers, read on!
 31 | 
 32 | =cut
 33 | 
 34 | use strict;
 35 | our $VERSION = '0.57';
 36 | 
 37 | my %handlers;
 38 | 
 39 | =head1 INTERFACE
 40 | 
 41 | This section documents the public interface of App::Info::Handler.
 42 | 
 43 | =head2 Class Method
 44 | 
 45 | =head3 register_handler
 46 | 
 47 |   App::Info::Handler->register_handler( $key => $code_ref );
 48 | 
 49 | This class method may be used by App::Info::Handler subclasses to register
 50 | themselves with App::Info::Handler. Multiple registrations are supported. The
 51 | idea is that a subclass can define different functionality by specifying
 52 | different strings that represent different modes of constructing an
 53 | App::Info::Handler subclass object. The keys are case-sensitive, and should be
 54 | unique across App::Info::Handler subclasses so that many subclasses can be
 55 | loaded and used separately. If the C<$key> is already registered,
 56 | C<register_handler()> will throw an exception. The values are code references
 57 | that, when executed, return the appropriate App::Info::Handler subclass
 58 | object.
 59 | 
 60 | =cut
 61 | 
 62 | sub register_handler {
 63 |     my ($pkg, $key, $code) = @_;
 64 |     Carp::croak("Handler '$key' already exists")
 65 |       if $handlers{$key};
 66 |     $handlers{$key} = $code;
 67 | }
 68 | 
 69 | # Register ourself.
 70 | __PACKAGE__->register_handler('default', sub { __PACKAGE__->new } );
 71 | 
 72 | ##############################################################################
 73 | 
 74 | =head2 Constructor
 75 | 
 76 | =head3 new
 77 | 
 78 |   my $handler = App::Info::Handler->new;
 79 |   $handler =  App::Info::Handler->new( key => $key);
 80 | 
 81 | Constructs an App::Info::Handler object and returns it. If the key parameter
 82 | is provided and has been registered by an App::Info::Handler subclass via the
 83 | C<register_handler()> class method, then the relevant code reference will be
 84 | executed and the resulting App::Info::Handler subclass object returned. This
 85 | approach provides a handy shortcut for having C<new()> behave as an abstract
 86 | factory method, returning an object of the subclass appropriate to the key
 87 | parameter.
 88 | 
 89 | =cut
 90 | 
 91 | sub new {
 92 |     my ($pkg, %p) = @_;
 93 |     my $class = ref $pkg || $pkg;
 94 |     $p{key} ||= 'default';
 95 |     if ($class eq __PACKAGE__ && $p{key} ne 'default') {
 96 |         # We were called directly! Handle it.
 97 |         Carp::croak("No such handler '$p{key}'") unless $handlers{$p{key}};
 98 |         return $handlers{$p{key}}->();
 99 |     } else {
100 |         # A subclass called us -- just instantiate and return.
101 |         return bless \%p, $class;
102 |     }
103 | }
104 | 
105 | =head2 Instance Method
106 | 
107 | =head3 handler
108 | 
109 |   $handler->handler($req);
110 | 
111 | App::Info::Handler defines a single instance method that must be defined by
112 | its subclasses, C<handler()>. This is the method that will be executed by an
113 | event triggered by an App::Info concrete subclass. It takes as its single
114 | argument an App::Info::Request object, and returns a true value if it has
115 | handled the event request. Returning a false value declines the request, and
116 | App::Info will then move on to the next handler in the chain.
117 | 
118 | The C<handler()> method implemented in App::Info::Handler itself does nothing
119 | more than return a true value. It thus acts as a very simple default event
120 | handler. See the App::Info::Handler subclasses for more interesting handling
121 | of events, or create your own!
122 | 
123 | =cut
124 | 
125 | sub handler { 1 }
126 | 
127 | 1;
128 | __END__
129 | 
130 | =head1 SUBCLASSING
131 | 
132 | I hatched the idea of the App::Info event model with its subclassable handlers
133 | as a way of separating the aggregation of application meta data from writing a
134 | user interface for handling certain conditions. I felt it a better idea to
135 | allow people to create their own user interfaces, and instead to provide only
136 | a few examples. The App::Info::Handler class defines the API interface for
137 | handling these conditions, which App::Info refers to as "events".
138 | 
139 | There are various types of events defined by App::Info ("info", "error",
140 | "unknown", and "confirm"), but the App::Info::Handler interface is designed to
141 | be flexible enough to handle any and all of them. If you're interested in
142 | creating your own App::Info event handler, this is the place to learn how.
143 | 
144 | =head2 The Interface
145 | 
146 | To create an App::Info event handler, all one need do is subclass
147 | App::Info::Handler and then implement the C<new()> constructor and the
148 | C<handler()> method. The C<new()> constructor can do anything you like, and
149 | take any arguments you like. However, I do recommend that the first thing
150 | you do in your implementation is to call the super constructor:
151 | 
152 |   sub new {
153 |       my $pkg = shift;
154 |       my $self = $pkg->SUPER::new(@_);
155 |       # ... other stuff.
156 |       return $self;
157 |   }
158 | 
159 | Although the default C<new()> constructor currently doesn't do much, that may
160 | change in the future, so this call will keep you covered. What it does do is
161 | take the parameterized arguments and assign them to the App::Info::Handler
162 | object. Thus if you've specified a "mode" argument, where clients can
163 | construct objects of you class like this:
164 | 
165 |   my $handler = FooHandler->new( mode => 'foo' );
166 | 
167 | You can access the mode parameter directly from the object, like so:
168 | 
169 |   sub new {
170 |       my $pkg = shift;
171 |       my $self = $pkg->SUPER::new(@_);
172 |       if ($self->{mode} eq 'foo') {
173 |           # ...
174 |       }
175 |       return $self;
176 |   }
177 | 
178 | Just be sure not to use a parameter key name required by App::Info::Handler
179 | itself. At the moment, the only parameter accepted by App::Info::Handler is
180 | "key", so in general you'll be pretty safe.
181 | 
182 | Next, I recommend that you take advantage of the C<register_handler()> method
183 | to create some shortcuts for creating handlers of your class. For example, say
184 | we're creating a handler subclass FooHandler. It has two modes, a default
185 | "foo" mode and an advanced "bar" mode. To allow both to be constructed by
186 | stringified shortcuts, the FooHandler class implementation might start like
187 | this:
188 | 
189 |   package FooHandler;
190 | 
191 |   use strict;
192 |   use App::Info::Handler;
193 |   our @ISA = qw(App::Info::Handler);
194 | 
195 |   foreach my $c (qw(foo bar)) {
196 |       App::Info::Handler->register_handler
197 |         ( $c => sub { __PACKAGE__->new( mode => $c) } );
198 |   }
199 | 
200 | The strings "foo" and "bar" can then be used by clients as shortcuts to have
201 | App::Info objects automatically create and use handlers for certain events.
202 | For example, if a client wanted to use a "bar" event handler for its info
203 | events, it might do this:
204 | 
205 |   use App::Info::Category::FooApp;
206 |   use FooHandler;
207 | 
208 |   my $app = App::Info::Category::FooApp->new(on_info => ['bar']);
209 | 
210 | Take a look at App::Info::Handler::Print and App::Info::Handler::Carp to see
211 | concrete examples of C<register_handler()> usage.
212 | 
213 | The final step in creating a new App::Info event handler is to implement the
214 | C<handler()> method itself. This method takes a single argument, an
215 | App::Info::Request object, and is expected to return true if it handled the
216 | request, and false if it did not. The App::Info::Request object contains all
217 | the meta data relevant to a request, including the type of event that triggered
218 | it; see L<App::Info::Request|App::Info::Request> for its documentation.
219 | 
220 | Use the App::Info::Request object however you like to handle the request
221 | however you like. You are, however, expected to abide by a a few guidelines:
222 | 
223 | =over 4
224 | 
225 | =item *
226 | 
227 | For error and info events, you are expected (but not required) to somehow
228 | display the info or error message for the user. How your handler chooses to do
229 | so is up to you and the handler.
230 | 
231 | =item *
232 | 
233 | For unknown and confirm events, you are expected to prompt the user for a
234 | value. If it's a confirm event, offer the known value (found in
235 | C<< $req->value >>) as a default.
236 | 
237 | =item *
238 | 
239 | For unknown and confirm events, you are expected to call C<< $req->callback >>
240 | and pass in the new value. If C<< $req->callback >> returns a false value, you
241 | are expected to display the error message in C<< $req->error >> and prompt the
242 | user again. Note that C<< $req->value >> calls C<< $req->callback >>
243 | internally, and thus assigns the value and returns true if
244 | C<< $req->callback >> returns true, and does not assign the value and returns
245 | false if C<< $req->callback >> returns false.
246 | 
247 | =item *
248 | 
249 | For unknown and confirm events, if you've collected a new value and
250 | C<< $req->callback >> returns true for that value, you are expected to assign
251 | the value by passing it to C<< $req->value >>. This allows App::Info to give
252 | the value back to the calling App::Info concrete subclass.
253 | 
254 | =back
255 | 
256 | Probably the easiest way to get started creating new App::Info event handlers
257 | is to check out the simple handlers provided with the distribution and follow
258 | their logical examples. Consult the App::Info documentation of the L<event
259 | methods|App::Info/"Events"> for details on how App::Info constructs the
260 | App::Info::Request object for each event type.
261 | 
262 | =head1 SUPPORT
263 | 
264 | This module is stored in an open L<GitHub
265 | repository|http://github.com/theory/app-info/>. Feel free to fork and
266 | contribute!
267 | 
268 | Please file bug reports via L<GitHub
269 | Issues|http://github.com/theory/app-info/issues/> or by sending mail to
270 | L<bug-App-Info@rt.cpan.org|mailto:bug-App-Info@rt.cpan.org>.
271 | 
272 | =head1 AUTHOR
273 | 
274 | David E. Wheeler <david@justatheory.com>
275 | 
276 | =head1 SEE ALSO
277 | 
278 | L<App::Info|App::Info> thoroughly documents the client interface for setting
279 | event handlers, as well as the event triggering interface for App::Info
280 | concrete subclasses.
281 | 
282 | L<App::Info::Request|App::Info::Request> documents the interface for the
283 | request objects passed to App::Info::Handler C<handler()> methods.
284 | 
285 | The following App::Info::Handler subclasses offer examples for event handler
286 | authors, and, of course, provide actual event handling functionality for
287 | App::Info clients.
288 | 
289 | =over 4
290 | 
291 | =item L<App::Info::Handler::Carp|App::Info::Handler::Carp>
292 | 
293 | =item L<App::Info::Handler::Print|App::Info::Handler::Print>
294 | 
295 | =item L<App::Info::Handler::Prompt|App::Info::Handler::Prompt>
296 | 
297 | =back
298 | 
299 | =head1 COPYRIGHT AND LICENSE
300 | 
301 | Copyright (c) 2002-2011, David E. Wheeler. Some Rights Reserved.
302 | 
303 | This module is free software; you can redistribute it and/or modify it under the
304 | same terms as Perl itself.
305 | 
306 | =cut
307 | 


--------------------------------------------------------------------------------
/t/07copy.t:
--------------------------------------------------------------------------------
  1 | #!perl
  2 | 
  3 | ## Test the COPY functionality
  4 | 
  5 | use 5.008001;
  6 | use strict;
  7 | use warnings;
  8 | use lib 'blib/lib', 'blib/arch', 't';
  9 | use Data::Dumper;
 10 | use DBD::Pg ':async';
 11 | use Test::More;
 12 | require 'dbdpg_test_setup.pl';
 13 | select(($|=1,select(STDERR),$|=1)[1]);
 14 | 
 15 | my $dbh = connect_database();
 16 | 
 17 | if ($dbh) {
 18 |     plan tests => 62;
 19 | }
 20 | else {
 21 |     plan skip_all => 'Connection to database failed, cannot continue testing';
 22 | }
 23 | 
 24 | ok (defined $dbh, 'Connect to database for COPY testing');
 25 | 
 26 | my ($result,$expected,@data,$t);
 27 | 
 28 | my $table = 'dbd_pg_test4';
 29 | $dbh->do(qq{CREATE TABLE $table(id2 integer, val2 text)});
 30 | $dbh->commit();
 31 | my $pgversion = $dbh->{pg_server_version};
 32 | 
 33 | #
 34 | # Test of the pg_putline and pg_endcopy methods
 35 | #
 36 | 
 37 | ## pg_putline should fail unless we are in a COPY IN state
 38 | $t='pg_putline fails when issued without a preceding COPY command';
 39 | eval {
 40 |     $dbh->pg_putline("12\tMulberry");
 41 | };
 42 | ok ($@, $t);
 43 | 
 44 | $t='putline returned a value of 1 for success';
 45 | $dbh->do("COPY $table FROM STDIN");
 46 | $result = $dbh->pg_putline("12\tMulberry\n");
 47 | is ($result, 1, $t);
 48 | 
 49 | $t='putline returned a value of 1 for success';
 50 | $result = $dbh->pg_putline("13\tStrawberry\n");
 51 | is ($result, 1, $t);
 52 | 
 53 | $t='putline returned a value of 1 for success';
 54 | $result = $dbh->pg_putline("14\tBlueberry\n");
 55 | is ($result, 1, $t);
 56 | 
 57 | ## Commands are not allowed while in a COPY IN state
 58 | $t='do() fails while in a COPY IN state';
 59 | eval {
 60 |     $dbh->do(q{SELECT 'dbdpg_copytest'});
 61 | };
 62 | ok ($@, $t);
 63 | 
 64 | ## pg_getline is not allowed as we are in a COPY_IN state
 65 | $t='pg_getline fails while in a COPY IN state';
 66 | $data[0] = '';
 67 | eval {
 68 |     $dbh->pg_getline($data[0], 100);
 69 | };
 70 | ok ($@, $t);
 71 | 
 72 | $t='pg_endcopy returned a 1';
 73 | $result = $dbh->pg_endcopy();
 74 | is ($result, 1, $t);
 75 | 
 76 | ## Make sure we can issue normal commands again
 77 | $dbh->do(q{SELECT 'dbdpg_copytest'});
 78 | 
 79 | ## Make sure we are out of the COPY IN state and pg_putline no longer works
 80 | $t='pg_putline fails when issued after pg_endcopy called';
 81 | eval {
 82 |     $dbh->pg_putline("16\tBlackberry");
 83 | };
 84 | ok ($@, $t);
 85 | 
 86 | ## Check that our lines were inserted properly
 87 | $t='putline inserted values correctly';
 88 | $expected = [[12 => 'Mulberry'],[13 => 'Strawberry'],[14 => 'Blueberry']];
 89 | $result = $dbh->selectall_arrayref("SELECT id2,val2 FROM $table ORDER BY id2");
 90 | is_deeply ($result, $expected, $t);
 91 | 
 92 | # pg_endcopy should not work because we are no longer in a COPY state
 93 | $t='pg_endcopy fails when called twice after COPY IN';
 94 | eval {
 95 |     $dbh->pg_endcopy;
 96 | };
 97 | ok ($@, $t);
 98 | 
 99 | $dbh->commit();
100 | 
101 | #
102 | # Test of the pg_getline method
103 | #
104 | 
105 | ## pg_getline should fail unless we are in a COPY OUT state
106 | $t='pg_getline fails when issued without a preceding COPY command';
107 | eval {
108 |     $dbh->pg_getline($data[0], 100);
109 | };
110 | ok ($@, $t);
111 | 
112 | $t='pg_getline returns a 1';
113 | $dbh->do("COPY $table TO STDOUT");
114 | my $buffer = '';
115 | $result = $dbh->pg_getline($data[0], 100);
116 | is ($result, 1, $t);
117 | 
118 | ## Commands are not allowed while in a COPY OUT state
119 | $t='do() fails while in a COPY OUT state';
120 | eval {
121 |     $dbh->do(q{SELECT 'dbdpg_copytest'});
122 | };
123 | ok ($@, $t);
124 | 
125 | ## pg_putline is not allowed as we are in a COPY OUT state
126 | $t='pg_putline fails while in a COPY OUT state';
127 | eval {
128 |     $dbh->pg_putline("99\tBogusberry");
129 | };
130 | ok ($@, $t);
131 | 
132 | $t='pg_getline returned a 1';
133 | $data[1]=$data[2]=$data[3]='';
134 | $result = $dbh->pg_getline($data[1], 100);
135 | is ($result, 1, $t);
136 | 
137 | $t='pg_getline returned a 1';
138 | $result = $dbh->pg_getline($data[2], 100);
139 | is ($result, 1, $t);
140 | 
141 | $t='pg_getline returns empty on final call';
142 | $result = $dbh->pg_getline($data[3], 100);
143 | is ($result, '', $t);
144 | 
145 | $t='getline returned all rows successfuly';
146 | $result = \@data;
147 | $expected = ["12\tMulberry\n","13\tStrawberry\n","14\tBlueberry\n",''];
148 | is_deeply ($result, $expected, $t);
149 | 
150 | ## Make sure we can issue normal commands again
151 | $dbh->do(q{SELECT 'dbdpg_copytest'});
152 | 
153 | ## Make sure we are out of the COPY OUT state and pg_getline no longer works
154 | $t='pg_getline fails when issued after pg_endcopy called';
155 | eval {
156 |     $data[5]='';
157 |     $dbh->pg_getline($data[5], 100);
158 | };
159 | ok ($@, $t);
160 | 
161 | ## pg_endcopy should fail because we are no longer in a COPY state
162 | $t='pg_endcopy fails when called twice after COPY OUT';
163 | eval {
164 |     $dbh->pg_endcopy;
165 | };
166 | ok ($@, $t);
167 | 
168 | 
169 | ##
170 | ## Test the new COPY methods
171 | ##
172 | 
173 | $dbh->do("DELETE FROM $table");
174 | 
175 | $t='pg_putcopydata fails if not after a COPY FROM statement';
176 | eval {
177 |     $dbh->pg_putcopydata("pizza\tpie");
178 | };
179 | like ($@, qr{COPY FROM command}, $t);
180 | 
181 | $t='pg_getcopydata fails if not after a COPY TO statement';
182 | eval {
183 |     $dbh->pg_getcopydata($data[0]);
184 | };
185 | like ($@, qr{COPY TO command}, $t);
186 | 
187 | $t='pg_getcopydata_async fails if not after a COPY TO statement';
188 | eval {
189 |     $dbh->pg_getcopydata_async($data[0]);
190 | };
191 | like ($@, qr{COPY TO command}, $t);
192 | 
193 | $t='pg_putcopyend warns but does not die if not after a COPY statement';
194 | eval { require Test::Warn; };
195 | if ($@) {
196 |     pass ('Skipping Test::Warn test');
197 | }
198 | else {
199 |     Test::Warn::warning_like (sub { $dbh->pg_putcopyend(); }, qr/until a COPY/, $t);
200 | }
201 | 
202 | $t='pg_getcopydata does not work if we are using COPY .. TO';
203 | $dbh->rollback();
204 | $dbh->do("COPY $table FROM STDIN");
205 | eval {
206 |     $dbh->pg_getcopydata($data[0]);
207 | };
208 | like ($@, qr{COPY TO command}, $t);
209 | 
210 | $t='pg_putcopydata does not work if we are using COPY .. FROM';
211 | $dbh->rollback();
212 | $dbh->do("COPY $table TO STDOUT");
213 | eval {
214 |     $dbh->pg_putcopydata("pizza\tpie");
215 | };
216 | like ($@, qr{COPY FROM command}, $t);
217 | 
218 | $t='pg_putcopydata works and returns a 1 on success';
219 | $dbh->rollback();
220 | $dbh->do("COPY $table FROM STDIN");
221 | $result = $dbh->pg_putcopydata("15\tBlueberry");
222 | is ($result, 1, $t);
223 | 
224 | $t='pg_putcopydata works on second call';
225 | $dbh->rollback();
226 | $dbh->do("COPY $table FROM STDIN");
227 | $result = $dbh->pg_putcopydata("16\tMoreBlueberries");
228 | is ($result, 1, $t);
229 | 
230 | $t='pg_putcopydata fails with invalid data';
231 | $dbh->rollback();
232 | $dbh->do("COPY $table FROM STDIN");
233 | eval {
234 |     $dbh->pg_putcopydata();
235 | };
236 | ok ($@, $t);
237 | 
238 | $t='Calling pg_getcopydata gives an error when in the middle of COPY .. TO';
239 | eval {
240 |     $dbh->pg_getcopydata($data[0]);
241 | };
242 | like ($@, qr{COPY TO command}, $t);
243 | 
244 | $t='Calling do() gives an error when in the middle of COPY .. FROM';
245 | eval {
246 |     $dbh->do('SELECT 123');
247 | };
248 | like ($@, qr{call pg_putcopyend}, $t);
249 | 
250 | $t='pg_putcopydata works after a rude non-COPY attempt';
251 | eval {
252 |     $result = $dbh->pg_putcopydata("17\tMoreBlueberries");
253 | };
254 | is ($@, q{}, $t);
255 | is ($result, 1, $t);
256 | 
257 | $t='pg_putcopyend works and returns a 1';
258 | eval {
259 |     $result = $dbh->pg_putcopyend();
260 | };
261 | is ($@, q{}, $t);
262 | is ($result, 1, $t);
263 | 
264 | $t='pg_putcopydata fails after pg_putcopyend is called';
265 | $dbh->commit();
266 | eval {
267 |     $result = $dbh->pg_putcopydata('root');
268 | };
269 | like ($@, qr{COPY FROM command}, $t);
270 | 
271 | $t='Normal queries work after pg_putcopyend is called';
272 | eval {
273 |     $dbh->do('SELECT 123');
274 | };
275 | is ($@, q{}, $t);
276 | 
277 | $t='Data from pg_putcopydata was entered correctly';
278 | $result = $dbh->selectall_arrayref("SELECT id2,val2 FROM $table ORDER BY id2");
279 | $expected = [['12','Mulberry'],['13','Strawberry'],[14,'Blueberry'],[17,'MoreBlueberries']];
280 | is_deeply ($result, $expected, $t);
281 | 
282 | $t='pg_getcopydata fails when argument is not a variable';
283 | $dbh->do("COPY $table TO STDOUT");
284 | eval {
285 |     $dbh->pg_getcopydata('wrongo');
286 | };
287 | like ($@, qr{read-only}, $t);
288 | 
289 | $t='pg_getcopydata works and returns the length of the string';
290 | $data[0] = 'old';
291 | eval {
292 |     $dbh->pg_getcopydata($data[0]);
293 | };
294 | is ($@, q{}, $t);
295 | is ($data[0], "13\tStrawberry\n", $t);
296 | 
297 | $t='pg_getcopydata works when argument is a reference';
298 | eval {
299 |     $dbh->pg_getcopydata(\$data[0]);
300 | };
301 | is ($@, q{}, $t);
302 | is ($data[0], "14\tBlueberry\n", $t);
303 | 
304 | $t='Calling do() gives an error when in the middle of COPY .. TO';
305 | eval {
306 |     $dbh->do('SELECT 234');
307 | };
308 | like ($@, qr{pg_getcopydata}, $t);
309 | 
310 | $t='Calling pg_putcopydata gives an errors when in the middle of COPY .. FROM';
311 | eval {
312 |     $dbh->pg_putcopydata('pie');
313 | };
314 | like ($@, qr{COPY FROM command}, $t);
315 | 
316 | $t='pg_getcopydata returns 0 when no more data';
317 | $dbh->pg_getcopydata(\$data[0]);
318 | eval {
319 |     $result = $dbh->pg_getcopydata(\$data[0]);
320 | };
321 | is ($@, q{}, $t);
322 | is ($data[0], '', $t);
323 | is ($result, -1, $t);
324 | 
325 | $t='Normal queries work after pg_getcopydata runs out';
326 | eval {
327 |     $dbh->do('SELECT 234');
328 | };
329 | is ($@, q{}, $t);
330 | 
331 | $t='Async queries work after COPY OUT';
332 | $dbh->do('CREATE TEMP TABLE foobar AS SELECT 123::INTEGER AS x');
333 | $dbh->do('COPY foobar TO STDOUT');
334 | 1 while ($dbh->pg_getcopydata($buffer) >= 0);
335 | 
336 | eval {
337 |     $dbh->do('SELECT 111', { pg_async => PG_ASYNC} );
338 | };
339 | is ($@, q{}, $t);
340 | $dbh->pg_result();
341 | 
342 | $t='Async queries work after COPY IN';
343 | $dbh->do('COPY foobar FROM STDIN');
344 | $dbh->pg_putcopydata(456);
345 | $dbh->pg_putcopyend();
346 | 
347 | eval {
348 |     $dbh->do('SELECT 222', { pg_async => PG_ASYNC} );
349 | };
350 | is ($@, q{}, $t);
351 | $dbh->pg_result();
352 | 
353 | 
354 | SKIP: {
355 |     $pgversion < 80200 and skip ('Server version 8.2 or greater needed for test', 1);
356 | 
357 |     $t='pg_getcopydata works when pulling from an empty table into an empty var';
358 |     $dbh->do(q{COPY (SELECT 1 FROM pg_class LIMIT 0) TO STDOUT});
359 |     eval {
360 |         my $newvar;
361 |         $dbh->pg_getcopydata($newvar);
362 |     };
363 |     is ($@, q{}, $t);
364 | }
365 | 
366 | #
367 | # Make sure rollback and commit reset our internal copystate tracking
368 | #
369 | 
370 | $t='commit resets COPY state';
371 | $dbh->do("COPY $table TO STDOUT");
372 | $dbh->commit();
373 | eval {
374 |     $dbh->do(q{SELECT 'dbdpg_copytest'});
375 | };
376 | ok (!$@, $t);
377 | 
378 | $t='rollback resets COPY state';
379 | $dbh->do("COPY $table TO STDOUT");
380 | $dbh->rollback();
381 | eval {
382 |     $dbh->do(q{SELECT 'dbdpg_copytest'});
383 | };
384 | ok (!$@, $t);
385 | 
386 | 
387 | #
388 | # Keep old-style calls around for backwards compatibility
389 | #
390 | 
391 | $t=q{old-style dbh->func('text', 'putline') still works};
392 | $dbh->do("COPY $table FROM STDIN");
393 | $result = $dbh->func("13\tOlive\n", 'putline');
394 | is ($result, 1, $t);
395 | 
396 | $t=q{old-style dbh->func(var, length, 'getline') still works};
397 | $dbh->pg_endcopy;
398 | $dbh->do("COPY $table TO STDOUT");
399 | $result = $dbh->func($data[0], 100, 'getline');
400 | is ($result, 1, $t);
401 | 1 while ($result = $dbh->func($data[0], 100, 'getline'));
402 | 
403 | # Test binary copy mode
404 | $dbh->do('CREATE TEMP TABLE binarycopy AS SELECT 1::INTEGER AS x');
405 | $dbh->do('COPY binarycopy TO STDOUT BINARY');
406 | 
407 | my $copydata;
408 | my $length = $dbh->pg_getcopydata($copydata);
409 | while ($dbh->pg_getcopydata(my $tmp) >= 0) {
410 |     $copydata .= $tmp;
411 | }
412 | 
413 | ok (!utf8::is_utf8($copydata), 'pg_getcopydata clears UTF-8 flag on binary copy result');
414 | is (substr($copydata, 0, 11), "PGCOPY\n\377\r\n\0", 'pg_getcopydata preserves binary copy header signature');
415 | cmp_ok ($length, '>=', 19, 'pg_getcopydata returns sane length of binary copy');
416 | 
417 | $dbh->do('COPY binarycopy FROM STDIN BINARY');
418 | eval {
419 |     $dbh->pg_putcopydata($copydata);
420 |     $dbh->pg_putcopyend;
421 | };
422 | is $@, '', 'pg_putcopydata in binary mode works'
423 |     or diag $copydata;
424 | 
425 | $t=q{COPY in binary mode roundtrips};
426 | is_deeply ($dbh->selectall_arrayref('SELECT * FROM binarycopy'), [[1],[1]], $t);
427 | 
428 | $dbh->do("DROP TABLE $table");
429 | $dbh->commit();
430 | 
431 | cleanup_database($dbh,'test');
432 | $dbh->disconnect;
433 | 


--------------------------------------------------------------------------------
/Makefile.PL:
--------------------------------------------------------------------------------
  1 | use ExtUtils::MakeMaker;
  2 | use Config;
  3 | use strict;
  4 | use warnings;
  5 | use 5.008001;
  6 | 
  7 | ## No version.pm for this one, as the prereqs are not loaded yet.
  8 | my $VERSION = '3.18.0';
  9 | 
 10 | ## App::Info is stored inside t/lib
 11 | ## Create a proper path so we can use it below
 12 | my $lib;
 13 | my $sep;
 14 | BEGIN {
 15 |     my %seplist = (
 16 |                MacOS   => ':',
 17 |                MSWin32 => '\\',
 18 |                os2     => '\\',
 19 |                VMS     => '\\',
 20 |                NetWare => '\\',
 21 |                dos     => '\\',
 22 |                );
 23 |     $sep = $seplist{$^O} || '/';
 24 |     $lib = join $sep, 't', 'lib';
 25 | }
 26 | 
 27 | use lib $lib;
 28 | 
 29 | if ($VERSION =~ /_/) {
 30 |     print "WARNING! This is a test version ($VERSION) and should not be used in production!\n";
 31 | }
 32 | 
 33 | if (grep { /help/ } @ARGV) {
 34 |     print qq{
 35 | Usage: perl $0
 36 | 
 37 | No other options are necessary, although you may need to
 38 | set some evironment variables. See the README file for full details.
 39 | 
 40 | In brief:
 41 | 
 42 | By default Makefile.PL uses App::Info to find the location of the
 43 | PostgreSQL library and include directories.  However, if you want to
 44 | control it yourself, define the environment variables POSTGRES_INCLUDE
 45 | and POSTGRES_LIB, or define just POSTGRES_HOME. Note that if you have
 46 | compiled PostgreSQL with SSL support, you must define the POSTGRES_LIB
 47 | environment variable and add "-lssl" to it, like this:
 48 | 
 49 | export POSTGRES_LIB="/usr/local/pgsql/lib -lssl"
 50 | 
 51 | The usual steps to install DBD::Pg:
 52 | 
 53 | 1.   perl Makefile.PL
 54 | 2.   make
 55 | 3.   make test
 56 | 4.   make install
 57 | 
 58 | Do steps 1 to 3 as a normal user, not as root!
 59 | 
 60 | If all else fails, email dbd-pg\@perl.org for help.
 61 | 
 62 | };
 63 |     exit 1;
 64 | 
 65 | }
 66 | 
 67 | print "Configuring DBD::Pg $VERSION\n";
 68 | 
 69 | my $POSTGRES_INCLUDE;
 70 | my $POSTGRES_LIB;
 71 | 
 72 | # We need the version information to properly set compiler options later
 73 | # Use App::Info to get the data we need.
 74 | require App::Info::RDBMS::PostgreSQL;
 75 | my $prompt;
 76 | if ($ENV{PERL_MM_USE_DEFAULT} or $ENV{AUTOMATED_TESTING}) {
 77 |     require App::Info::Handler::Print;
 78 |     $prompt = App::Info::Handler::Print->new;
 79 | }
 80 | else {
 81 |     require App::Info::Handler::Prompt;
 82 |     $prompt = App::Info::Handler::Prompt->new;
 83 | }
 84 | 
 85 | my $pg = App::Info::RDBMS::PostgreSQL->new(on_unknown => $prompt);
 86 | my ($major_ver, $minor_ver, $patch, $conf, $bindir) = map {$pg->$_}
 87 |     qw/major_version minor_version patch_version configure bin_dir/;
 88 | my $initdb = '';
 89 | if (defined $bindir and -d $bindir) {
 90 |     my $testinitdb = "$bindir${sep}initdb";
 91 |     if (-e $testinitdb) {
 92 |         $initdb = $testinitdb;
 93 |     }
 94 | }
 95 | my $serverversion = 0;
 96 | my $defaultport = 0;
 97 | 
 98 | if (defined $major_ver) {
 99 |     $serverversion = sprintf '%d%.02d%.02d', $major_ver, $minor_ver, $patch;
100 |     $defaultport = $conf =~ /with-pgport=([0-9]+)/ ? $1 : 5432;
101 | }
102 | 
103 | # We set POSTGRES_INCLUDE and POSTGRES_LIB from the first found of:
104 | # 1. environment variable
105 | # 2. App::Info::RDBMS::PostgreSQL information
106 | # 3. subdirectory of $ENV{POSTGRES_HOME}
107 | 
108 | $POSTGRES_INCLUDE = $ENV{POSTGRES_INCLUDE} || $pg->inc_dir;
109 | 
110 | if (! defined $POSTGRES_INCLUDE) {
111 | 	if (! defined $ENV{POSTGRES_HOME}) {
112 | 		warn "No POSTGRES_HOME defined, cannot find automatically\n";
113 | 		exit 0;
114 | 	}
115 | 	$POSTGRES_INCLUDE = "$ENV{POSTGRES_HOME}/include";
116 | }
117 | 
118 | $POSTGRES_LIB = $ENV{POSTGRES_LIB} || $pg->lib_dir || "$ENV{POSTGRES_HOME}/lib";
119 | 
120 | my $os = $^O;
121 | print "PostgreSQL version: $serverversion (default port: $defaultport)\n";
122 | my $showhome = $ENV{POSTGRES_HOME} || '(not set)';
123 | print "POSTGRES_HOME: $showhome\n";
124 | my $showinc = $POSTGRES_INCLUDE || '(not set)';
125 | print "POSTGRES_INCLUDE: $showinc\n";
126 | my $showlib = $POSTGRES_LIB || '(not set)';
127 | print "POSTGRES_LIB: $showlib\n";
128 | print "OS: $os\n";
129 | 
130 | my $baddir = 0;
131 | sub does_path_exist {
132 |     my ($path_name, $path) = @_;
133 | 
134 |     return if ! defined $path or ! length $path or -d $path;
135 |     printf "The value of %s points to a non-existent directory: %s\n",
136 |         $path_name, $path;
137 |     $baddir++;
138 |     return;
139 | }
140 | 
141 | does_path_exist('POSTGRES_HOME', $ENV{POSTGRES_HOME});
142 | does_path_exist('POSTGRES_INCLUDE',  $POSTGRES_INCLUDE);
143 | 
144 | if ($baddir) {
145 |     print "Cannot build unless the directories exist, exiting.\n";
146 |     exit 0;
147 | }
148 | 
149 | if ($serverversion < 11) {
150 |     print "Could not determine the PostgreSQL library version.\n".
151 |     "Please ensure that a valid path is given to the 'pg_config' command,\n".
152 |     "either manually or by setting the environment variables\n".
153 |     "POSTGRES_DATA, POSTGRES_INCLUDE, and POSTGRES_LIB\n";
154 |     exit 0;
155 | }
156 | 
157 | if ($os =~ /Win32/) {
158 |     for ($POSTGRES_INCLUDE, $POSTGRES_LIB) {
159 |         $_ = qq{"$_"} if index $_,'"';
160 |     }
161 | }
162 | 
163 | ## Warn about older versions
164 | if ($serverversion < 80000) {
165 |     print "\n****************\n";
166 |     print "WARNING! DBD::Pg no longer supports versions less than 8.0.\n";
167 |     print "You must upgrade PostgreSQL to a newer version.\n";
168 |     print "****************\n\n";
169 |     exit 1;
170 | }
171 | 
172 | my $dbi_arch_dir;
173 | {
174 |     eval {
175 |         require DBI::DBD;
176 |     };
177 |     if ($@) {
178 |         print "Could not load DBI::DBD - is the DBI module installed?\n";
179 |         exit 0;
180 |     }
181 |     local *STDOUT; ## Prevent duplicate debug info as WriteMakefile also calls this
182 |     $dbi_arch_dir = DBI::DBD::dbd_dbi_arch_dir();
183 | }
184 | 
185 | my $defines = " -DPGLIBVERSION=$serverversion -DPGDEFPORT=$defaultport";
186 | if ($Config{ivsize} >= 8 && $serverversion >= 90300) {
187 |     $defines .= ' -DHAS64BITLO';
188 | }
189 | my $comp_opts = $Config{q{ccflags}} . $defines;
190 | 
191 | if ($ENV{DBDPG_GCCDEBUG}) {
192 |     warn "Enabling many compiler options\n";
193 |     $comp_opts .= ' -Wchar-subscripts -Wcomment';
194 |     $comp_opts .= ' -Wformat=2'; ## does -Wformat,-Wformat-y2k,-Wformat-nonliteral,-Wformat-security
195 |     $comp_opts .= ' -Wnonnull';
196 |     $comp_opts .= ' -Wuninitialized -Winit-self'; ## latter requires the former
197 |     $comp_opts .= ' -Wimplicit'; ## does -Wimplicit-int and -Wimplicit-function-declaration
198 |     $comp_opts .= ' -Wmain -Wmissing-braces -Wparentheses -Wsequence-point -Wreturn-type -Wswitch -Wswitch-enum -Wtrigraphs';
199 |     $comp_opts .= ' -Wunused'; ## contains -Wunused- function,label,parameter,variable,value
200 |     $comp_opts .= ' -Wunknown-pragmas -Wstrict-aliasing';
201 |     $comp_opts .= ' -Wall'; ## all of above, but we enumerate anyway
202 |     $comp_opts .= ' -Wextra -Wendif-labels -Wpointer-arith';
203 |     $comp_opts .= ' -Wbad-function-cast -Wcast-qual -Wcast-align -Wsign-compare -Waggregate-return';
204 |     $comp_opts .= ' -Wmissing-prototypes -Wmissing-declarations -Wmissing-format-attribute -Wpacked -Winline -Winvalid-pch';
205 |     $comp_opts .= ' -Wdisabled-optimization';
206 |     $comp_opts .= ' -Wnested-externs';
207 |     $comp_opts .= ' -Wstrict-prototypes'; ## Still hits a couple places in types.h
208 |     $comp_opts .= ' -Wswitch-default';
209 |     $comp_opts .= ' -Wsystem-headers';
210 |     $comp_opts .= ' -Wmissing-noreturn';
211 |     $comp_opts .= ' -Wfloat-equal'; ## Does not like SvTRUE() calls
212 | }
213 | 
214 | my %opts =
215 |     (
216 |      NAME           => 'DBD::Pg',
217 |      VERSION_FROM   => 'Pg.pm',
218 |      INC            => "-I$POSTGRES_INCLUDE -I$dbi_arch_dir",
219 |      OBJECT         => 'Pg$(OBJ_EXT) dbdimp$(OBJ_EXT) quote$(OBJ_EXT) types$(OBJ_EXT)',
220 |      LIBS           => ["-L$POSTGRES_LIB -lpq -lm"],
221 |      AUTHOR         => 'Greg Sabino Mullane',
222 |      ABSTRACT       => 'PostgreSQL database driver for the DBI module',
223 |      PREREQ_PM      => {
224 |                         'ExtUtils::MakeMaker' => '6.58',
225 |                         'DBI'                 => '1.614',
226 |                         'File::Temp'          => '0',
227 |                         'Test::More'          => '0.88',
228 |                         'Time::HiRes'         => '0',
229 |                         'version'             => '0',
230 |                        },
231 |      CCFLAGS        => $comp_opts,
232 |      PERL_MALLOC_OK => 1,
233 |      NEEDS_LINKING  => 1,
234 |      NO_META        => 1,
235 |      NORECURS       => 1,
236 |      PM             => {
237 |                         'Pg.pm' => '$(INST_LIBDIR)/Pg.pm',
238 |                         'lib/Bundle/DBD/Pg.pm' => '$(INST_LIB)/Bundle/DBD/Pg.pm',
239 |                        },
240 |      clean          => { FILES => 'trace Pg.xsi README.testdatabase cover_db *.tst' },
241 |      realclean      => { FILES => 'dbdpg_test_database/' },
242 | );
243 | 
244 | if ($os eq 'hpux') {
245 |     my $osvers = $Config{osvers};
246 |     if ($osvers < 10) {
247 |         print "Warning: Forced to build static not dynamic on $os $osvers.\a\n";
248 |         $opts{LINKTYPE} = 'static';
249 |     }
250 | }
251 | elsif ($os =~ /Win32/) {
252 |     my $msdir = $POSTGRES_LIB;
253 |     $msdir =~ s{"$}{/ms"};
254 |     $opts{LIBS}[0] .= " -L$msdir -lsecur32";
255 | }
256 | 
257 | if ($Config{dlsrc} =~ /dl_none/) {
258 |     $opts{LINKTYPE} = 'static';
259 | }
260 | 
261 | {
262 |     package MY; ## no critic
263 |     sub MY::test { ## no critic
264 |         my $string = shift->SUPER::test(@_);
265 |         $string =~ s/(PERL_DL_NONLAZY=1)/PGINITDB="$initdb" $1/g;
266 |         return "HARNESS_OPTIONS=j1\n$string";
267 |     }
268 | }
269 | 
270 | sub constants {
271 |     my $self = shift;
272 | 
273 |     my $old_constants = $self->SUPER::constants();
274 |     my $new_constants = '';
275 |     for my $line (split /\n/ => $old_constants) {
276 |         if ($line =~ /^INC = .*strawberry.*/ ) {
277 |             print qq(Strawberry Perl found; adjusting the INC variable;\n);
278 |             $line .= ' -I ' . DBI::DBD::dbd_dbi_arch_dir();
279 |             print qq(INC is now $line\n);
280 |         }
281 |         $new_constants .= "$line\n";
282 |     }
283 |     return $new_constants;
284 | }
285 | 
286 | sub MY::postamble { ## no critic ProhibitQualifiedSubDeclarations
287 |     no strict 'subs'; ## no critic ProhibitNoStrict
288 |     my $string = DBI::DBD->dbd_postamble();
289 |     use strict 'subs';
290 |     ## Evil, evil stuff - but we really want to suppress the "duplicate function" message!
291 |     $string =~ s/dependancy/dependency/g; ## why not, while we are here
292 |     $string =~ s{(BASEEXT\)/g)}{$1; s/^do\\\(/dontdo\\\(/};
293 | 
294 |         my $tags = <<'MAKE_FRAG';
295 | .PHONY: tags
296 | 
297 | tags:
298 | 	ctags -f tags --recurse --totals \
299 | 		--exclude=blib \
300 | 		--exclude=.git \
301 | 		--exclude='*~' \
302 | 		--languages=Perl,C --langmap=c:+.h,Perl:+.t \
303 | 
304 | MAKE_FRAG
305 |         $string = "$string\n$tags\n";
306 | 
307 | 	$string .= <<'MAKE_SPLINT';
308 | 
309 | ## This must be version 3.2.1 or better: earlier versions have many 
310 | ## problems parsing the DBI header files
311 | SPLINT = splint
312 | 
313 | ## Temp directory, for use with +keep
314 | SPLINT_TMP = $(TMP)/splint_dbdpg
315 | 
316 | SPLINTFLAGS =            \
317 |   -message-stream-stdout \
318 |   -linelen 90            \
319 |   -boolops               \
320 |   -tmpdir $(SPLINT_TMP)  \
321 |   +posixstrictlib        \
322 |   +ignoresigns           \
323 |   +showdeephistory       \
324 |   -predboolint           \
325 |   -nullpass              \
326 |   +charint               \
327 |   +boolint               \
328 |   +allglobals            \
329 | 
330 | SPLINTFLAGS_TEST = 
331 | 
332 | SDEFINES = 
333 | 
334 | splint: $(H_FILES) $(C_FILES)
335 | 	$(MKPATH) $(SPLINT_TMP)
336 | 	$(SPLINT) $(SPLINTFLAGS) $(SPLINTFLAGS_TEST) $(SDEFINES) -I$(PERL_INC) $(INC) $(C_FILES)
337 | 
338 | MAKE_SPLINT
339 | 
340 |     $string =~ s/SDEFINES = /SDEFINES =$defines/;
341 | 
342 |     return $string;
343 | }
344 | 
345 | my $output = WriteMakefile(%opts);
346 | 
347 | if (!exists $output->{EXTRALIBS} or
348 | 
349 |     ($output->{EXTRALIBS} !~ /\-lpq/ and $output->{EXTRALIBS} !~ /libpq/)) {
350 | 
351 |     my $makefile = exists $output->{MAKEFILE}
352 |         ? "\nRemoving ($output->{MAKEFILE})\n" : '';
353 | 
354 |     warn qq{
355 | ==========================================================
356 | 
357 | WARNING! No libpq libraries were detected!
358 | 
359 | You need to install the postgresql-libs package for your system,
360 | 
361 | or set the POSTGRES_LIB environment variable to the correct place.
362 | $makefile
363 | ===========================================================
364 | 
365 | };
366 | 
367 |     ## Do not let make proceed
368 |     unlink $output->{MAKEFILE} if $makefile;
369 | 
370 |     exit 1;
371 | }
372 | 
373 | exit 0;
374 | 
375 | # end of Makefile.PL
376 | 


--------------------------------------------------------------------------------