diff options
Diffstat (limited to 'install')
77 files changed, 13285 insertions, 0 deletions
diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/Changes b/install/5.005/DBD-Pg-1.22-fixvercmp/Changes new file mode 100644 index 0000000..c345628 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/Changes @@ -0,0 +1,352 @@ +1.22 Wed Mar 26 22:33:44 EST 2003 + - Win32 compile fix for snprintf [Joe Spears] + - Fix memory allocation problem in bytea escaping [Barrie Slaymaker] + - Add utf8 support [Dominic Mitchell <dom@semantico.com>] + - Transform Perl arrays into PostgreSQL arrays [Alexey Slynko] + - Fix for foreign_key_info() [Keith Keller] + - Fix PG_TEXT parameter binding + - Doc cleanups [turnstep] + - Fix warning from func($table, 'table_attributes') [turnstep] + - Added suppport for schemas [turnstep] + - Fix binary to a bytea field conversion [Chris Dunlop <chris@onthe.net.au>] +1.21 Sun Jan 12 21:00:44 EST 2003 + - System tables no longer returned by tables(). [Dave Rolsky] + - Fix table_attributes to handle removal of pg_relcheck in 7.3, + from Ian Barwick <barwick@gmx.net> + - Properly reset transaction status after failed transaction when + autocommit is off. Properly report transaction failure message. + Kai <kai@xs4all.nl> + - New pg_bool_tf database handle that when set to true booleans are + returned as 't'/'f' rather than 1/0. + +1.20 Wed Nov 27 16:19:26 2002 + - Maintenance transferred to GBorg, + http://gborg.postgresql.org/project/dbdpg/projdisplay.php. Incremented + version number to reflect new management. [Bruce Momjian] + - README cleaned up. [Bruce Momjian] + - Added t/15funct.t, a series of tests that determine if the meta data + is working. [Thomas Lowery] + - Added implementations of column_info() and table_info(), and + primary_key_info(). [Thomas Lowery] + - The POD formatting was cleaned up. [David Wheeler] + - The preparser was updated to better handle escaped characters. [Rudy + Lippan] + - Removed redundant use of strlen() in pg_error() (Jason E. Stewart). + - Test suite cleaned up, converted to use Test::More, and updated to use + standard DBI environment variables for connecting to a test database. + [Jason E. Stewart] + - Added eg/lotest.pl as a demonstration of using large objects in buffers + rather than files. Contributed by Garth Webb. + - Added LISTEN/NOTIFY functionality. Congributed by Alex Pilosov. + - Added constants for common PostgreSQL data types, plus simple tests to + make sure that they work. These are exportable via "use DBD::Pg + qw(:pg_types);". [David Wheeler] + - Deprecatated the undocumented (and invalid) use of SQL_BINARY in + bind_param() and documented the correct approach: "bind_param($num, + $val { pg_type => PG_BYTEA });". Use of SQL_BINARY in bind_param() will + now issue a warning if $h->{Warn} is true. [David Wheeler] + - Removed invalid (and broken) support for SQL_BINARY in quote(). [David + Wheeler] + - Added App::Info::RDBMS::PostgreSQL to the distribution (but it won't + be installed) to help Makefile.PL find the PostgreSQL include and + library files. [David Wheeler] + - Fixed compile-time warnings. [David Wheeler and Jason E. Stewart] + +2002-04-27 Jeffrey W. Baker <jwbaker@acm.org> + + - dbdimp.c: Add default at end of switch statement for pg_type attrib. + - t/13pgtype.t: test for above. + +2002-04-09 Jeffrey W. Baker <jwbaker@acm.org> + + - Pg.pm, dbdimp.c: Applied patch from + Thomas A. Lowery <tlowery@stlowery.net> concerning metadata + in table_info and so forth. + +2002-03-06 Jeffrey W. Baker <jwbaker@acm.org> + - Pg.pm (quote): Applied patch from David Wheeler <david@wheeler.net> + to simplfiy and speed up quoting. + - t/11quoting.t: Tests for above patch. + - t/12placeholders.t: Tests for placeholder parsing in quoted strings. + +2002-03-06 Jeffrey W. Baker + - Version 1.10 uploaded to CPAN. + +1.01 Jun 27, 2001 + - fixed core dump when trying to use a BYTEA value with + a byte outside 0..127 Alex Pilosov <alex@pilosoft.com> + +1.00 May 27, 2001 + - Fetching all records now resets Active flag as it should. + +0.99 May 24, 2001 + - fix the segmentation fault in pg_error. + +0.98 Apr 25, 2001 + - bug-fix for core-dump after any failed function call. + - applied patch from Alex Pilosov <alex@pilosoft.com> + which adds support for the datatype bytea + +0.97 Apr 20, 2001 + - fix bug in connect method, which erroneously set the userid + and the password to the environment variables DBI_USER and + DBI_PASS. + - applied patch from Jan-Pieter Cornet <john@pc.xs4all.nl>, + which removed the special handling of a backslash when + used for octal presentation. Now a backslash always will + be escaped. + +0.96 Apr 09, 2001 + - remove memory-leak in ping function, bug-fix + from Doug Perham <dperham@wgate.com> + - correct the recognition of primary keys in + table_attributes(). Patch from Brian Powell + <brian@nicklebys.com>. + - applied patch from David D. Kilzer <ddkilzer@lubricants-oil.com> + which fixes a segmentation fault in DBD::pg::blob_read() when + reading LOBs that required perl to reallocate space for the + variable holding the scalar value + - updated test.pl to create a test blob larger than 256 bytes + (now 128 Kbytes) + - apply patch from Tom Lane, which fixes a seg-fault when + inserting large amounts of text. + - apply patch from Peter Haworth pmh@edison.ioppublishing.com, + which removes the newlines from the error messages and which + quotes date placeholders. + +0.95 Jul 10, 2000 + - add Win32 port from Bob Kline <bkline@rksystems.com>. + +0.94 Jul 07, 2000 + - applied patch from Rudy Lippan <almighty@randomc.com> + which fixes a memory-leak with failed connections. + - applied patch from Hein Roehrig <hein@acm.org> + which fixes a bug with escaping a backslash except for + octal presentation + - applied patch from Francis J. Lacoste <francis.lacoste@iNsu.COM + which fixes a segmentation fault when all binded parameters are NULL + - adapt test.pl to avoid warnings with postgresql-7.0 + - added support for 'COPY FROM STDIN' and 'COPY TO STDOUT' + - added patch from Mark Stosberg <mark@summersault.com> + to enhance the table_attributes subroutine + +0.93 Sep 29, 1999 + - it is required now to set the environment variables POSTGRES_INCLUDE + and POSTGRES_LIB for compiling the module. + - add Win32 port from Bob Kline <bkline@rksystems.com>. + - support for all large-object functions via the func + interface. + - fixed bug with placeholders and casts spotted by + mschout@gkg.net + - replaced the method attributes by the method table_attributes, + from Scott Williams <scott@james.com>. + - fix type definitions for type_info_all(). + bug spotted by "carlos" <emarcet@intramed.net.ar>. + - now the Pg-specific quote() method also evaluates the + data-type paramater. + +0.92 Jun 16, 1999 + - proposal from Philip Warner <pjw@rhyme.com.au>: + increase BUFSIZE from 1024 to 32768 in order to improve + I/O performance. + - bug-fix in Makefile.PL for $POSTGRES_HOME not defined + spotted by mdalphin@amgen.com (Mark Dalphin) + - bug-fix for data-type datetime in type_info_all + spotted by Alan Grover <awgrover@iconnect-inc.com> + - bug-fix for escaped 's spotted by Hankin <hankin@consultco.com> + - removed 'large objects' related tests from test.pl + +0.91 Feb 14, 1999 + - removed restriction for commercial use in copyright + - corrected DATA_TYPE in type_info_all() + +0.90 Jan 15, 1998 + - discard parameter authtype from connect string + - remove work-around for bug in the large object + interface of postgresql + +0.89 Nov 05, 1998 + - bug-fix from Jan Iven <j.iven@rz.uni-sb.de>: + fix problem with quoting Null in bind variables. + +0.88 Oct 10, 1998 + - fixed blob_read + - suppressed warning when testing DBI::errstr + +0.87 Sep 05, 1998 + - Pg.xs adapted to Driver.xst from DBI-1.0 + - major rewrite of module documentation + - major rewrite of the test script + - use built-in DBI method for $dbh->do + - add macro dHTR in order to avoid compile errors + with threaded perl5.005 + - renamed attribute AutoEscape to pg_auto_escape + - renamed attribute SIZE to pg_size + - new attribute pg_type + - added support for DBI->data_sources($driver) + - added support for $dbh->table_info + - blob_read documented and added to test.pl + - added support for attr parameter in bind_param() + +0.86 Aug 21, 1998 + - added /usr/lib/ to search path for libpq. + - added ChopBlanks, patch from + Victor Krasinsky <victor@rdovira.lviv.ua> + - changed test.pl to test multiple database handles + +0.85 July 19, 1998 + - non-printable characters in parameters will not be + converted to '.'. They are passed unchanged to the + database. + +0.84 July 18, 1998 + - bug-fix from Max Cohan <mcohan@adnc.net>: + check for \xxx presentation before escaping backslash + in parameters. + - introduce new database handle attribute AutoEscape, which + controls escaping of quotes and backslashes in parameters. + When set to on, all quotes except at the beginning and + at the end of a line will be escaped and all backslashes + except when used to indicate an octal presentation (\xxx) + will be escaped. Default of AutoEscape is on. + +0.83 July 10, 1998 + - bug-fix from Max Cohan <mcohan@adnc.net>: + using traces together with undef in place-holders dumped + core. + +0.82 June 20, 1998 + - bug-fix from Matthew Lenz <matthew@nocturnal.org>: + corrected include path in Makefile.PL . + - added 'use strict;' to test.pl + +0.81 June 13, 1998 + - bug-fix from Rolf Grossmann <grossman@securitas.net>: + undefined parameters in an execute statement will be + translated from 'undef' to 'NULL'. Also every parameter + for bind_param() will be quoted by default (escape quote + and backslash). Appropriate tests have been added to test.pl. + - change ping method to use libpq-interface. + +0.80 June 07, 1998 + - adapted to postgresql-6.4: + the backend protocol has changed, which needs an adapted + ping method. A ping-test has been added to the test-script. + Also some type identifiers have changed. + +0.73 June 03, 1998 + - changed include directives in Makefile.PL from + archlib to installarchlib and from sitearch to + installsitearch (Tony.Curtis@vcpc.univie.ac.at). + - applied patch from Junio Hamano <junio@twinsun.com> + quote method also doubles backslash. + +0.72 April 20, 1998 + - applied patch from Michael J Schout <mschout@gkg.net> + which fixed the bug with queries containing the cast + operator. + - applied patch from "Irving Reid" <irving@tor.securecomputing.com> + which fixed a memory leak. + +0.71 April 04, 1998 + - applied patch from "Irving Reid" + <irving@tor.securecomputing.com> which fixed the + the problem with the InactiveDestroy message. + +0.70 March 28, 1998 + - linking again with the shared version of libpq + due to problems on several operating systems. + +0.69 March 6, 1998 + - expanded the search path for include files + - module is now linked with static libpq.a + +0.68 March 3, 1998 + - return to UNIX domain sockets in test-scripts + +0.67 February 21, 1998 + - remove part of Driver.xst due to compile + error on some systems. + +0.66 February 19, 1998 + - remove defines in Pg.h so that + it compiles also with postgresql-6.2.1 + - changed ping method: set RaiseError=0 + +0.65 February 14, 1998 + - adapted to changes in DBI-0.91, so that the + default setting for AutoCommit and PrintError is + again conformant to the DBI specs. + +0.64 February 01, 1998 + - changed syntax of data_source (ODBC-conformant): + 'dbi:Pg:dbname=dbname;host=host;port=port' + !!! PLEASE ADAPT YOUR SCRIPTS !!! + - implemented place-holders + - implemented ping-method + - added support for $dbh->{RaiseError} and $dbh->{PrintError}, + note: DBI-default for PrintError is on ! + - allow commit and rollback only if AutoCommit = off + - added documentation for $dbh->tables; + - new method to get meta-information about a given table: + $dbh->DBD::Pg::db::attributes($table); + - host-parameter in test.pl is set explicitly to localhost + +0.63 October 05, 1997 + - adapted to PostgreSQL-6.2: + o $sth->rows as well as $sth->execute + and $sth->do return the number of + affected rows even for non-Select + statements. + o support for password authorization added, + please check the man-page for pg_passwd. + - the data_source parameter of the connect + method accepts two additional parameters + which are treated as host and port: + DBI->connect("dbi:Pg:dbname:host:port", "uid", "pwd") + - support for AutoCommit, please read the + module documentation for impacts on your + scripts ! + - more perl-ish handling of data type bool, + please read the module documentation for + impacts on your scripts ! + +0.62 August 26, 1997 + - added blobs/README + +0.61 August 23, 1997 + - adapted to DBI-0.89/Driver.xst + - added support for blob_read + +0.52 August 15, 1997 + - added support for literal $sth->{'TYPE'}, + pg_type.pl / pg_type.pm. + +0.51 August 12, 1997 + - changed attributes to be DBI conformant: + o OID_STATUS to pg_oid_status + o CMD_STATUS to pg_cmd_status + +0.5 August 05, 1997 + - support for user authentication + - support for bind_columns + - added $dbh->tables + +0.4 Jun 24, 1997 + - adapted to DBI-0.84: + o new syntax for DBI->connect ! + o execute returns 0E0 -> n for SELECT stmt + -1 for non SELECT stmt + -2 on error + - new attribute $sth->{'OID_STATUS'} + - new attribute $sth->{'CMD_STATUS'} + +0.3 Apr 24, 1997 + - bug fix release, ( still alpha ! ) + +0.2 Mar 13, 1997 + - complete rewrite, ( still alpha ! ) + +0.1 Feb 15, 1997 + - creation, ( totally pre-alpha ! ) + diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/MANIFEST b/install/5.005/DBD-Pg-1.22-fixvercmp/MANIFEST new file mode 100644 index 0000000..7d1b700 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/MANIFEST @@ -0,0 +1,38 @@ +Changes +MANIFEST +Makefile.PL +Pg.h +Pg.pm +Pg.xs +README +README.win32 +dbd-pg.pod +dbdimp.c +dbdimp.h +eg/ApacheDBI.pl +eg/lotest.pl +eg/notify_test.patch +t/00basic.t +t/01connect.t +t/01constants.t +t/01setup.t +t/02prepare.t +t/03bind.t +t/04execute.t +t/05fetch.t +t/06disconnect.t +t/07reuse.t +t/08txn.t +t/09autocommit.t +t/11quoting.t +t/12placeholders.t +t/13pgtype.t +t/15funct.t +t/99cleanup.t +t/lib/App/Info.pm +t/lib/App/Info/Handler.pm +t/lib/App/Info/Handler/Prompt.pm +t/lib/App/Info/RDBMS.pm +t/lib/App/Info/RDBMS/PostgreSQL.pm +t/lib/App/Info/Request.pm +t/lib/App/Info/Util.pm diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/Makefile.PL b/install/5.005/DBD-Pg-1.22-fixvercmp/Makefile.PL new file mode 100644 index 0000000..0633280 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/Makefile.PL @@ -0,0 +1,83 @@ + +# $Id: Makefile.PL,v 1.1 2004-04-29 09:21:28 ivan Exp $ + +use ExtUtils::MakeMaker; +use Config; +use strict; + +use DBI 1.00; +use DBI::DBD; + +my $lib; +BEGIN { + my %sep = (MacOS => ':', + MSWin32 => '\\', + os2 => '\\', + VMS => '\\', + NetWare => '\\', + dos => '\\'); + my $s = $sep{$^O} || '/'; + $lib = join $s, 't', 'lib'; +} + +use lib $lib; +print "Configuring Pg\n"; +print "Remember to actually read the README file !\n"; + +my $POSTGRES_INCLUDE; +my $POSTGRES_LIB; + +if ((!$ENV{POSTGRES_INCLUDE} or !$ENV{POSTGRES_LIB}) and !$ENV{POSTGRES_HOME}) { + # Use App::Info to get the data we need. + require App::Info::RDBMS::PostgreSQL; + require App::Info::Handler::Prompt; + my $p = App::Info::Handler::Prompt->new; + my $pg = App::Info::RDBMS::PostgreSQL->new(on_unknown => $p); + $POSTGRES_INCLUDE = $pg->inc_dir; + $POSTGRES_LIB = $pg->lib_dir; +} elsif ((!$ENV{POSTGRES_INCLUDE} or !$ENV{POSTGRES_LIB}) and $ENV{POSTGRES_HOME}) { + $POSTGRES_INCLUDE = "$ENV{POSTGRES_HOME}/include"; + $POSTGRES_LIB = "$ENV{POSTGRES_HOME}/lib"; +} else { + $POSTGRES_INCLUDE = "$ENV{POSTGRES_INCLUDE}"; + $POSTGRES_LIB = "$ENV{POSTGRES_LIB}"; +} + +my $os = $^O; +print "OS: $os\n"; + +my $dbi_arch_dir; +if ($os eq 'MSWin32') { + $dbi_arch_dir = "\$(INSTALLSITEARCH)/auto/DBI"; +} else { + $dbi_arch_dir = dbd_dbi_arch_dir(); +} + +my %opts = ( + NAME => 'DBD::Pg', + VERSION_FROM => 'Pg.pm', + INC => "-I$POSTGRES_INCLUDE -I$dbi_arch_dir", + OBJECT => "Pg\$(OBJ_EXT) dbdimp\$(OBJ_EXT)", + LIBS => ["-L$POSTGRES_LIB -lpq"], + AUTHOR => 'http://gborg.postgresql.org/project/dbdpg/projdisplay.php', + ABSTRACT => 'PostgreSQL database driver for the DBI module', + PREREQ_PM => { 'Test::Simple' => 0.17 }, # Need Test::More +); + +if ($os eq 'hpux') { + my $osvers = $Config{osvers}; + if ($osvers < 10) { + print "Warning: Forced to build static not dynamic on $os $osvers.\a\n"; + $opts{LINKTYPE} = 'static'; + } +} + +if ($Config{dlsrc} =~ /dl_none/) { + $opts{LINKTYPE} = 'static'; +} + +WriteMakefile(%opts); + +exit(0); + +# end of Makefile.PL diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/Pg.h b/install/5.005/DBD-Pg-1.22-fixvercmp/Pg.h new file mode 100644 index 0000000..b77a9f8 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/Pg.h @@ -0,0 +1,46 @@ +/* + $Id: Pg.h,v 1.1 2004-04-29 09:21:28 ivan Exp $ + + Copyright (c) 1997,1998,1999,2000 Edmund Mergl + Portions Copyright (c) 1994,1995,1996,1997 Tim Bunce + + You may distribute under the terms of either the GNU General Public + License or the Artistic License, as specified in the Perl README file. + +*/ + + +#ifdef WIN32 +static int errno; +#endif + +#include "libpq-fe.h" + +#ifdef NEVER +#include<sys/stat.h> +#include "libpq/libpq-fs.h" +#endif +#ifndef INV_READ +#define INV_READ 0x00040000 +#endif +#ifndef INV_WRITE +#define INV_WRITE 0x00020000 +#endif + +#ifdef BUFSIZ +#undef BUFSIZ +#endif +/* this should improve I/O performance for large objects */ +#define BUFSIZ 32768 + + +#define NEED_DBIXS_VERSION 93 + +#include <DBIXS.h> /* installed by the DBI module */ + +#include "dbdimp.h" /* read in our implementation details */ + +#include <dbd_xsh.h> /* installed by the DBI module */ + + +/* end of Pg.h */ diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/Pg.pm b/install/5.005/DBD-Pg-1.22-fixvercmp/Pg.pm new file mode 100644 index 0000000..284e563 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/Pg.pm @@ -0,0 +1,1913 @@ + +# $Id: Pg.pm,v 1.1 2004-04-29 09:21:28 ivan Exp $ +# +# Copyright (c) 1997,1998,1999,2000 Edmund Mergl +# Copyright (c) 2002 Jeffrey W. Baker +# Portions Copyright (c) 1994,1995,1996,1997 Tim Bunce +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + + +require 5.004; + +$DBD::Pg::VERSION = '1.22'; + +{ + package DBD::Pg; + + use DBI (); + use DynaLoader (); + use Exporter (); + @ISA = qw(DynaLoader Exporter); + + %EXPORT_TAGS = ( + pg_types => [ qw( + PG_BOOL PG_BYTEA PG_CHAR PG_INT8 PG_INT2 PG_INT4 PG_TEXT PG_OID + PG_FLOAT4 PG_FLOAT8 PG_ABSTIME PG_RELTIME PG_TINTERVAL PG_BPCHAR + PG_VARCHAR PG_DATE PG_TIME PG_DATETIME PG_TIMESPAN PG_TIMESTAMP + )]); + + Exporter::export_ok_tags('pg_types'); + + require_version DBI 1.00; + + bootstrap DBD::Pg $VERSION; + + $err = 0; # holds error code for DBI::err + $errstr = ""; # holds error string for DBI::errstr + $drh = undef; # holds driver handle once initialized + + sub driver{ + return $drh if $drh; + my($class, $attr) = @_; + + $class .= "::dr"; + + # not a 'my' since we use it above to prevent multiple drivers + + $drh = DBI::_new_drh($class, { + 'Name' => 'Pg', + 'Version' => $VERSION, + 'Err' => \$DBD::Pg::err, + 'Errstr' => \$DBD::Pg::errstr, + 'Attribution' => 'PostgreSQL DBD by Edmund Mergl', + }); + + $drh; + } + + ## Used by both the dr and db packages + sub pg_server_version { + my $dbh = shift; + return $dbh->{pg_server_version} if defined $dbh->{pg_server_version}; + my ($version) = $dbh->selectrow_array("SELECT version();"); + return 0 unless $version =~ /^PostgreSQL ([\d\.]+)/; + $dbh{pg_server_version} = $1; + return $dbh{pg_server_version}; + } + + sub pg_use_catalog { + my $dbh = shift; + my $version = DBD::Pg::pg_server_version($dbh); + $version =~ /^(\d+\.\d+)/; + return $1 < 7.3 ? "" : "pg_catalog."; + } + + 1; +} + + +{ package DBD::Pg::dr; # ====== DRIVER ====== + use strict; + + sub data_sources { + my $drh = shift; + my $dbh = DBD::Pg::dr::connect($drh, 'dbname=template1') or return undef; + $dbh->{AutoCommit} = 1; + my $CATALOG = DBD::Pg::pg_use_catalog($dbh); + my $sth = $dbh->prepare("SELECT datname FROM ${CATALOG}pg_database ORDER BY datname"); + $sth->execute or return undef; + my (@sources, @datname); + while (@datname = $sth->fetchrow_array) { + push @sources, "dbi:Pg:dbname=$datname[0]"; + } + $sth->finish; + $dbh->disconnect; + return @sources; + } + + + sub connect { + my($drh, $dbname, $user, $auth)= @_; + + # create a 'blank' dbh + + my $Name = $dbname; + $Name =~ s/^.*dbname\s*=\s*//; + $Name =~ s/\s*;.*$//; + + $user = "" unless defined($user); + $auth = "" unless defined($auth); + + $user = $ENV{DBI_USER} if $user eq ""; + $auth = $ENV{DBI_PASS} if $auth eq ""; + + $user = "" unless defined($user); + $auth = "" unless defined($auth); + + my($dbh) = DBI::_new_dbh($drh, { + 'Name' => $Name, + 'User' => $user, 'CURRENT_USER' => $user, + }); + + # Connect to the database.. + DBD::Pg::db::_login($dbh, $dbname, $user, $auth) or return undef; + + $dbh; + } + +} + + +{ package DBD::Pg::db; # ====== DATABASE ====== + use strict; + use Carp (); + + sub prepare { + my($dbh, $statement, @attribs)= @_; + + # create a 'blank' sth + + my $sth = DBI::_new_sth($dbh, { + 'Statement' => $statement, + }); + + DBD::Pg::st::_prepare($sth, $statement, @attribs) or return undef; + + $sth; + } + + + sub ping { + my($dbh) = @_; + + local $SIG{__WARN__} = sub { } if $dbh->{PrintError}; + local $dbh->{RaiseError} = 0 if $dbh->{RaiseError}; + my $ret = DBD::Pg::db::_ping($dbh); + + return $ret; + } + + # Column expected in statement handle returned. + # table_cat, table_schem, table_name, column_name, data_type, type_name, + # column_size, buffer_length, DECIMAL_DIGITS, NUM_PREC_RADIX, NULLABLE, + # REMARKS, COLUMN_DEF, SQL_DATA_TYPE, SQL_DATETIME_SUB, CHAR_OCTET_LENGTH, + # ORDINAL_POSITION, IS_NULLABLE + # The result set is ordered by TABLE_CAT, TABLE_SCHEM, + # TABLE_NAME and ORDINAL_POSITION. + + sub column_info { + my ($dbh) = shift; + my @attrs = @_; + # my ($dbh, $catalog, $schema, $table, $column) = @_; + my $CATALOG = DBD::Pg::pg_use_catalog($dbh); + + my @wh = (); + my @flds = qw/catname n.nspname c.relname a.attname/; + + for my $idx (0 .. $#attrs) { + next if ($flds[$idx] eq 'catname'); # Skip catalog + if(defined $attrs[$idx] and length $attrs[$idx]) { + # Insure that the value is enclosed in single quotes. + $attrs[$idx] =~ s/^'?(\w+)'?$/'$1'/; + if ($attrs[$idx] =~ m/[,%]/) { + # contains a meta character. + push( @wh, q{( } . join ( " OR " + , map { m/\%/ + ? qq{$flds[$idx] ILIKE $_ } + : qq{$flds[$idx] = $_ } + } (split /,/, $attrs[$idx]) ) + . q{ )} + ); + } + else { + push( @wh, qq{$flds[$idx] = $attrs[$idx]} ); + } + } + } + + my $wh = ""; # (); + $wh = join( " AND ", '', @wh ) if (@wh); + my $version = DBD::Pg::pg_server_version($dbh); + $version =~ /^(\d+\.\d+)/; + $version = $1; + my $showschema = $version < 7.3 ? "NULL::text" : "n.nspname"; + my $schemajoin = $version < 7.3 ? "" : "LEFT JOIN pg_catalog.pg_namespace n ON (n.oid = c.relnamespace)"; + my $col_info_sql = qq{ + SELECT + NULL::text AS "TABLE_CAT" + , $showschema AS "TABLE_SCHEM" + , c.relname AS "TABLE_NAME" + , a.attname AS "COLUMN_NAME" + , t.typname AS "DATA_TYPE" + , NULL::text AS "TYPE_NAME" + , a.attlen AS "COLUMN_SIZE" + , NULL::text AS "BUFFER_LENGTH" + , NULL::text AS "DECIMAL_DIGITS" + , NULL::text AS "NUM_PREC_RADIX" + , a.attnotnull AS "NULLABLE" + , NULL::text AS "REMARKS" + , a.atthasdef AS "COLUMN_DEF" + , NULL::text AS "SQL_DATA_TYPE" + , NULL::text AS "SQL_DATETIME_SUB" + , NULL::text AS "CHAR_OCTET_LENGTH" + , a.attnum AS "ORDINAL_POSITION" + , a.attnotnull AS "IS_NULLABLE" + , a.atttypmod as atttypmod + , a.attnotnull as attnotnull + , a.atthasdef as atthasdef + , a.attnum as attnum + FROM + ${CATALOG}pg_attribute a + , ${CATALOG}pg_type t + , ${CATALOG}pg_class c + $schemajoin + WHERE + a.attrelid = c.oid + AND a.attnum >= 0 + AND t.oid = a.atttypid + AND c.relkind in ('r','v') + $wh + ORDER BY 2, 3, 4 + }; + + my $sth = $dbh->prepare( $col_info_sql ) or return undef; + $sth->execute(); + + return $sth; + } + + sub primary_key_info { + my $dbh = shift; + my ($catalog, $schema, $table) = @_; + my @attrs = @_; + my $CATALOG = DBD::Pg::pg_use_catalog($dbh); + + # TABLE_CAT:, TABLE_SCHEM:, TABLE_NAME:, COLUMN_NAME:, KEY_SEQ: + # , PK_NAME: + + my @wh = (); my @dat = (); # Used to hold data for the attributes. + + my $version = DBD::Pg::pg_server_version($dbh); + $version =~ /^(\d+\.\d+)/; + $version = $1; + + my @flds = qw/catname u.usename bc.relname/; + $flds[1] = 'n.nspname' unless ($version < 7.3); + + for my $idx (0 .. $#attrs) { + next if ($flds[$idx] eq 'catname'); # Skip catalog + if(defined $attrs[$idx] and length $attrs[$idx]) { + if ($attrs[$idx] =~ m/[,%_?]/) { + # contains a meta character. + push( @wh, q{( } . join ( " OR " + , map { push(@dat, $_); + m/[%_?]/ + ? qq{$flds[$idx] iLIKE ? } + : qq{$flds[$idx] = ? } + } (split /,/, $attrs[$idx]) ) + . q{ )} + ); + } + else { + push( @dat, $attrs[$idx] ); + push( @wh, qq{$flds[$idx] = ? } ); + } + } + } + + my $wh = ''; + $wh = join( " AND ", '', @wh ) if (@wh); + + # Base primary key selection query borrowed from phpPgAdmin. + my $showschema = $version < 7.3 ? "NULL::text" : "n.nspname"; + my $schemajoin = $version < 7.3 ? "" : "LEFT JOIN pg_catalog.pg_namespace n ON (n.oid = bc.relnamespace)"; + my $pri_key_sql = qq{ + SELECT + NULL::text AS "TABLE_CAT" + , $showschema AS "TABLE_SCHEM" + , bc.relname AS "TABLE_NAME" + , a.attname AS "COLUMN_NAME" + , a.attnum AS "KEY_SEQ" + , ic.relname AS "PK_NAME" + FROM + ${CATALOG}pg_index i + , ${CATALOG}pg_attribute a + , ${CATALOG}pg_class ic + , ${CATALOG}pg_class bc + $schemajoin + WHERE + i.indrelid = bc.oid + AND i.indexrelid = ic.oid + AND + ( + i.indkey[0] = a.attnum + OR + i.indkey[1] = a.attnum + OR + i.indkey[2] = a.attnum + OR + i.indkey[3] = a.attnum + OR + i.indkey[4] = a.attnum + OR + i.indkey[5] = a.attnum + OR + i.indkey[6] = a.attnum + OR + i.indkey[7] = a.attnum + OR + i.indkey[8] = a.attnum + OR + i.indkey[9] = a.attnum + OR + i.indkey[10] = a.attnum + OR + i.indkey[11] = a.attnum + OR + i.indkey[12] = a.attnum + ) + AND a.attrelid = bc.oid + AND i.indproc = '0'::oid + AND i.indisprimary = 't' + $wh + ORDER BY 2, 3, 5 + }; + + my $sth = $dbh->prepare( $pri_key_sql ) or return undef; + $sth->execute(@dat); + + return $sth; + } + + sub foreign_key_info { + # todo: verify schema work as expected + # add code to handle multiple-column keys correctly + # return something nicer for pre-7.3? + # try to clean up SQL, perl code + # create a test script? + + my $dbh = shift; + my ($pk_catalog, $pk_schema, $pk_table, + $fk_catalog, $fk_schema, $fk_table) = @_; + + # this query doesn't work for Postgres before 7.3 + my $version = $dbh->pg_server_version; + $version =~ /^(\d+)\.(\d)/; + return undef if ($1.$2 < 73); + + # Used to hold data for the attributes. + my @dat = (); + + # SQL to find primary/unique keys of a table + my $pkey_sql = qq{ + SELECT + NULL::text AS PKTABLE_CAT, + pknam.nspname AS PKTABLE_SCHEM, + pkc.relname AS PKTABLE_NAME, + pka.attname AS PKCOLUMN_NAME, + NULL::text AS FKTABLE_CAT, + NULL::text AS FKTABLE_SCHEM, + NULL::text AS FKTABLE_NAME, + NULL::text AS FKCOLUMN_NAME, + pkcon.conkey[1] AS KEY_SEQ, + CASE + WHEN pkcon.confupdtype = 'c' THEN 0 + WHEN pkcon.confupdtype = 'r' THEN 1 + WHEN pkcon.confupdtype = 'n' THEN 2 + WHEN pkcon.confupdtype = 'a' THEN 3 + WHEN pkcon.confupdtype = 'd' THEN 4 + END AS UPDATE_RULE, + CASE + WHEN pkcon.confdeltype = 'c' THEN 0 + WHEN pkcon.confdeltype = 'r' THEN 1 + WHEN pkcon.confdeltype = 'n' THEN 2 + WHEN pkcon.confdeltype = 'a' THEN 3 + WHEN pkcon.confdeltype = 'd' THEN 4 + END AS DELETE_RULE, + NULL::text AS FK_NAME, + pkcon.conname AS PK_NAME, + CASE + WHEN pkcon.condeferrable = 'f' THEN 7 + WHEN pkcon.condeferred = 't' THEN 6 + WHEN pkcon.condeferred = 'f' THEN 5 + END AS DEFERRABILITY, + CASE + WHEN pkcon.contype = 'p' THEN 'PRIMARY' + WHEN pkcon.contype = 'u' THEN 'UNIQUE' + END AS UNIQUE_OR_PRIMARY + FROM + pg_constraint AS pkcon + JOIN + pg_class pkc ON pkc.oid=pkcon.conrelid + JOIN + pg_namespace pknam ON pkcon.connamespace=pknam.oid + JOIN + pg_attribute pka ON pka.attnum=pkcon.conkey[1] AND pka.attrelid=pkc.oid + }; + + # SQL to find foreign keys of a table + my $fkey_sql = qq{ + SELECT + NULL::text AS PKTABLE_CAT, + pknam.nspname AS PKTABLE_SCHEM, + pkc.relname AS PKTABLE_NAME, + pka.attname AS PKCOLUMN_NAME, + NULL::text AS FKTABLE_CAT, + fknam.nspname AS FKTABLE_SCHEM, + fkc.relname AS FKTABLE_NAME, + fka.attname AS FKCOLUMN_NAME, + fkcon.conkey[1] AS KEY_SEQ, + CASE + WHEN fkcon.confupdtype = 'c' THEN 0 + WHEN fkcon.confupdtype = 'r' THEN 1 + WHEN fkcon.confupdtype = 'n' THEN 2 + WHEN fkcon.confupdtype = 'a' THEN 3 + WHEN fkcon.confupdtype = 'd' THEN 4 + END AS UPDATE_RULE, + CASE + WHEN fkcon.confdeltype = 'c' THEN 0 + WHEN fkcon.confdeltype = 'r' THEN 1 + WHEN fkcon.confdeltype = 'n' THEN 2 + WHEN fkcon.confdeltype = 'a' THEN 3 + WHEN fkcon.confdeltype = 'd' THEN 4 + END AS DELETE_RULE, + fkcon.conname AS FK_NAME, + pkcon.conname AS PK_NAME, + CASE + WHEN fkcon.condeferrable = 'f' THEN 7 + WHEN fkcon.condeferred = 't' THEN 6 + WHEN fkcon.condeferred = 'f' THEN 5 + END AS DEFERRABILITY, + CASE + WHEN pkcon.contype = 'p' THEN 'PRIMARY' + WHEN pkcon.contype = 'u' THEN 'UNIQUE' + END AS UNIQUE_OR_PRIMARY + FROM + pg_constraint AS fkcon + JOIN + pg_constraint AS pkcon ON fkcon.confrelid=pkcon.conrelid + AND fkcon.confkey=pkcon.conkey + JOIN + pg_class fkc ON fkc.oid=fkcon.conrelid + JOIN + pg_class pkc ON pkc.oid=fkcon.confrelid + JOIN + pg_namespace pknam ON pkcon.connamespace=pknam.oid + JOIN + pg_namespace fknam ON fkcon.connamespace=fknam.oid + JOIN + pg_attribute fka ON fka.attnum=fkcon.conkey[1] AND fka.attrelid=fkc.oid + JOIN + pg_attribute pka ON pka.attnum=pkcon.conkey[1] AND pka.attrelid=pkc.oid + }; + + # if schema are provided, use this SQL + my $pk_schema_sql = " AND pknam.nspname = ? "; + my $fk_schema_sql = " AND fknam.nspname = ? "; + + my $key_sql; + + # if $fk_table: generate SQL stub, which will be same + # whether or not $pk_table supplied + if ($fk_table) + { + $key_sql = $fkey_sql . qq{ + WHERE + fkc.relname = ? + }; + push @dat, $fk_table; + + if ($fk_schema) + { + $key_sql .= $fk_schema_sql; + push @dat,$fk_schema; + } + } + + # if $fk_table and $pk_table: (defined by DBI, not SQL/CLI) + # return foreign key of $fk_table that refers to $pk_table + # (if any) + if ($pk_table and $fk_table) + { + $key_sql .= qq{ + AND + pkc.relname = ? + }; + push @dat, $pk_table; + + if ($pk_schema) + { + $key_sql .= $pk_schema_sql; + push @dat,$pk_schema; + } + } + + # if $fk_table but no $pk_table: + # return all foreign keys of $fk_table, and all + # primary keys of tables to which $fk_table refers + if (!$pk_table and $fk_table) + { + # find primary/unique keys referenced by $fk_table + # (this one is a little tricky) + $key_sql .= ' UNION ' . $pkey_sql . qq{ + WHERE + pkcon.conname IN + ( + SELECT + pkcon.conname + FROM + pg_constraint AS fkcon + JOIN + pg_constraint AS pkcon ON fkcon.confrelid=pkcon.conrelid AND + fkcon.confkey=pkcon.conkey + JOIN + pg_class fkc ON fkc.oid=fkcon.conrelid + WHERE + fkc.relname = ? + ) + }; + push @dat, $fk_table; + + if ($fk_schema) + { + $key_sql .= $pk_schema_sql; + push @dat,$fk_schema; + } + } + + # if $pk_table but no $fk_table: + # return primary key of $pk_table and all foreign keys + # that reference $pk_table + # question: what about unique keys? + # (DBI and SQL/CLI both state to omit unique keys) + + if ($pk_table and !$fk_table) + { + # find primary key (only!) of $pk_table + $key_sql = $pkey_sql . qq{ + WHERE + pkc.relname = ? + AND + pkcon.contype = 'p' + }; + @dat = ($pk_table); + + if ($pk_schema) + { + $key_sql .= $pk_schema_sql; + push @dat,$pk_schema; + } + + # find all foreign keys that reference $pk_table + $key_sql .= 'UNION ' . $fkey_sql . qq{ + WHERE + pkc.relname = ? + AND + pkcon.contype = 'p' + }; + push @dat, $pk_table; + + if ($pk_schema) + { + $key_sql .= $fk_schema_sql; + push @dat,$pk_schema; + } + } + + return undef unless $key_sql; + my $sth = $dbh->prepare( $key_sql ) or + return undef; + $sth->execute(@dat); + + return $sth; + } + + + sub table_info { # DBI spec: TABLE_CAT, TABLE_SCHEM, TABLE_NAME, TABLE_TYPE, REMARKS + my $dbh = shift; + my ($catalog, $schema, $table, $type) = @_; + my @attrs = @_; + + my $tbl_sql = (); + + my $version = DBD::Pg::pg_server_version($dbh); + $version =~ /^(\d+\.\d+)/; + $version = $1; + my $CATALOG = DBD::Pg::pg_use_catalog($dbh); + + if ( # Rules 19a + (defined $catalog and $catalog eq '%') + and (defined $schema and $schema eq '') + and (defined $table and $table eq '') + ) { + $tbl_sql = q{ + SELECT + NULL::text AS "TABLE_CAT" + , NULL::text AS "TABLE_SCHEM" + , NULL::text AS "TABLE_NAME" + , NULL::text AS "TABLE_TYPE" + , NULL::text AS "REMARKS" + }; + } + elsif (# Rules 19b + (defined $catalog and $catalog eq '') + and (defined $schema and $schema eq '%') + and (defined $table and $table eq '') + ) { + $tbl_sql = ($version < 7.3) ? q{ + SELECT + NULL::text AS "TABLE_CAT" + , NULL::text AS "TABLE_SCHEM" + , NULL::text AS "TABLE_NAME" + , NULL::text AS "TABLE_TYPE" + , NULL::text AS "REMARKS" + } : q{ + SELECT + NULL::text AS "TABLE_CAT" + , n.nspname AS "TABLE_SCHEM" + , NULL::text AS "TABLE_NAME" + , NULL::text AS "TABLE_TYPE" + , NULL::text AS "REMARKS" + FROM pg_catalog.pg_namespace n + ORDER BY 1 + }; + } + elsif (# Rules 19c + (defined $catalog and $catalog eq '') + and (defined $schema and $schema eq '') + and (defined $table and $table eq '') + and (defined $type and $type eq '%') + ) { + # From the postgresql 7.2.1 manual 3.5 pg_class + # 'r' = ordinary table + #, 'i' = index + #, 'S' = sequence + #, 'v' = view + #, 's' = special + #, 't' = secondary TOAST table + $tbl_sql = q{ + SELECT + NULL::text AS "TABLE_CAT" + , NULL::text AS "TABLE_SCHEM" + , NULL::text AS "TABLE_NAME" + , 'table' AS "TABLE_TYPE" + , 'ordinary table - r' AS "REMARKS" + union + SELECT + NULL::text AS "TABLE_CAT" + , NULL::text AS "TABLE_SCHEM" + , NULL::text AS "TABLE_NAME" + , 'index' AS "TABLE_TYPE" + , 'index - i' AS "REMARKS" + union + SELECT + NULL::text AS "TABLE_CAT" + , NULL::text AS "TABLE_SCHEM" + , NULL::text AS "TABLE_NAME" + , 'sequence' AS "TABLE_TYPE" + , 'sequence - S' AS "REMARKS" + union + SELECT + NULL::text AS "TABLE_CAT" + , NULL::text AS "TABLE_SCHEM" + , NULL::text AS "TABLE_NAME" + , 'view' AS "TABLE_TYPE" + , 'view - v' AS "REMARKS" + union + SELECT + NULL::text AS "TABLE_CAT" + , NULL::text AS "TABLE_SCHEM" + , NULL::text AS "TABLE_NAME" + , 'special' AS "TABLE_TYPE" + , 'special - s' AS "REMARKS" + union + SELECT + NULL::text AS "TABLE_CAT" + , NULL::text AS "TABLE_SCHEM" + , NULL::text AS "TABLE_NAME" + , 'secondary' AS "TABLE_TYPE" + , 'secondary TOAST table - t' AS "REMARKS" + }; + } + else { + # Default SQL + my $showschema = $version < 7.3 ? "NULL::text" : "n.nspname"; + my $schemajoin = $version < 7.3 ? "" : "LEFT JOIN pg_catalog.pg_namespace n ON (n.oid = c.relnamespace)"; + my $schemacase = $version < 7.3 ? "CASE WHEN c.relname ~ '^pg_' THEN 'SYSTEM TABLE' ELSE 'TABLE' END" : + "CASE WHEN n.nspname ~ '^pg_' THEN 'SYSTEM TABLE' ELSE 'TABLE' END"; + $tbl_sql = qq{ + SELECT NULL::text AS "TABLE_CAT" + , $showschema AS "TABLE_SCHEM" + , c.relname AS "TABLE_NAME" + , CASE + WHEN c.relkind = 'v' THEN 'VIEW' + ELSE $schemacase + END AS "TABLE_TYPE" + , d.description AS "REMARKS" + FROM ${CATALOG}pg_user AS u + , ${CATALOG}pg_class AS c + LEFT JOIN + ${CATALOG}pg_description AS d + ON (c.relfilenode = d.objoid AND d.objsubid = 0) + $schemajoin + WHERE + ((c.relkind = 'r' + AND c.relhasrules = FALSE) OR + (c.relkind = 'v' + AND c.relhasrules = TRUE)) + AND c.relname !~ '^xin[vx][0-9]+' + AND c.relowner = u.usesysid + ORDER BY 1, 2, 3 + }; + + # Did we receive any arguments? + if (@attrs) { + my @wh = (); + my @flds = qw/catname n.nspname c.relname c.relkind/; + + for my $idx (0 .. $#attrs) { + next if ($flds[$idx] eq 'catname'); # Skip catalog + if(defined $attrs[$idx] and length $attrs[$idx]) { + # Change the "name" of the types to the real value. + if ($flds[$idx] =~ m/relkind/) { + $attrs[$idx] =~ s/^\'?table\'?/'r'/i; + $attrs[$idx] =~ s/^\'?index\'?/'i'/i; + $attrs[$idx] =~ s/^\'?sequence\'?/'S'/i; + $attrs[$idx] =~ s/^\'?view\'?/'v'/i; + $attrs[$idx] =~ s/^\'?special\'?/'s'/i; + $attrs[$idx] =~ s/^\'?secondary\'?/'t'/i; + } + # Insure that the value is enclosed in single quotes. + $attrs[$idx] =~ s/^'?(\w+)'?$/'$1'/; + if ($attrs[$idx] =~ m/[,%]/) { + # contains a meta character. + push( @wh, q{( } . join ( " OR " + , map { m/\%/ + ? qq{$flds[$idx] LIKE $_ } + : qq{$flds[$idx] = $_ } + } (split /,/, $attrs[$idx]) ) + . q{ )} + ); + } + else { + push( @wh, qq{$flds[$idx] = $attrs[$idx]} ); + } + } + } + + my $wh = (); + if (@wh) { + $wh = join( " AND ",'', @wh ); + $tbl_sql = qq{ + SELECT NULL::text AS "TABLE_CAT" + , $showschema AS "TABLE_SCHEM" + , c.relname AS "TABLE_NAME" + , CASE + WHEN c.relkind = 'r' THEN + CASE WHEN n.nspname ~ '^pg_' THEN 'SYSTEM TABLE' ELSE 'TABLE' END + WHEN c.relkind = 'v' THEN 'VIEW' + WHEN c.relkind = 'i' THEN 'INDEX' + WHEN c.relkind = 'S' THEN 'SEQUENCE' + WHEN c.relkind = 's' THEN 'SPECIAL' + WHEN c.relkind = 't' THEN 'SECONDARY' + ELSE 'UNKNOWN' + END AS "TABLE_TYPE" + , d.description AS "REMARKS" + FROM ${CATALOG}pg_class AS c + LEFT JOIN + ${CATALOG}pg_description AS d + ON (c.relfilenode = d.objoid AND d.objsubid = 0) + $schemajoin + WHERE + c.relname !~ '^xin[vx][0-9]+' + $wh + ORDER BY 2, 3 + }; + } + } + } + + my $sth = $dbh->prepare( $tbl_sql ) or return undef; + $sth->execute(); + + return $sth; + } + + + sub tables { + my($dbh) = @_; + my $version = DBD::Pg::pg_server_version($dbh); + $version =~ /^(\d+\.\d+)/; + $version = $1; + my $SQL = ($version < 7.3) ? + "SELECT relname AS \"TABLE_NAME\" + FROM pg_class + WHERE relkind = 'r' + AND relname !~ '^pg_' + AND relname !~ '^xin[vx][0-9]+' + ORDER BY 1" : + "SELECT n.nspname AS \"SCHEMA_NAME\", c.relname AS \"TABLE_NAME\" + FROM pg_catalog.pg_class c + LEFT JOIN pg_catalog.pg_namespace n ON (n.oid = c.relnamespace) + WHERE c.relkind = 'r' + AND n.nspname NOT IN ('pg_catalog', 'pg_toast') + AND pg_catalog.pg_table_is_visible(c.oid) + ORDER BY 1,2"; + my $sth = $dbh->prepare($SQL) or return undef; + $sth->execute or return undef; + my (@tables, @relname); + while (@relname = $sth->fetchrow_array) { + push @tables, $version < 7.3 ? $relname[0] : "$relname[0].$relname[1]"; + } + $sth->finish; + + return @tables; + } + + + sub table_attributes { + my ($dbh, $table) = @_; + my $CATALOG = DBD::Pg::pg_use_catalog($dbh); + my $result = []; + my $attrs = $dbh->selectall_arrayref( + "select a.attname, t.typname, a.attlen, a.atttypmod, a.attnotnull, a.atthasdef, a.attnum + from ${CATALOG}pg_attribute a, + ${CATALOG}pg_class c, + ${CATALOG}pg_type t + where c.relname = ? + and a.attrelid = c.oid + and a.attnum >= 0 + and t.oid = a.atttypid + order by 1 + ", undef, $table); + + return $result unless scalar(@$attrs); + + # Select the array value for tables primary key. + my $pk_key_sql = qq{SELECT pg_index.indkey + FROM ${CATALOG}pg_class, ${CATALOG}pg_index + WHERE + pg_class.oid = pg_index.indrelid + AND pg_class.relname = '$table' + AND pg_index.indisprimary = 't' + }; + # Expand this (returned as a string) a real array. + my @pk = (); + my $pkeys = $dbh->selectrow_array( $pk_key_sql ); + if (defined $pkeys) { + foreach (split( /\s+/, $pkeys)) + { + push @pk, $_; + } + } + my $pk_bt = + (@pk) ? "AND pg_attribute.attnum in (" . join ( ", ", @pk ) . ")" + : ""; + + # Get the primary key + my $pri_key = $dbh->selectcol_arrayref("SELECT pg_attribute.attname + FROM ${CATALOG}pg_class, ${CATALOG}pg_attribute, ${CATALOG}pg_index + WHERE pg_class.oid = pg_attribute.attrelid + AND pg_class.oid = pg_index.indrelid + $pk_bt + AND pg_index.indisprimary = 't' + AND pg_class.relname = ? + ORDER BY pg_attribute.attnum + ", undef, $table ); + $pri_key = [] unless $pri_key; + + foreach my $attr (reverse @$attrs) { + my ($col_name, $col_type, $size, $mod, $notnull, $hasdef, $attnum) = @$attr; + my $col_size = do { + if ($size > 0) { + $size; + } elsif ($mod > 0xffff) { + my $prec = ($mod & 0xffff) - 4; + $mod >>= 16; + my $dig = $mod; + $dig; + } elsif ($mod >= 4) { + $mod - 4; + } else { + $mod; + } + }; + + # Get the default value, if any + my ($default) = $dbh->selectrow_array("SELECT adsrc FROM ${CATALOG}pg_attrdef WHERE adnum = $attnum") if -1 == $attnum; + $default = '' unless $default; + + # Test for any constraints + # Note: as of PostgreSQL 7.3 pg_relcheck has been replaced + # by pg_constraint. To maintain compatibility, check + # version number and execute appropriate query. + + my $version = pg_server_version( $dbh ); + + my $con_query = $version < 7.3 + ? "SELECT rcsrc FROM pg_relcheck WHERE rcname = '${table}_$col_name'" + : "SELECT consrc FROM pg_catalog.pg_constraint WHERE contype = 'c' AND conname = '${table}_$col_name'"; + my ($constraint) = $dbh->selectrow_array($con_query); + $constraint = '' unless $constraint; + + # Check to see if this is the primary key + my $is_primary_key = scalar(grep { /^$col_name$/i } @$pri_key) ? 1 : 0; + + push @$result, + { NAME => $col_name, + TYPE => $col_type, + SIZE => $col_size, + NOTNULL => $notnull, + DEFAULT => $default, + CONSTRAINT => $constraint, + PRIMARY_KEY => $is_primary_key, + }; + } + + return $result; + } + + + sub type_info_all { + my ($dbh) = @_; + + #my $names = { + # TYPE_NAME => 0, + # DATA_TYPE => 1, + # PRECISION => 2, + # LITERAL_PREFIX => 3, + # LITERAL_SUFFIX => 4, + # CREATE_PARAMS => 5, + # NULLABLE => 6, + # CASE_SENSITIVE => 7, + # SEARCHABLE => 8, + # UNSIGNED_ATTRIBUTE => 9, + # MONEY =>10, + # AUTO_INCREMENT =>11, + # LOCAL_TYPE_NAME =>12, + # MINIMUM_SCALE =>13, + # MAXIMUM_SCALE =>14, + # }; + + my $names = { + TYPE_NAME => 0, + DATA_TYPE => 1, + COLUMN_SIZE => 2, # was PRECISION originally + LITERAL_PREFIX => 3, + LITERAL_SUFFIX => 4, + CREATE_PARAMS => 5, + NULLABLE => 6, + CASE_SENSITIVE => 7, + SEARCHABLE => 8, + UNSIGNED_ATTRIBUTE=> 9, + FIXED_PREC_SCALE => 10, # was MONEY originally + AUTO_UNIQUE_VALUE => 11, # was AUTO_INCREMENT originally + LOCAL_TYPE_NAME => 12, + MINIMUM_SCALE => 13, + MAXIMUM_SCALE => 14, + NUM_PREC_RADIX => 15, + }; + + + # typname |typlen|typprtlen| SQL92 + # --------------+------+---------+ ------- + # bool | 1| 1| BOOLEAN + # text | -1| -1| like VARCHAR, but automatic storage allocation + # bpchar | -1| -1| CHARACTER(n) bp=blank padded + # varchar | -1| -1| VARCHAR(n) + # int2 | 2| 5| SMALLINT + # int4 | 4| 10| INTEGER + # int8 | 8| 20| / + # money | 4| 24| / + # float4 | 4| 12| FLOAT(p) for p<7=float4, for p<16=float8 + # float8 | 8| 24| REAL + # abstime | 4| 20| / + # reltime | 4| 20| / + # tinterval | 12| 47| / + # date | 4| 10| / + # time | 8| 16| / + # datetime | 8| 47| / + # timespan | 12| 47| INTERVAL + # timestamp | 4| 19| TIMESTAMP + # --------------+------+---------+ + + # DBI type definitions / PostgreSQL definitions # type needs to be DBI-specific (not pg_type) + # + # SQL_ALL_TYPES 0 + # SQL_CHAR 1 1042 bpchar + # SQL_NUMERIC 2 700 float4 + # SQL_DECIMAL 3 700 float4 + # SQL_INTEGER 4 23 int4 + # SQL_SMALLINT 5 21 int2 + # SQL_FLOAT 6 700 float4 + # SQL_REAL 7 701 float8 + # SQL_DOUBLE 8 20 int8 + # SQL_DATE 9 1082 date + # SQL_TIME 10 1083 time + # SQL_TIMESTAMP 11 1296 timestamp + # SQL_VARCHAR 12 1043 varchar + + my $ti = [ + $names, + # name type prec prefix suffix create params null case se unsign mon incr local min max + # + [ 'bytea', -2, 4096, '\'', '\'', undef, 1, '1', 3, undef, '0', '0', 'BYTEA', undef, undef, undef ], + [ 'bool', 0, 1, '\'', '\'', undef, 1, '0', 2, undef, '0', '0', 'BOOLEAN', undef, undef, undef ], + [ 'int8', 8, 20, undef, undef, undef, 1, '0', 2, '0', '0', '0', 'LONGINT', undef, undef, undef ], + [ 'int2', 5, 5, undef, undef, undef, 1, '0', 2, '0', '0', '0', 'SMALLINT', undef, undef, undef ], + [ 'int4', 4, 10, undef, undef, undef, 1, '0', 2, '0', '0', '0', 'INTEGER', undef, undef, undef ], + [ 'text', 12, 4096, '\'', '\'', undef, 1, '1', 3, undef, '0', '0', 'TEXT', undef, undef, undef ], + [ 'float4', 6, 12, undef, undef, 'precision', 1, '0', 2, '0', '0', '0', 'FLOAT', undef, undef, undef ], + [ 'float8', 7, 24, undef, undef, 'precision', 1, '0', 2, '0', '0', '0', 'REAL', undef, undef, undef ], + [ 'abstime', 10, 20, '\'', '\'', undef, 1, '0', 2, undef, '0', '0', 'ABSTIME', undef, undef, undef ], + [ 'reltime', 10, 20, '\'', '\'', undef, 1, '0', 2, undef, '0', '0', 'RELTIME', undef, undef, undef ], + [ 'tinterval', 11, 47, '\'', '\'', undef, 1, '0', 2, undef, '0', '0', 'TINTERVAL', undef, undef, undef ], + [ 'money', 0, 24, undef, undef, undef, 1, '0', 2, undef, '1', '0', 'MONEY', undef, undef, undef ], + [ 'bpchar', 1, 4096, '\'', '\'', 'max length', 1, '1', 3, undef, '0', '0', 'CHARACTER', undef, undef, undef ], + [ 'bpchar', 12, 4096, '\'', '\'', 'max length', 1, '1', 3, undef, '0', '0', 'CHARACTER', undef, undef, undef ], + [ 'varchar', 12, 4096, '\'', '\'', 'max length', 1, '1', 3, undef, '0', '0', 'VARCHAR', undef, undef, undef ], + [ 'date', 9, 10, '\'', '\'', undef, 1, '0', 2, undef, '0', '0', 'DATE', undef, undef, undef ], + [ 'time', 10, 16, '\'', '\'', undef, 1, '0', 2, undef, '0', '0', 'TIME', undef, undef, undef ], + [ 'datetime', 11, 47, '\'', '\'', undef, 1, '0', 2, undef, '0', '0', 'DATETIME', undef, undef, undef ], + [ 'timespan', 11, 47, '\'', '\'', undef, 1, '0', 2, undef, '0', '0', 'INTERVAL', undef, undef, undef ], + [ 'timestamp', 10, 19, '\'', '\'', undef, 1, '0', 2, undef, '0', '0', 'TIMESTAMP', undef, undef, undef ] + # + # intentionally omitted: char, all geometric types, all array types + ]; + return $ti; + } + + + # Characters that need to be escaped by quote(). + my %esc = ( "'" => '\\047', # '\\' . sprintf("%03o", ord("'")), # ISO SQL 2 + '\\' => '\\134', # '\\' . sprintf("%03o", ord("\\")), + ); + + # Set up lookup for SQL types we don't want to escape. + my %no_escape = map { $_ => 1 } + DBI::SQL_INTEGER, DBI::SQL_SMALLINT, DBI::SQL_DECIMAL, + DBI::SQL_FLOAT, DBI::SQL_REAL, DBI::SQL_DOUBLE, DBI::SQL_NUMERIC; + + sub quote { + my ($dbh, $str, $data_type) = @_; + return "NULL" unless defined $str; + return $str if $data_type && $no_escape{$data_type}; + + $dbh->DBI::set_err(1, "Use of SQL_BINARY invalid in quote()") + if $data_type && $data_type == DBI::SQL_BINARY; + + $str =~ s/(['\\\0])/$esc{$1}/g; + return "'$str'"; + } + +} # end of package DBD::Pg::db + +{ package DBD::Pg::st; # ====== STATEMENT ====== + + # all done in XS + +} + +1; + +__END__ + +=head1 NAME + +DBD::Pg - PostgreSQL database driver for the DBI module + +=head1 SYNOPSIS + + use DBI; + + $dbh = DBI->connect("dbi:Pg:dbname=$dbname", "", ""); + + # for some advanced uses you may need PostgreSQL type values: + use DBD::Oracle qw(:pg_types); + + # See the DBI module documentation for full details + +=head1 DESCRIPTION + +DBD::Pg is a Perl module which works with the DBI module to provide access to +PostgreSQL databases. + +=head1 MODULE DOCUMENTATION + +This documentation describes driver specific behavior and restrictions. It is +not supposed to be used as the only reference for the user. In any case +consult the DBI documentation first! + +=head1 THE DBI CLASS + +=head2 DBI Class Methods + +=over 4 + +=item B<connect> + +To connect to a database with a minimum of parameters, use the following +syntax: + + $dbh = DBI->connect("dbi:Pg:dbname=$dbname", "", ""); + +This connects to the database $dbname at localhost without any user +authentication. This is sufficient for the defaults of PostgreSQL. + +The following connect statement shows all possible parameters: + + $dbh = DBI->connect("dbi:Pg:dbname=$dbname;host=$host;port=$port;" . + "options=$options;tty=$tty", "$username", "$password"); + +If a parameter is undefined PostgreSQL first looks for specific environment +variables and then it uses hard coded defaults: + + parameter environment variable hard coded default + -------------------------------------------------- + dbname PGDATABASE current userid + host PGHOST localhost + port PGPORT 5432 + options PGOPTIONS "" + tty PGTTY "" + username PGUSER current userid + password PGPASSWORD "" + +If a host is specified, the postmaster on this host needs to be started with +the C<-i> option (TCP/IP sockets). + +The options parameter specifies runtime options for the Postgres +backend. Common usage is to increase the number of buffers with the C<-B> +option. Also important is the C<-F> option, which disables automatic fsync() +call after each transaction. For further details please refer to the +L<postgres>. + +For authentication with username and password appropriate entries have to be +made in pg_hba.conf. Please refer to the L<pg_hba.conf> and the L<pg_passwd> +for the different types of authentication. Note that for these two parameters +DBI distinguishes between empty and undefined. If these parameters are +undefined DBI substitutes the values of the environment variables DBI_USER and +DBI_PASS if present. + +=item B<available_drivers> + + @driver_names = DBI->available_drivers; + +Implemented by DBI, no driver-specific impact. + +=item B<data_sources> + + @data_sources = DBI->data_sources('Pg'); + +The driver supports this method. Note that the necessary database connection to +the database template1 will be done on the localhost without any +user-authentication. Other preferences can only be set with the environment +variables PGHOST, DBI_USER and DBI_PASS. + +=item B<trace> + + DBI->trace($trace_level, $trace_file) + +Implemented by DBI, no driver-specific impact. + +=back + +=head2 DBI Dynamic Attributes + +See Common Methods. + +=head1 METHODS COMMON TO ALL HANDLES + +=over 4 + +=item B<err> + + $rv = $h->err; + +Supported by the driver as proposed by DBI. For the connect method it returns +PQstatus. In all other cases it returns PQresultStatus of the current handle. + +=item B<errstr> + + $str = $h->errstr; + +Supported by the driver as proposed by DBI. It returns the PQerrorMessage +related to the current handle. + +=item B<state> + + $str = $h->state; + +This driver does not (yet) support the state method. + +=item B<trace> + + $h->trace($trace_level, $trace_filename); + +Implemented by DBI, no driver-specific impact. + +=item B<trace_msg> + + $h->trace_msg($message_text); + +Implemented by DBI, no driver-specific impact. + +=item B<func> + +This driver supports a variety of driver specific functions accessible via the +func interface: + + $attrs = $dbh->func($table, 'table_attributes'); + +This method returns for the given table a reference to an array of hashes: + + NAME attribute name + TYPE attribute type + SIZE attribute size (-1 for variable size) + NULLABLE flag nullable + DEFAULT default value + CONSTRAINT constraint + PRIMARY_KEY flag is_primary_key + + $lobjId = $dbh->func($mode, 'lo_creat'); + +Creates a new large object and returns the object-id. $mode is a bit-mask +describing different attributes of the new object. Use the following +constants: + + $dbh->{pg_INV_WRITE} + $dbh->{pg_INV_READ} + +Upon failure it returns undef. + + $lobj_fd = $dbh->func($lobjId, $mode, 'lo_open'); + +Opens an existing large object and returns an object-descriptor for use in +subsequent lo_* calls. For the mode bits see lo_create. Returns undef upon +failure. Note that 0 is a perfectly correct object descriptor! + + $nbytes = $dbh->func($lobj_fd, $buf, $len, 'lo_write'); + +Writes $len bytes of $buf into the large object $lobj_fd. Returns the number +of bytes written and undef upon failure. + + $nbytes = $dbh->func($lobj_fd, $buf, $len, 'lo_read'); + +Reads $len bytes into $buf from large object $lobj_fd. Returns the number of +bytes read and undef upon failure. + + $loc = $dbh->func($lobj_fd, $offset, $whence, 'lo_lseek'); + +Change the current read or write location on the large object +$obj_id. Currently $whence can only be 0 (L_SET). Returns the current location +and undef upon failure. + + $loc = $dbh->func($lobj_fd, 'lo_tell'); + +Returns the current read or write location on the large object $lobj_fd and +undef upon failure. + + $lobj_fd = $dbh->func($lobj_fd, 'lo_close'); + +Closes an existing large object. Returns true upon success and false upon +failure. + + $lobj_fd = $dbh->func($lobj_fd, 'lo_unlink'); + +Deletes an existing large object. Returns true upon success and false upon +failure. + + $lobjId = $dbh->func($filename, 'lo_import'); + +Imports a Unix file as large object and returns the object id of the new +object or undef upon failure. + + $ret = $dbh->func($lobjId, 'lo_export', 'filename'); + +Exports a large object into a Unix file. Returns false upon failure, true +otherwise. + + $ret = $dbh->func($line, 'putline'); + +Used together with the SQL-command 'COPY table FROM STDIN' to copy large +amount of data into a table avoiding the overhead of using single +insert commands. The application must explicitly send the two characters "\." +to indicate to the backend that it has finished sending its data. See test.pl +for an example on how to use this function. + + $ret = $dbh->func($buffer, length, 'getline'); + +Used together with the SQL-command 'COPY table TO STDOUT' to dump a complete +table. See test.pl for an example on how to use this function. + + $ret = $dbh->func('pg_notifies'); + +Returns either undef or a reference to two-element array [ $table, +$backend_pid ] of asynchronous notifications received. + + $fd = $dbh->func('getfd'); + +Returns fd of the actual connection to server. Can be used with select() and +func('pg_notifies'). + +=back + +=head1 ATTRIBUTES COMMON TO ALL HANDLES + +=over 4 + +=item B<Warn> (boolean, inherited) + +Implemented by DBI, no driver-specific impact. + +=item B<Active> (boolean, read-only) + +Supported by the driver as proposed by DBI. A database handle is active while +it is connected and statement handle is active until it is finished. + +=item B<Kids> (integer, read-only) + +Implemented by DBI, no driver-specific impact. + +=item B<ActiveKids> (integer, read-only) + +Implemented by DBI, no driver-specific impact. + +=item B<CachedKids> (hash ref) + +Implemented by DBI, no driver-specific impact. + +=item B<CompatMode> (boolean, inherited) + +Not used by this driver. + +=item B<InactiveDestroy> (boolean) + +Implemented by DBI, no driver-specific impact. + +=item B<PrintError> (boolean, inherited) + +Implemented by DBI, no driver-specific impact. + +=item B<RaiseError> (boolean, inherited) + +Implemented by DBI, no driver-specific impact. + +=item B<HandleError> (boolean, inherited) + +Implemented by DBI, no driver-specific impact. + +=item B<ChopBlanks> (boolean, inherited) + +Supported by the driver as proposed by DBI. This method is similar to the +SQL-function RTRIM. + +=item B<LongReadLen> (integer, inherited) + +Implemented by DBI, not used by the driver. + +=item B<LongTruncOk> (boolean, inherited) + +Implemented by DBI, not used by the driver. + +=item B<Taint> (boolean, inherited) + +Implemented by DBI, no driver-specific impact. + +=item B<private_*> + +Implemented by DBI, no driver-specific impact. + +=back + +=head1 DBI DATABASE HANDLE OBJECTS + +=head2 Database Handle Methods + +=over 4 + +=item B<selectrow_array> + + @row_ary = $dbh->selectrow_array($statement, \%attr, @bind_values); + +Implemented by DBI, no driver-specific impact. + +=item B<selectrow_arrayref> + + $ary_ref = $dbh->selectrow_arrayref($statement, \%attr, @bind_values); + +Implemented by DBI, no driver-specific impact. + +=item B<selectrow_hashref> + + $hash_ref = $dbh->selectrow_hashref($statement, \%attr, @bind_values); + +Implemented by DBI, no driver-specific impact. + +=item B<selectall_arrayref> + + $ary_ref = $dbh->selectall_arrayref($statement, \%attr, @bind_values); + +Implemented by DBI, no driver-specific impact. + +=item B<selectall_hashref> + + $hash_ref = $dbh->selectall_hashref($statement, $key_field); + +Implemented by DBI, no driver-specific impact. + +=item B<selectcol_arrayref> + + $ary_ref = $dbh->selectcol_arrayref($statement, \%attr, @bind_values); + +Implemented by DBI, no driver-specific impact. + +=item B<prepare> + + $sth = $dbh->prepare($statement, \%attr); + +PostgreSQL does not have the concept of preparing a statement. Hence the +prepare method just stores the statement after checking for place-holders. No +information about the statement is available after preparing it. + +=item B<prepare_cached> + + $sth = $dbh->prepare_cached($statement, \%attr); + +Implemented by DBI, no driver-specific impact. This method is not useful for +this driver, because preparing a statement has no database interaction. + +=item B<do> + + $rv = $dbh->do($statement, \%attr, @bind_values); + +Implemented by DBI, no driver-specific impact. See the notes for the execute +method elsewhere in this document. + +=item B<commit> + + $rc = $dbh->commit; + +Supported by the driver as proposed by DBI. See also the notes about +B<Transactions> elsewhere in this document. + +=item B<rollback> + + $rc = $dbh->rollback; + +Supported by the driver as proposed by DBI. See also the notes about +B<Transactions> elsewhere in this document. + +=item B<disconnect> + + $rc = $dbh->disconnect; + +Supported by the driver as proposed by DBI. + +=item B<ping> + + $rc = $dbh->ping; + +This driver supports the ping-method, which can be used to check the validity +of a database-handle. The ping method issues an empty query and checks the +result status. + +=item B<table_info> + + $sth = $dbh->table_info; + +Supported by the driver as proposed by DBI. This method returns all tables and +views which are owned by the current user. It does not select any indexes and +sequences. Also System tables are not selected. As TABLE_QUALIFIER the reltype +attribute is returned and the REMARKS are undefined. + +=item B<foreign_key_info> + + $sth = $dbh->foreign_key_info( $pk_catalog, $pk_schema, $pk_table, + $fk_catalog, $fk_schema, $fk_table ); + +Supported by the driver as proposed by DBI. Unimplemented for Postgres +servers before 7.3 (returns undef). Currently only returns information +about first column of any multiple-column keys. + +=item B<tables> + + @names = $dbh->tables; + +Supported by the driver as proposed by DBI. This method returns all tables and +views which are owned by the current user. It does not select any indexes and +sequences, or system tables. + +=item B<type_info_all> + + $type_info_all = $dbh->type_info_all; + +Supported by the driver as proposed by DBI. Only for SQL data-types and for +frequently used data-types information is provided. The mapping between the +PostgreSQL typename and the SQL92 data-type (if possible) has been done +according to the following table: + + +---------------+------------------------------------+ + | typname | SQL92 | + |---------------+------------------------------------| + | bool | BOOL | + | text | / | + | bpchar | CHAR(n) | + | varchar | VARCHAR(n) | + | int2 | SMALLINT | + | int4 | INT | + | int8 | / | + | money | / | + | float4 | FLOAT(p) p<7=float4, p<16=float8 | + | float8 | REAL | + | abstime | / | + | reltime | / | + | tinterval | / | + | date | / | + | time | / | + | datetime | / | + | timespan | TINTERVAL | + | timestamp | TIMESTAMP | + +---------------+------------------------------------+ + +For further details concerning the PostgreSQL specific data-types please read +the L<pgbuiltin>. + +=item B<type_info> + + @type_info = $dbh->type_info($data_type); + +Implemented by DBI, no driver-specific impact. + +=item B<quote> + + $sql = $dbh->quote($value, $data_type); + +This module implements its own quote method. In addition to the DBI method it +also doubles the backslash, because PostgreSQL treats a backslash as an escape +character. + +B<NOTE:> The undocumented (and invalid) support for the C<SQL_BINARY> data +type is officially deprecated. Use C<PG_BYTEA> with C<bind_param()> instead: + + $rv = $sth->bind_param($param_num, $bind_value, + { pg_type => DBD::Pg::PG_BYTEA }); + +=back + +=head2 Database Handle Attributes + +=over 4 + +=item B<AutoCommit> (boolean) + +Supported by the driver as proposed by DBI. According to the classification of +DBI, PostgreSQL is a database, in which a transaction must be explicitly +started. Without starting a transaction, every change to the database becomes +immediately permanent. The default of AutoCommit is on, which corresponds to +the default behavior of PostgreSQL. When setting AutoCommit to off, a +transaction will be started and every commit or rollback will automatically +start a new transaction. For details see the notes about B<Transactions> +elsewhere in this document. + +=item B<Driver> (handle) + +Implemented by DBI, no driver-specific impact. + +=item B<Name> (string, read-only) + +The default method of DBI is overridden by a driver specific method, which +returns only the database name. Anything else from the connection string is +stripped off. Note, that here the method is read-only in contrast to the DBI +specs. + +=item B<RowCacheSize> (integer) + +Implemented by DBI, not used by the driver. + +=item B<pg_auto_escape> (boolean) + +PostgreSQL specific attribute. If true, then quotes and backslashes in all +parameters will be escaped in the following way: + + escape quote with a quote (SQL) + escape backslash with a backslash + +The default is on. Note, that PostgreSQL also accepts quotes, which are +escaped by a backslash. Any other ASCII character can be used directly in a +string constant. + +=item B<pg_enable_utf8> (boolean) + +PostgreSQL specific attribute. If true, then the utf8 flag will be +turned for returned character data (if the data is valid utf8). For +details about the utf8 flag, see L<Encode>. This is only relevant under +perl 5.8 and higher. + +B<NB>: This attribute is experimental and may be subject to change. + +=item B<pg_INV_READ> (integer, read-only) + +Constant to be used for the mode in lo_creat and lo_open. + +=item B<pg_INV_WRITE> (integer, read-only) + +Constant to be used for the mode in lo_creat and lo_open. + +=back + +=head1 DBI STATEMENT HANDLE OBJECTS + +=head2 Statement Handle Methods + +=over 4 + +=item B<bind_param> + + $rv = $sth->bind_param($param_num, $bind_value, \%attr); + +Supported by the driver as proposed by DBI. + +B<NOTE:> The undocumented (and invalid) support for the C<SQL_BINARY> +SQL type is officially deprecated. Use C<PG_BYTEA> instead: + + $rv = $sth->bind_param($param_num, $bind_value, + { pg_type => DBD::Pg::PG_BYTEA }); + +=item B<bind_param_inout> + +Not supported by this driver. + +=item B<execute> + + $rv = $sth->execute(@bind_values); + +Supported by the driver as proposed by DBI. In addition to 'UPDATE', 'DELETE', +'INSERT' statements, for which it returns always the number of affected rows, +the execute method can also be used for 'SELECT ... INTO table' statements. + +=item B<fetchrow_arrayref> + + $ary_ref = $sth->fetchrow_arrayref; + +Supported by the driver as proposed by DBI. + +=item B<fetchrow_array> + + @ary = $sth->fetchrow_array; + +Supported by the driver as proposed by DBI. + +=item B<fetchrow_hashref> + + $hash_ref = $sth->fetchrow_hashref; + +Supported by the driver as proposed by DBI. + +=item B<fetchall_arrayref> + + $tbl_ary_ref = $sth->fetchall_arrayref; + +Implemented by DBI, no driver-specific impact. + +=item B<finish> + + $rc = $sth->finish; + +Supported by the driver as proposed by DBI. + +=item B<rows> + + $rv = $sth->rows; + +Supported by the driver as proposed by DBI. In contrast to many other drivers +the number of rows is available immediately after executing the statement. + +=item B<bind_col> + + $rc = $sth->bind_col($column_number, \$var_to_bind, \%attr); + +Supported by the driver as proposed by DBI. + +=item B<bind_columns> + + $rc = $sth->bind_columns(\%attr, @list_of_refs_to_vars_to_bind); + +Supported by the driver as proposed by DBI. + +=item B<dump_results> + + $rows = $sth->dump_results($maxlen, $lsep, $fsep, $fh); + +Implemented by DBI, no driver-specific impact. + +=item B<blob_read> + + $blob = $sth->blob_read($id, $offset, $len); + +Supported by this driver as proposed by DBI. Implemented by DBI but not +documented, so this method might change. + +This method seems to be heavily influenced by the current implementation of +blobs in Oracle. Nevertheless we try to be as compatible as possible. Whereas +Oracle suffers from the limitation that blobs are related to tables and every +table can have only one blob (data-type LONG), PostgreSQL handles its blobs +independent of any table by using so called object identifiers. This explains +why the blob_read method is blessed into the STATEMENT package and not part of +the DATABASE package. Here the field parameter has been used to handle this +object identifier. The offset and len parameter may be set to zero, in which +case the driver fetches the whole blob at once. + +Starting with PostgreSQL-6.5 every access to a blob has to be put into a +transaction. This holds even for a read-only access. + +See also the PostgreSQL-specific functions concerning blobs which are +available via the func-interface. + +For further information and examples about blobs, please read the chapter +about Large Objects in the PostgreSQL Programmer's Guide. + +=back + +=head2 Statement Handle Attributes + +=over 4 + +=item B<NUM_OF_FIELDS> (integer, read-only) + +Implemented by DBI, no driver-specific impact. + +=item B<NUM_OF_PARAMS> (integer, read-only) + +Implemented by DBI, no driver-specific impact. + +=item B<NAME> (array-ref, read-only) + +Supported by the driver as proposed by DBI. + +=item B<NAME_lc> (array-ref, read-only) + +Implemented by DBI, no driver-specific impact. + +=item B<NAME_uc> (array-ref, read-only) + +Implemented by DBI, no driver-specific impact. + +=item B<TYPE> (array-ref, read-only) + +Supported by the driver as proposed by DBI, with the restriction, that the +types are PostgreSQL specific data-types which do not correspond to +international standards. + +=item B<PRECISION> (array-ref, read-only) + +Not supported by the driver. + +=item B<SCALE> (array-ref, read-only) + +Not supported by the driver. + +=item B<NULLABLE> (array-ref, read-only) + +Not supported by the driver. + +=item B<CursorName> (string, read-only) + +Not supported by the driver. See the note about B<Cursors> elsewhere in this +document. + +=item B<Statement> (string, read-only) + +Supported by the driver as proposed by DBI. + +=item B<RowCache> (integer, read-only) + +Not supported by the driver. + +=item B<pg_size> (array-ref, read-only) + +PostgreSQL specific attribute. It returns a reference to an array of integer +values for each column. The integer shows the size of the column in +bytes. Variable length columns are indicated by -1. + +=item B<pg_type> (hash-ref, read-only) + +PostgreSQL specific attribute. It returns a reference to an array of strings +for each column. The string shows the name of the data_type. + +=item B<pg_oid_status> (integer, read-only) + +PostgreSQL specific attribute. It returns the OID of the last INSERT command. + +=item B<pg_cmd_status> (integer, read-only) + +PostgreSQL specific attribute. It returns the type of the last +command. Possible types are: INSERT, DELETE, UPDATE, SELECT. + +=back + +=head1 FURTHER INFORMATION + +=head2 Transactions + +The transaction behavior is now controlled with the attribute AutoCommit. For +a complete definition of AutoCommit please refer to the DBI documentation. + +According to the DBI specification the default for AutoCommit is TRUE. In this +mode, any change to the database becomes valid immediately. Any 'begin', +'commit' or 'rollback' statement will be rejected. + +If AutoCommit is switched-off, immediately a transaction will be started by +issuing a 'begin' statement. Any 'commit' or 'rollback' will start a new +transaction. A disconnect will issue a 'rollback' statement. + +=head2 Large Objects + +The driver supports all large-objects related functions provided by libpq via +the func-interface. Please note, that starting with PostgreSQL 6.5 any access +to a large object - even read-only - has to be put into a transaction! + +=head2 Cursors + +Although PostgreSQL has a cursor concept, it has not been used in the current +implementation. Cursors in PostgreSQL can only be used inside a transaction +block. Because only one transaction block at a time is allowed, this would +have implied the restriction, not to use any nested SELECT statements. Hence +the execute method fetches all data at once into data structures located in +the frontend application. This has to be considered when selecting large +amounts of data! + +=head2 Data-Type bool + +The current implementation of PostgreSQL returns 't' for true and 'f' for +false. From the Perl point of view a rather unfortunate choice. The DBD::Pg +module translates the result for the data-type bool in a perl-ish like manner: +'f' -> '0' and 't' -> '1'. This way the application does not have to check the +database-specific returned values for the data-type bool, because Perl treats +'0' as false and '1' as true. + +Boolean values can be passed to PostgreSQL as TRUE, 't', 'true', 'y', 'yes' or +'1' for true and FALSE, 'f', 'false', 'n', 'no' or '0' for false. + +=head2 Schema support + +PostgreSQL version 7.3 introduced schema support. Note that the PostgreSQL +schema concept may differ to that of other databases. Please refer to the +PostgreSQL documentation for more details. + +Currently DBD::Pg does not provide explicit support for PostgreSQL schemas. +However, schema functionality may be used without any restrictions by +explicitly addressing schema objects, e.g. + + my $res = $dbh->selectall_arrayref("SELECT * FROM my_schema.my_table"); + +or by manipulating the schema search path with SET search_path, e.g. + + $dbh->do("SET search_path TO my_schema, public"); + +B<NOTE:> If you create an object with the same name as a PostgreSQL system +object (as contained in the pg_catalog schema) and explicitly set the search +path so that pg_catalog comes after the new object's schema, some DBD::Pg +methods (particularly those querying PostgreSQL system objects) may fail. +This problem should be fixed in a future release of DBD::Pg. Creating objects +with the same name as system objects (or beginning with 'pg_') is not +recommended practice and should be avoided in any case. + +=head1 SEE ALSO + +L<DBI> + +=head1 AUTHORS + +DBI and DBD-Oracle by Tim Bunce (Tim.Bunce@ig.co.uk) + +DBD-Pg by Edmund Mergl (E.Mergl@bawue.de) and Jeffrey W. Baker +(jwbaker@acm.org). By David Wheeler <david@wheeler.net>, Jason +Stewart <jason@openinformatics.com> and Bruce Momjian +<pgman@candle.pha.pa.us> after v1.13. + +Major parts of this package have been copied from DBI and DBD-Oracle. + +=head1 COPYRIGHT + +The DBD::Pg module is free software. You may distribute under the terms of +either the GNU General Public License or the Artistic License, as specified in +the Perl README file. + +=head1 ACKNOWLEDGMENTS + +See also B<DBI/ACKNOWLEDGMENTS>. + +=cut + diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/Pg.xs b/install/5.005/DBD-Pg-1.22-fixvercmp/Pg.xs new file mode 100644 index 0000000..e5e4362 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/Pg.xs @@ -0,0 +1,644 @@ +/* + $Id: Pg.xs,v 1.1 2004-04-29 09:21:28 ivan Exp $ + + Copyright (c) 1997,1998,1999,2000 Edmund Mergl + Portions Copyright (c) 1994,1995,1996,1997 Tim Bunce + + You may distribute under the terms of either the GNU General Public + License or the Artistic License, as specified in the Perl README file. + +*/ + + +#include "Pg.h" + + +#ifdef _MSC_VER +#define strncasecmp(a,b,c) _strnicmp((a),(b),(c)) +#endif + + + +DBISTATE_DECLARE; + + +MODULE = DBD::Pg PACKAGE = DBD::Pg + +I32 +constant(name=Nullch) + char *name + PROTOTYPE: + ALIAS: + PG_BOOL = 16 + PG_BYTEA = 17 + PG_CHAR = 18 + PG_INT8 = 20 + PG_INT2 = 21 + PG_INT4 = 23 + PG_TEXT = 25 + PG_OID = 26 + PG_FLOAT4 = 700 + PG_FLOAT8 = 701 + PG_ABSTIME = 702 + PG_RELTIME = 703 + PG_TINTERVAL = 704 + PG_BPCHAR = 1042 + PG_VARCHAR = 1043 + PG_DATE = 1082 + PG_TIME = 1083 + PG_DATETIME = 1184 + PG_TIMESPAN = 1186 + PG_TIMESTAMP = 1296 + CODE: + if (!ix) { + if (!name) name = GvNAME(CvGV(cv)); + croak("Unknown DBD::Pg constant '%s'", name); + } + else RETVAL = ix; + OUTPUT: + RETVAL + +PROTOTYPES: DISABLE + +BOOT: + items = 0; /* avoid 'unused variable' warning */ + DBISTATE_INIT; + /* XXX this interface will change: */ + DBI_IMP_SIZE("DBD::Pg::dr::imp_data_size", sizeof(imp_drh_t)); + DBI_IMP_SIZE("DBD::Pg::db::imp_data_size", sizeof(imp_dbh_t)); + DBI_IMP_SIZE("DBD::Pg::st::imp_data_size", sizeof(imp_sth_t)); + dbd_init(DBIS); + + +# ------------------------------------------------------------ +# driver level interface +# ------------------------------------------------------------ +MODULE = DBD::Pg PACKAGE = DBD::Pg::dr + +# disconnect_all renamed and ALIASed to avoid length clash on VMS :-( +void +discon_all_(drh) + SV * drh + ALIAS: + disconnect_all = 1 + CODE: + D_imp_drh(drh); + ST(0) = dbd_discon_all(drh, imp_drh) ? &sv_yes : &sv_no; + + + +# ------------------------------------------------------------ +# database level interface +# ------------------------------------------------------------ +MODULE = DBD::Pg PACKAGE = DBD::Pg::db + +void +_login(dbh, dbname, username, pwd) + SV * dbh + char * dbname + char * username + char * pwd + CODE: + D_imp_dbh(dbh); + ST(0) = pg_db_login(dbh, imp_dbh, dbname, username, pwd) ? &sv_yes : &sv_no; + + +int +_ping(dbh) + SV * dbh + CODE: + int ret; + ret = dbd_db_ping(dbh); + if (ret == 0) { + XST_mUNDEF(0); + } + else { + XST_mIV(0, ret); + } + +void +getfd(dbh) + SV * dbh + CODE: + int ret; + D_imp_dbh(dbh); + + ret = dbd_db_getfd(dbh, imp_dbh); + ST(0) = sv_2mortal( newSViv( ret ) ); + +void +pg_notifies(dbh) + SV * dbh + CODE: + D_imp_dbh(dbh); + + ST(0) = dbd_db_pg_notifies(dbh, imp_dbh); + +void +commit(dbh) + SV * dbh + CODE: + D_imp_dbh(dbh); + if (DBIc_has(imp_dbh, DBIcf_AutoCommit)) { + warn("commit ineffective with AutoCommit enabled"); + } + ST(0) = dbd_db_commit(dbh, imp_dbh) ? &sv_yes : &sv_no; + + +void +rollback(dbh) + SV * dbh + CODE: + D_imp_dbh(dbh); + if (DBIc_has(imp_dbh, DBIcf_AutoCommit)) { + warn("rollback ineffective with AutoCommit enabled"); + } + ST(0) = dbd_db_rollback(dbh, imp_dbh) ? &sv_yes : &sv_no; + + +void +disconnect(dbh) + SV * dbh + CODE: + D_imp_dbh(dbh); + if ( !DBIc_ACTIVE(imp_dbh) ) { + XSRETURN_YES; + } + /* pre-disconnect checks and tidy-ups */ + if (DBIc_CACHED_KIDS(imp_dbh)) { + SvREFCNT_dec(DBIc_CACHED_KIDS(imp_dbh)); + DBIc_CACHED_KIDS(imp_dbh) = Nullhv; + } + /* Check for disconnect() being called whilst refs to cursors */ + /* still exists. This possibly needs some more thought. */ + if (DBIc_ACTIVE_KIDS(imp_dbh) && DBIc_WARN(imp_dbh) && !dirty) { + char *plural = (DBIc_ACTIVE_KIDS(imp_dbh)==1) ? "" : "s"; + warn("disconnect(%s) invalidates %d active statement%s. %s", + SvPV(dbh,na), (int)DBIc_ACTIVE_KIDS(imp_dbh), plural, + "Either destroy statement handles or call finish on them before disconnecting."); + } + ST(0) = dbd_db_disconnect(dbh, imp_dbh) ? &sv_yes : &sv_no; + + +void +STORE(dbh, keysv, valuesv) + SV * dbh + SV * keysv + SV * valuesv + CODE: + D_imp_dbh(dbh); + ST(0) = &sv_yes; + if (!dbd_db_STORE_attrib(dbh, imp_dbh, keysv, valuesv)) { + if (!DBIS->set_attr(dbh, keysv, valuesv)) { + ST(0) = &sv_no; + } + } + + +void +FETCH(dbh, keysv) + SV * dbh + SV * keysv + CODE: + D_imp_dbh(dbh); + SV *valuesv = dbd_db_FETCH_attrib(dbh, imp_dbh, keysv); + if (!valuesv) { + valuesv = DBIS->get_attr(dbh, keysv); + } + ST(0) = valuesv; /* dbd_db_FETCH_attrib did sv_2mortal */ + + +void +DESTROY(dbh) + SV * dbh + PPCODE: + D_imp_dbh(dbh); + ST(0) = &sv_yes; + if (!DBIc_IMPSET(imp_dbh)) { /* was never fully set up */ + if (DBIc_WARN(imp_dbh) && !dirty && dbis->debug >= 2) { + warn("Database handle %s DESTROY ignored - never set up", SvPV(dbh,na)); + } + } + else { + /* pre-disconnect checks and tidy-ups */ + if (DBIc_CACHED_KIDS(imp_dbh)) { + SvREFCNT_dec(DBIc_CACHED_KIDS(imp_dbh)); + DBIc_CACHED_KIDS(imp_dbh) = Nullhv; + } + if (DBIc_IADESTROY(imp_dbh)) { /* want's ineffective destroy */ + DBIc_ACTIVE_off(imp_dbh); + } + if (DBIc_ACTIVE(imp_dbh)) { + if (DBIc_WARN(imp_dbh) && (!dirty || dbis->debug >= 3)) { + warn("Database handle destroyed without explicit disconnect"); + } + /* The application has not explicitly disconnected. That's bad. */ + /* To ensure integrity we *must* issue a rollback. This will be */ + /* harmless if the application has issued a commit. If it hasn't */ + /* then it'll ensure integrity. Consider a Ctrl-C killing perl */ + /* between two statements that must be executed as a transaction. */ + /* Perl will call DESTROY on the dbh and, if we don't rollback, */ + /* the server will automatically commit! Bham! Corrupt database! */ + if (!DBIc_has(imp_dbh,DBIcf_AutoCommit)) { + dbd_db_rollback(dbh, imp_dbh); /* ROLLBACK! */ + } + dbd_db_disconnect(dbh, imp_dbh); + } + dbd_db_destroy(dbh, imp_dbh); + } + + +# driver specific functions + + +void +lo_open(dbh, lobjId, mode) + SV * dbh + unsigned int lobjId + int mode + CODE: + int ret = pg_db_lo_open(dbh, lobjId, mode); + ST(0) = (-1 != ret) ? sv_2mortal(newSViv(ret)) : &sv_undef; + +void +lo_close(dbh, fd) + SV * dbh + int fd + CODE: + ST(0) = (-1 != pg_db_lo_close(dbh, fd)) ? &sv_yes : &sv_no; + + +void +lo_read(dbh, fd, buf, len) + SV * dbh + int fd + char * buf + int len + PREINIT: + SV *bufsv = SvROK(ST(2)) ? SvRV(ST(2)) : ST(2); + int ret; + CODE: + buf = SvGROW(bufsv, len + 1); + ret = pg_db_lo_read(dbh, fd, buf, len); + if (ret > 0) { + SvCUR_set(bufsv, ret); + *SvEND(bufsv) = '\0'; + sv_setpvn(ST(2), buf, ret); + SvSETMAGIC(ST(2)); + } + ST(0) = (-1 != ret) ? sv_2mortal(newSViv(ret)) : &sv_undef; + + +void +lo_write(dbh, fd, buf, len) + SV * dbh + int fd + char * buf + int len + CODE: + int ret = pg_db_lo_write(dbh, fd, buf, len); + ST(0) = (-1 != ret) ? sv_2mortal(newSViv(ret)) : &sv_undef; + + +void +lo_lseek(dbh, fd, offset, whence) + SV * dbh + int fd + int offset + int whence + CODE: + int ret = pg_db_lo_lseek(dbh, fd, offset, whence); + ST(0) = (-1 != ret) ? sv_2mortal(newSViv(ret)) : &sv_undef; + + +void +lo_creat(dbh, mode) + SV * dbh + int mode + CODE: + int ret = pg_db_lo_creat(dbh, mode); + ST(0) = (-1 != ret) ? sv_2mortal(newSViv(ret)) : &sv_undef; + + +void +lo_tell(dbh, fd) + SV * dbh + int fd + CODE: + int ret = pg_db_lo_tell(dbh, fd); + ST(0) = (-1 != ret) ? sv_2mortal(newSViv(ret)) : &sv_undef; + + +void +lo_unlink(dbh, lobjId) + SV * dbh + unsigned int lobjId + CODE: + ST(0) = (-1 != pg_db_lo_unlink(dbh, lobjId)) ? &sv_yes : &sv_no; + + +void +lo_import(dbh, filename) + SV * dbh + char * filename + CODE: + unsigned int ret = pg_db_lo_import(dbh, filename); + ST(0) = (ret) ? sv_2mortal(newSViv(ret)) : &sv_undef; + + +void +lo_export(dbh, lobjId, filename) + SV * dbh + unsigned int lobjId + char * filename + CODE: + ST(0) = (-1 != pg_db_lo_export(dbh, lobjId, filename)) ? &sv_yes : &sv_no; + + +void +putline(dbh, buf) + SV * dbh + char * buf + CODE: + int ret = pg_db_putline(dbh, buf); + ST(0) = (-1 != ret) ? &sv_yes : &sv_no; + + +void +getline(dbh, buf, len) + PREINIT: + SV *bufsv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1); + INPUT: + SV * dbh + int len + char * buf = sv_grow(bufsv, len); + CODE: + int ret = pg_db_getline(dbh, buf, len); + if (*buf == '\\' && *(buf+1) == '.') { + ret = -1; + } + sv_setpv((SV*)ST(1), buf); + SvSETMAGIC(ST(1)); + ST(0) = (-1 != ret) ? &sv_yes : &sv_no; + + +void +endcopy(dbh) + SV * dbh + CODE: + ST(0) = (-1 != pg_db_endcopy(dbh)) ? &sv_yes : &sv_no; + + +# -- end of DBD::Pg::db + + +# ------------------------------------------------------------ +# statement interface +# ------------------------------------------------------------ +MODULE = DBD::Pg PACKAGE = DBD::Pg::st + +void +_prepare(sth, statement, attribs=Nullsv) + SV * sth + char * statement + SV * attribs + CODE: + { + D_imp_sth(sth); + D_imp_dbh_from_sth; + DBD_ATTRIBS_CHECK("_prepare", sth, attribs); + if (!strncasecmp(statement, "begin", 5) || + !strncasecmp(statement, "end", 4) || + !strncasecmp(statement, "commit", 6) || + !strncasecmp(statement, "abort", 5) || + !strncasecmp(statement, "rollback", 8) ) { + warn("please use DBI functions for transaction handling"); + ST(0) = &sv_no; + } else { + ST(0) = dbd_st_prepare(sth, imp_sth, statement, attribs) ? &sv_yes : &sv_no; + } + } + + +void +rows(sth) + SV * sth + CODE: + D_imp_sth(sth); + XST_mIV(0, dbd_st_rows(sth, imp_sth)); + + +void +bind_param(sth, param, value, attribs=Nullsv) + SV * sth + SV * param + SV * value + SV * attribs + CODE: + { + IV sql_type = 0; + D_imp_sth(sth); + if (attribs) { + if (SvNIOK(attribs)) { + sql_type = SvIV(attribs); + attribs = Nullsv; + } + else { + SV **svp; + DBD_ATTRIBS_CHECK("bind_param", sth, attribs); + /* XXX we should perhaps complain if TYPE is not SvNIOK */ + DBD_ATTRIB_GET_IV(attribs, "TYPE", 4, svp, sql_type); + } + } + ST(0) = dbd_bind_ph(sth, imp_sth, param, value, sql_type, attribs, FALSE, 0) ? &sv_yes : &sv_no; + } + + +void +bind_param_inout(sth, param, value_ref, maxlen, attribs=Nullsv) + SV * sth + SV * param + SV * value_ref + IV maxlen + SV * attribs + CODE: + { + IV sql_type = 0; + D_imp_sth(sth); + if (!SvROK(value_ref) || SvTYPE(SvRV(value_ref)) > SVt_PVMG) { + croak("bind_param_inout needs a reference to a scalar value"); + } + if (SvREADONLY(SvRV(value_ref))) { + croak(no_modify); + } + if (attribs) { + if (SvNIOK(attribs)) { + sql_type = SvIV(attribs); + attribs = Nullsv; + } + else { + SV **svp; + DBD_ATTRIBS_CHECK("bind_param", sth, attribs); + DBD_ATTRIB_GET_IV(attribs, "TYPE", 4, svp, sql_type); + } + } + ST(0) = dbd_bind_ph(sth, imp_sth, param, SvRV(value_ref), sql_type, attribs, TRUE, maxlen) ? &sv_yes : &sv_no; + } + + +void +execute(sth, ...) + SV * sth + CODE: + D_imp_sth(sth); + int ret; + if (items > 1) { + /* Handle binding supplied values to placeholders */ + int i; + SV *idx; + imp_sth->all_params_len = 0; /* used for malloc of statement string in case we have placeholders */ + if (items-1 != DBIc_NUM_PARAMS(imp_sth)) { + croak("execute called with %ld bind variables, %d needed", items-1, DBIc_NUM_PARAMS(imp_sth)); + XSRETURN_UNDEF; + } + idx = sv_2mortal(newSViv(0)); + for(i=1; i < items ; ++i) { + sv_setiv(idx, i); + if (!dbd_bind_ph(sth, imp_sth, idx, ST(i), 0, Nullsv, FALSE, 0)) { + XSRETURN_UNDEF; /* dbd_bind_ph already registered error */ + } + } + } + ret = dbd_st_execute(sth, imp_sth); + /* remember that dbd_st_execute must return <= -2 for error */ + if (ret == 0) { /* ok with no rows affected */ + XST_mPV(0, "0E0"); /* (true but zero) */ + } + else if (ret < -1) { /* -1 == unknown number of rows */ + XST_mUNDEF(0); /* <= -2 means error */ + } + else { + XST_mIV(0, ret); /* typically 1, rowcount or -1 */ + } + + +void +fetchrow_arrayref(sth) + SV * sth + ALIAS: + fetch = 1 + CODE: + D_imp_sth(sth); + AV *av = dbd_st_fetch(sth, imp_sth); + ST(0) = (av) ? sv_2mortal(newRV_inc((SV *)av)) : &sv_undef; + + +void +fetchrow_array(sth) + SV * sth + ALIAS: + fetchrow = 1 + PPCODE: + D_imp_sth(sth); + AV *av; + av = dbd_st_fetch(sth, imp_sth); + if (av) { + int num_fields = AvFILL(av)+1; + int i; + EXTEND(sp, num_fields); + for(i=0; i < num_fields; ++i) { + PUSHs(AvARRAY(av)[i]); + } + } + + +void +finish(sth) + SV * sth + CODE: + D_imp_sth(sth); + D_imp_dbh_from_sth; + if (!DBIc_ACTIVE(imp_dbh)) { + /* Either an explicit disconnect() or global destruction */ + /* has disconnected us from the database. Finish is meaningless */ + /* XXX warn */ + XSRETURN_YES; + } + if (!DBIc_ACTIVE(imp_sth)) { + /* No active statement to finish */ + XSRETURN_YES; + } + ST(0) = dbd_st_finish(sth, imp_sth) ? &sv_yes : &sv_no; + + +void +blob_read(sth, field, offset, len, destrv=Nullsv, destoffset=0) + SV * sth + int field + long offset + long len + SV * destrv + long destoffset + CODE: + { + D_imp_sth(sth); + if (!destrv) { + destrv = sv_2mortal(newRV_inc(sv_2mortal(newSViv(0)))); + } + ST(0) = dbd_st_blob_read(sth, imp_sth, field, offset, len, destrv, destoffset) ? SvRV(destrv) : &sv_undef; + } + +void +STORE(sth, keysv, valuesv) + SV * sth + SV * keysv + SV * valuesv + CODE: + D_imp_sth(sth); + ST(0) = &sv_yes; + if (!dbd_st_STORE_attrib(sth, imp_sth, keysv, valuesv)) { + if (!DBIS->set_attr(sth, keysv, valuesv)) { + ST(0) = &sv_no; + } + } + + +# FETCH renamed and ALIASed to avoid case clash on VMS :-( +void +FETCH_attrib(sth, keysv) + SV * sth + SV * keysv + ALIAS: + FETCH = 1 + CODE: + D_imp_sth(sth); + SV *valuesv = dbd_st_FETCH_attrib(sth, imp_sth, keysv); + if (!valuesv) { + valuesv = DBIS->get_attr(sth, keysv); + } + ST(0) = valuesv; /* dbd_st_FETCH_attrib did sv_2mortal */ + + +void +DESTROY(sth) + SV * sth + PPCODE: + D_imp_sth(sth); + ST(0) = &sv_yes; + if (!DBIc_IMPSET(imp_sth)) { /* was never fully set up */ + if (DBIc_WARN(imp_sth) && !dirty && dbis->debug >= 2) { + warn("Statement handle %s DESTROY ignored - never set up", SvPV(sth,na)); + } + } + else { + if (DBIc_IADESTROY(imp_sth)) { /* want's ineffective destroy */ + DBIc_ACTIVE_off(imp_sth); + } + if (DBIc_ACTIVE(imp_sth)) { + dbd_st_finish(sth, imp_sth); + } + dbd_st_destroy(sth, imp_sth); + } + + +# end of Pg.xs diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/README b/install/5.005/DBD-Pg-1.22-fixvercmp/README new file mode 100644 index 0000000..7edebde --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/README @@ -0,0 +1,166 @@ + +DBD::Pg -- the DBI PostgreSQL interface for Perl + +# $Id: README,v 1.1 2004-04-29 09:21:28 ivan Exp $ + +DESCRIPTION: +------------ + +This is version 1.21 of DBD-Pg. The web site for this interface is at: + + http://gborg.postgresql.org/project/dbdpg/projdisplay.php + +For further information about DBI look at: + + http://dbi.perl.org/ + +For information about PostgreSQL, visit: + + http://www.postgresql.org/ + +COPYRIGHT: +---------- + + Portions Copyright (c) 1994,1995,1996,1997 Tim Bunce + Copyright (c) 1997,1998,1999,2000 Edmund Mergl + Copyright (c) 2002 Jeffrey W. Baker + Copyright (c) 2002 PostgreSQL Global Development Group + +You may distribute under the terms of either the GNU General Public +License or the Artistic License, as specified in the Perl README file. + + +HOW TO GET THE LATEST VERSION: +------------------------------ + +Use the following URL to look for new versions of this module: + + http://gborg.postgresql.org/project/dbdpg/projdisplay.php + +or + + http://www.perl.com/CPAN/modules/by-module/DBD/ + +Note, that this request will be redirected automatically to the +nearest CPAN site. + + +IF YOU HAVE PROBLEMS: +--------------------- + +Please send comments and bug-reports to <dbd-general@gborg.postgresql.org> + +Please include the output of perl -v and perl -V, the version of PostgreSQL, +the version of DBD-Pg, the version of DBI, and details about your platform +in your bug-report. + + +REQUIREMENTS: +------------- + + build, test, and install Perl 5 (at least 5.005) + build, test, and install the DBI module (at least 1.30) + build, test, and install PostgreSQL (at least 7.3) + build, test, and install Test::Simple (at least 0.17) + +INSTALLATION: +------------- + +By default Makefile.PL uses App:Info to find the location of the +PostgreSQL library and include directories. However, if you want to +control it yourself, define the environment variables POSTGRES_INCLUDE +and POSTGRES_LIB, or POSTGRES_HOME. + + 1. perl Makefile.PL + 2. make + 3. make test + 4. make install + +Do steps 1 to 3 as normal user, not as root! + + +TESTING: +-------- + +The tests are designed to connect to a live database. The following +environment variables must be set for the tests to run: + + DBI_DSN=dbi:Pg:dbname=<database> + DBI_USER=<username> + DBI_PASS=<password> + +If you are using the shared library libpq.so check if your dynamic +loader finds libpq.so. With Linux the command /sbin/ldconfig -v should +tell you, where it finds libpq.so. If ldconfig does not find libpq.so, +either add an appropriate entry to /etc/ld.so.conf and re-run ldconfig +or add the path to the environment variable LD_LIBRARY_PATH. + +A typical error message resulting from not finding libpq.so is: + + install_driver(Pg) failed: Can't load './blib/arch/auto/DBD/Pg/Pg.so' + for module DBD::Pg: File not found at + +If you get an error message like: + + perl: error while loading shared libraries: + /usr/lib/perl5/site_perl/5.6.0/i386-linux/auto/DBD/Pg/Pg.so: undefined + symbol: PQconnectdb + +when you call DBI->connect, then your libpq.so was probably not seen at +build-time. This should have caused 'make test' to fail; did you really +run it and look at the output? Check the setting of POSTGRES_LIB and +recompile DBD-Pg. + +Some linux distributions have incomplete perl installations. If you have +compile errors like "XS_VERSION_BOOTCHECK undeclared", do: + + find .../lib/perl5 -name XSUB.h -print + +If this file is not present, you need to recompile and re-install perl. + +SGI users: if you get segmentation faults make sure, you use the malloc +which comes with perl when compiling perl (the default is not to). +"David R. Noble" <drnoble@engsci.sandia.gov> + +HP users: if you get error messages like: + + can't open shared library: .../lib/libpq.sl + No such file or directory + +when running the test script, try to replace the 'shared' option in the +LDDFLAGS with 'archive'. Dan Lauterbach <danla@dimensional.com> + + +FreeBSD users: if you get during make test the error message: + + 'DBD driver has not implemented the AutoCommit attribute' + +recompile the DBI module and the DBD-Pg module and disable optimization. +This error message is due to the broken optimization in gcc-2.7.2.1. + +If you get compiler errors like: + In function `XS_DBD__Pg__dr_discon_all_' + `sv_yes' undeclared (first use in this function) + +It may be because there is a 'patchlevel.h' file from another package +(such as 'hdf') in your POSTGRES_INCLUDE dir. The presence of this file +prevents the compiler from finding the perl include file +'mach/CORE/patchlevel.h'. Do 'pg_config --includedir' to identify the +POSTGRES_INCLUDE dir. Rename patchlevel.h whilst you build DBD::Pg. + + +Sun Users: if you get compile errors like: + + /usr/include/string.h:57: parse error before `]' + +then you need to remove from pgsql/include/libpq-fe.h the define for +strerror, which clashes with the definition in the standard include +file. + +Win32 Users: Running DBD-Pg scripts on Win32 needs some configuration work +on the server side: + + o add a postgres user with the same name as the NT-User + (eg Administrator) + o make sure, that your pg_hba.conf on the server is configured, + such that a connection from another host will be accepted diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/README.win32 b/install/5.005/DBD-Pg-1.22-fixvercmp/README.win32 new file mode 100644 index 0000000..3cbe673 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/README.win32 @@ -0,0 +1,63 @@ + +$Id: README.win32,v 1.1 2004-04-29 09:21:28 ivan Exp $ + + +Here is a step-by-step procedure for getting DBD-Pg to work on Windows +NT. This Port has been done by Bob Kline <bkline@rksystems.com>. + + +prerequisites: (older versions might also work, but these are the +-------------- versions I used) + + o Windows NT4 SP4 + o Visual Studio 6.0 + o ActivePerl-5_6_0_613 with DBI-1.13 + o postgresql-7.0.2 + o DBD-Pg-0.95 + +Here we assume, that perl and postgresql have been installed in C:\. Now +perform the following steps: + + +1. compile libpq +---------------- + +set POSTGRES_HOME=C:\postgresql-7.0.2 +cd postgresql-7.0.2 +mkdir lib +mkdir include +cd src +copy include\port\win32.h include\os.h +edit interfaces\libpq\fe-connect.c and add as first statement in connectDBStart() the following code: + #ifdef WIN32 + static int WeHaveCalledWSAStartup; + if (!WeHaveCalledWSAStartup) { + WSADATA wsaData; + if (WSAStartup(MAKEWORD(1, 1), &wsaData)) { + printfPQExpBuffer(&conn->errorMessage, "WSAStartup failed: errno=%d\n", h_errno); + goto connect_errReturn; + } + WeHaveCalledWSAStartup = 1; + } + #endif +edit interfaces\libpq\win32.mak and change the flag /ML to /MD: CPP_PROJ=/nologo /MD ... +nmake /f win32.mak +cd .. +copy src\interfaces\libpq\Release\libpq.lib lib +copy src\interfaces\libpq\libpq-fe.h include +copy src\include\postgres_ext.h include +cd .. + + +2. build DBD-Pg +--------------- + +cd DBD-Pg +perl Makefile.PL CAPI=TRUE +nmake +set the environment variable PGHOST to the name of the postgresql server: set PGHOST=myserver +add on the server a postgres user with the same name as the NT-User (eg Administrator) +make sure, that your pg_hba.conf on the server is configured, such that a connection from another host will be accepted +mkdir C:\tmp +nmake test (expect to get errors concerning blobs) +nmake install diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/dbd-pg.pod b/install/5.005/DBD-Pg-1.22-fixvercmp/dbd-pg.pod new file mode 100644 index 0000000..ccbbc63 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/dbd-pg.pod @@ -0,0 +1,411 @@ + +# $Id: dbd-pg.pod,v 1.1 2004-04-29 09:21:28 ivan Exp $ + +=head1 NAME + +DBD::Pg - PostgreSQL database driver for the DBI module + +=head1 DESCRIPTION + +DBD::Pg is a Perl module which works with the DBI module to provide +access to PostgreSQL databases. + +=head1 DBD::Pg + +=begin docbook +<!-- The following blank =head1 is to allow us to use purely =head2 headings --> +<!-- This keeps the POD fairly simple with regards to Pod::DocBook --> + +=end docbook + +=head1 + +=head2 Version + +Version 0.91. + +=head2 Author and Contact Details + +The driver author is Edmund Mergl. He can be contacted via the +I<dbi-users> mailing list. + + +=head2 Supported Database Versions and Options + +The DBD-Pg-0.92 module supports Postgresql 6.5. + + +=head2 Connect Syntax + +The C<DBI-E<gt>connect()> Data Source Name, or I<DSN>, can be one of the +following: + + dbi:Pg:dbname=$dbname + dbi:Pg:dbname=$dbname;host=$host;port=$port;options=$options;tty=$tty + +All parameters, including the userid and password parameter of the +connect command, have a hard-coded default which can be overridden +by setting appropriate environment variables: + + Parameter Environment Variable Default + --------- -------------------- -------------- + dbname PGDATABASE current userid + host PGHOST localhost + port PGPORT 5432 + options PGOPTIONS "" + tty PGTTY "" + username PGUSER current userid + password PGPASSWORD "" + +There are no driver specific attributes for the C<DBI->connect()> method. + + +=head2 Numeric Data Handling + +Postgresql supports the following numeric types: + + Postgresql Range + ---------- -------------------------- + int2 -32768 to +32767 + int4 -2147483648 to +2147483647 + float4 6 decimal places + float8 15 decimal places + +Some platforms also support the int8 type. +C<DBD::Pg> always returns all numbers as strings. + + +=head2 String Data Handling + +Postgresql supports the following string data types: + + CHAR single character + CHAR(size) fixed length blank-padded + VARCHAR(size) variable length with limit + TEXT variable length + +All string data types have a limit of 4096 bytes. +The CHAR type is fixed length and blank padded. + +There is no special handling for data with the 8th bit set. They +are stored unchanged in the database. +None of the character types can store embedded nulls and Unicode is +not formally supported. + +Strings can be concatenated using the C<||> operator. + + +=head2 Date Data Handling + +Postgresql supports the following date time data types: + + Type Storage Recommendation Description + --------- -------- -------------------------- ---------------------------- + abstime 4 bytes original date and time limited range + date 4 bytes SQL92 type wide range + datetime 8 bytes best general date and time wide range, high precision + interval 12 bytes SQL92 type equivalent to timespan + reltime 4 bytes original time interval limited range, low precision + time 4 bytes SQL92 type wide range + timespan 12 bytes best general time interval wide range, high precision + timestamp 4 bytes SQL92 type limited range + + Data Type Range Resolution + ---------- ---------------------------------- ----------- + abstime 1901-12-14 2038-01-19 1 sec + timestamp 1901-12-14 2038-01-19 1 sec + reltime -68 years +68 years 1 sec + tinterval -178000000 years +178000000 years 1 microsec + timespan -178000000 years 178000000 years 1 microsec + date 4713 BC 32767 AD 1 day + datetime 4713 BC 1465001 AD 1 microsec + time 00:00:00:00 23:59:59:99 1 microsec + +Postgresql supports a range of date formats: + + Name Example + ----------- ---------------------- + ISO 1997-12-17 0:37:16-08 + SQL 12/17/1997 07:37:16.00 PST + Postgres Wed Dec 17 07:37:16 1997 PST + European 17/12/1997 15:37:16.00 MET + NonEuropean 12/17/1997 15:37:16.00 MET + US 12/17/1997 07:37:16.00 MET + +The default output format does not depend on the client/server locale. +It depends on, in increasing priority: the PGDATESTYLE environment +variable at the server, the PGDATESTYLE environment variable at the client, and +the C<SET DATESTYLE> SQL command. + +All of the formats described above can be used for input. A great many +others can also be used. There is no specific default input format. +If the format of a date input is ambiguous then the current DATESTYLE +is used to help disambiguate. + +If you specify a date/time value without a time component, the default +time is 00:00:00 (midnight). To specify a date/time value without a date +is not allowed. +If a date with a two digit year is input then if the year was less than +70, add 2000; otherwise, add 1900. + +The currect date/time is returned by the keyword C<'now'> or C<'current'>, +which has to be casted to a valid data type. For example: + + SELECT 'now'::datetime + +Postgresql supports a range of date time functions for converting +between types, extracting parts of a date time value, truncating to a +given unit, etc. The usual arithmetic can be performed on date and +interval values, e.g., date-date=interval, etc. + +The following SQL expression can be used to convert an integer "seconds +since 1-jan-1970 GMT" value to the corresponding database date time: + + DATETIME(unixtime_field) + +and to do the reverse: + + DATE_PART('epoch', datetime_field) + +The server stores all dates internally in GMT. Times are converted to +local time on the database server before being sent to the client +frontend, hence by default are in the server time zone. + +The TZ environment variable is used by the server as default time +zone. The PGTZ environment variable on the client side is used to send +the time zone information to the backend upon connection. The SQL C<SET +TIME ZONE> command can set the time zone for the current session. + + +=head2 LONG/BLOB Data Handling + +Postgresql handles BLOBS using a so called "large objects" type. The +handling of this type differs from all other data types. The data are +broken into chunks, which are stored in tuples in the database. Access +to large objects is given by an interface which is modelled closely +after the UNIX file system. The maximum size is limited by the file +size of the operating system. + + +If you just select the field, you get a "large object identifier" and +not the data itself. The I<LongReadLen> and I<LongTruncOk> attributes are +not implemented because they don't make sense in this case. The only +method implemented by the driver is the undocumented DBI method +C<blob_read()>. + + +=head2 Other Data Handling issues + +The C<DBD::Pg> driver supports the C<type_info()> method. + +Postgresql supports automatic conversions between data types wherever +it's reasonable. + +=head2 Transactions, Isolation and Locking + +Postgresql supports transactions. +The current default isolation transaction level is "Serializable" and +is currently implemented using table level locks. Both may change. +No other isolation levels for transactions are supported. + +With AutoCommit on, a query never places a lock on a table. Readers +never block writers and writers never block readers. This behavior +changes whenever a transaction is started (AutoCommit off). Then a +query induces a shared lock on a table and blocks anyone else +until the transaction has been finished. + +The C<LOCK TABLE table_name> statement can be used to apply an explicit +lock on a table. This only works inside a transaction (AutoCommit off). + +To ensure that a table being selected does not change before you make +an update later in the transaction, you must explicitly lock it with a +C<LOCK TABLE> statement before executing the select. + + +=head2 No-Table Expression Select Syntax + +To select a constant expression, that is, an expression that doesn't involve +data from a database table or view, just omit the "from" clause. +Here's an example that selects the current time as a datetime: + + SELECT 'now'::datetime; + +=head2 Table Join Syntax + +Outer joins are not supported. Inner joins use the traditional syntax. + +=head2 Table and Column Names + +The max size of table and column names cannot exceed 31 charaters in +length. +Only alphanumeric characters can be used; the first character must +be a letter. + +If an identifier is enclosed by double quotation marks (C<">), it can +contain any combination of characters except double quotation marks. + +Postgresql converts all identifiers to lower-case unless enclosed in +double quotation marks. +National character set characters can be used, if enclosed in quotation +marks. + + +=head2 Case Sensitivity of LIKE Operator + +Postgresql has the following string matching operators: + + Glyph Description Example + ----- ---------------------------------------- ----------------------------- + ~~ Same as SQL "LIKE" operator 'scrappy,marc' ~~ '%scrappy%' + !~~ Same as SQL "NOT LIKE" operator 'bruce' !~~ '%al%' + ~ Match (regex), case sensitive 'thomas' ~ '.*thomas.*' + ~* Match (regex), case insensitive 'thomas' ~* '.*Thomas.*' + !~ Does not match (regex), case sensitive 'thomas' !~ '.*Thomas.*' + !~* Does not match (regex), case insensitive 'thomas' !~ '.*vadim.*' + + +=head2 Row ID + +The Postgresql "row id" pseudocolumn is called I<oid>, object identifier. +It can be treated as a string and used to rapidly (re)select rows. + + +=head2 Automatic Key or Sequence Generation + +Postgresql does not support automatic key generation such as "auto +increment" or "system generated" keys. + +However, Postgresql does support "sequence generators". Any number of +named sequence generators can be created in a database. Sequences +are used via functions called C<NEXTVAL> and C<CURRVAL>. Typical usage: + + INSERT INTO table (k, v) VALUES (nextval('seq_name'), ?); + +To get the value just inserted, you can use the corresponding C<currval()> +SQL function in the same session, or + + SELECT last_value FROM seq_name + + +=head2 Automatic Row Numbering and Row Count Limiting + +Postgresql does not support any way of automatically numbering returned rows. + + +=head2 Parameter Binding + +Parameter binding is emulated by the driver. +Both the C<?> and C<:1> style of placeholders are supported. + +The TYPE attribute of the C<bind_param()> method may be used to +influence how parameters are treated. These SQL types are bound as +VARCHAR: SQL_NUMERIC, SQL_DECIMAL, SQL_INTEGER, SQL_SMALLINT, +SQL_FLOAT, SQL_REAL, SQL_DOUBLE, SQL_VARCHAR. + +The SQL_CHAR type is bound as a CHAR thus enabling fixed-width blank +padded comparison semantics. + +Unsupported values of the TYPE attribute generate a warning. + + +=head2 Stored Procedures + +C<DBD::Pg> does not support stored procedures. + + +=head2 Table Metadata + +C<DBD::Pg> supports the C<table_info()> method. + +The I<pg_attribute> table contains detailed information about all columns +of all the tables in the database, one row per table. + +The I<pg_index> table contains detailed information about all indexes in +the database, one row per index. + +Primary keys are implemented as unique indexes. See I<pg_index> above. + + +=head2 Driver-specific Attributes and Methods + +There are no significant C<DBD::Pg> driver-specific database handle attributes. + +C<DBD::Pg> has the following driver-specific statement handle attributes: + +=over 8 + +=item I<pg_size> + +Returns a reference to an array of integer values for each column. The +integer shows the storage (not display) size of the column in bytes. +Variable length columns are indicated by -1. + +=item I<pg_type> + +Returns a reference to an array of strings for each column. The string +shows the name of the data type. + +=item I<pg_oid_status> + +Returns the OID of the last INSERT command. + +=item I<pg_cmd_status> + +Returns the name of the last command type. Possible types are: INSERT, +DELETE, UPDATE, SELECT. + +=back + + +C<DBD::Pg> has no private methods. + + +=head2 Positioned updates and deletes + +Postgresql does not support positioned updates or deletes. + + +=head2 Differences from the DBI Specification + +C<DBD::Pg> has no significant differences in behavior from the +current DBI specification. + +Note that C<DBD::Pg> does not fully parse the statement until +it's executed. Thus attributes like I<$sth-E<gt>{NUM_OF_FIELDS}> are not +available until after C<$sth-E<gt>execute> has been called. This is valid +behaviour but is important to note when porting applications +originally written for other drivers. + + +=head2 URLs to More Database/Driver Specific Information + + http://www.postgresql.org + + +=head2 Concurrent use of Multiple Handles + +C<DBD::Pg> supports an unlimited number of concurrent database +connections to one or more databases. + +It also supports the preparation and execution of a new statement +handle while still fetching data from another statement handle, +provided it is +associated with the same database handle. + + +=head2 Other Significant Database or Driver Features + +Postgres offers substantial additional power by incorporating the +following four additional basic concepts in such a way that users can +easily extend the system: classes, inheritance, types, and functions. + +Other features provide additional power and flexibility: constraints, +triggers, rules, transaction integrity, procedural languages, and large objects. + +It's also free Open Source Software with an active community of developers. + +=cut + +# This driver summary for DBD::Pg is Copyright (c) 1999 Tim Bunce +# and Edmund Mergl. +# $Id: dbd-pg.pod,v 1.1 2004-04-29 09:21:28 ivan Exp $ diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/dbdimp.c b/install/5.005/DBD-Pg-1.22-fixvercmp/dbdimp.c new file mode 100644 index 0000000..55f4ee7 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/dbdimp.c @@ -0,0 +1,2024 @@ +/* + $Id: dbdimp.c,v 1.1 2004-04-29 09:21:28 ivan Exp $ + + Copyright (c) 1997,1998,1999,2000 Edmund Mergl + Copyright (c) 2002 Jeffrey W. Baker + Portions Copyright (c) 1994,1995,1996,1997 Tim Bunce + + You may distribute under the terms of either the GNU General Public + License or the Artistic License, as specified in the Perl README file. + +*/ + + +/* + hard-coded OIDs: (here we need the postgresql types) + pg_sql_type() 1042 (bpchar), 1043 (varchar) + ddb_st_fetch() 1042 (bpchar), 16 (bool) + ddb_preparse() 1043 (varchar) + pgtype_bind_ok() +*/ + +#include "Pg.h" + +/* XXX DBI should provide a better version of this */ +#define IS_DBI_HANDLE(h) (SvROK(h) && SvTYPE(SvRV(h)) == SVt_PVHV && SvRMAGICAL(SvRV(h)) && (SvMAGIC(SvRV(h)))->mg_type == 'P') + +DBISTATE_DECLARE; + +/* hard-coded array delimiter */ +static char* array_delimiter = ","; + +static void dbd_preparse (imp_sth_t *imp_sth, char *statement); + + +void +dbd_init (dbistate) + dbistate_t *dbistate; +{ + DBIS = dbistate; +} + + +int +dbd_discon_all (drh, imp_drh) + SV *drh; + imp_drh_t *imp_drh; +{ + dTHR; + + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_discon_all\n"); } + + /* The disconnect_all concept is flawed and needs more work */ + if (!dirty && !SvTRUE(perl_get_sv("DBI::PERL_ENDING",0))) { + sv_setiv(DBIc_ERR(imp_drh), (IV)1); + sv_setpv(DBIc_ERRSTR(imp_drh), + (char*)"disconnect_all not implemented"); + DBIh_EVENT2(drh, ERROR_event, + DBIc_ERR(imp_drh), DBIc_ERRSTR(imp_drh)); + return FALSE; + } + if (perl_destruct_level) { + perl_destruct_level = 0; + } + return FALSE; +} + + +/* Database specific error handling. */ + +void +pg_error (h, error_num, error_msg) + SV *h; + int error_num; + char *error_msg; +{ + D_imp_xxh(h); + char *err, *src, *dst; + int len = strlen(error_msg); + + err = (char *)malloc(len + 1); + if (!err) { + return; + } + src = error_msg; + dst = err; + + /* copy error message without trailing newlines */ + while (*src != '\0' && *src != '\n') { + *dst++ = *src++; + } + *dst = '\0'; + + sv_setiv(DBIc_ERR(imp_xxh), (IV)error_num); /* set err early */ + sv_setpv(DBIc_ERRSTR(imp_xxh), (char*)err); + DBIh_EVENT2(h, ERROR_event, DBIc_ERR(imp_xxh), DBIc_ERRSTR(imp_xxh)); + if (dbis->debug >= 2) { PerlIO_printf(DBILOGFP, "%s error %d recorded: %s\n", err, error_num, SvPV(DBIc_ERRSTR(imp_xxh),na)); } + free(err); +} + +static int +pgtype_bind_ok (dbtype) + int dbtype; +{ + /* basically we support types that can be returned as strings */ + switch(dbtype) { + case 16: /* bool */ + case 17: /* bytea */ + case 18: /* char */ + case 20: /* int8 */ + case 21: /* int2 */ + case 23: /* int4 */ + case 25: /* text */ + case 26: /* oid */ + case 700: /* float4 */ + case 701: /* float8 */ + case 702: /* abstime */ + case 703: /* reltime */ + case 704: /* tinterval */ + case 1042: /* bpchar */ + case 1043: /* varchar */ + case 1082: /* date */ + case 1083: /* time */ + case 1184: /* datetime */ + case 1186: /* timespan */ + case 1296: /* timestamp */ + return 1; + } + return 0; +} + + +/* ================================================================== */ + +int +pg_db_login (dbh, imp_dbh, dbname, uid, pwd) + SV *dbh; + imp_dbh_t *imp_dbh; + char *dbname; + char *uid; + char *pwd; +{ + dTHR; + + char *conn_str; + char *src; + char *dest; + + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "pg_db_login\n"); } + + /* build connect string */ + /* DBD-Pg syntax: 'dbname=dbname;host=host;port=port' */ + /* pgsql syntax: 'dbname=dbname host=host port=port user=uid password=pwd' */ + + conn_str = (char *)malloc(strlen(dbname) + strlen(uid) + strlen(pwd) + 16 + 1); + if (! conn_str) { + return 0; + } + + src = dbname; + dest = conn_str; + while (*src) { + if (*src != ';') { + *dest++ = *src++; + continue; + } + *dest++ = ' '; + src++; + } + *dest = '\0'; + + if (strlen(uid)) { + strcat(conn_str, " user="); + strcat(conn_str, uid); + } + if (strlen(uid) && strlen(pwd)) { + strcat(conn_str, " password="); + strcat(conn_str, pwd); + } + + if (dbis->debug >= 2) { PerlIO_printf(DBILOGFP, "pg_db_login: conn_str = >%s<\n", conn_str); } + + /* make a connection to the database */ + imp_dbh->conn = PQconnectdb(conn_str); + free(conn_str); + + /* check to see that the backend connection was successfully made */ + if (PQstatus(imp_dbh->conn) != CONNECTION_OK) { + pg_error(dbh, PQstatus(imp_dbh->conn), PQerrorMessage(imp_dbh->conn)); + PQfinish(imp_dbh->conn); + return 0; + } + + imp_dbh->init_commit = 1; /* initialize AutoCommit */ + imp_dbh->pg_auto_escape = 1; /* initialize pg_auto_escape */ + imp_dbh->pg_bool_tf = 0; /* initialize pg_bool_tf */ + + DBIc_IMPSET_on(imp_dbh); /* imp_dbh set up now */ + DBIc_ACTIVE_on(imp_dbh); /* call disconnect before freeing */ + return 1; +} + + +int +dbd_db_getfd (dbh, imp_dbh) + SV *dbh; + imp_dbh_t *imp_dbh; +{ + char id; + SV* retsv; + + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_getfd\n"); } + + return PQsocket(imp_dbh->conn); +} + +SV * +dbd_db_pg_notifies (dbh, imp_dbh) + SV *dbh; + imp_dbh_t *imp_dbh; +{ + char id; + PGnotify* notify; + AV* ret; + SV* retsv; + + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_pg_notifies\n"); } + + PQconsumeInput(imp_dbh->conn); + + notify = PQnotifies(imp_dbh->conn); + + if (!notify) return &sv_undef; + + ret=newAV(); + + av_push(ret, newSVpv(notify->relname,0) ); + av_push(ret, newSViv(notify->be_pid) ); + + /* Should free notify memory with PQfreemem() */ + + retsv = newRV(sv_2mortal((SV*)ret)); + + return retsv; +} + +int +dbd_db_ping (dbh) + SV *dbh; +{ + char id; + D_imp_dbh(dbh); + PGresult* result; + ExecStatusType status; + + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_ping\n"); } + + if (NULL != imp_dbh->conn) { + result = PQexec(imp_dbh->conn, " "); + status = result ? PQresultStatus(result) : -1; + PQclear(result); + + if (PGRES_EMPTY_QUERY != status) { + return 0; + } + + return 1; + } + + return 0; +} + + +int +dbd_db_commit (dbh, imp_dbh) + SV *dbh; + imp_dbh_t *imp_dbh; +{ + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_commit\n"); } + + /* no commit if AutoCommit = on */ + if (DBIc_has(imp_dbh, DBIcf_AutoCommit) != FALSE) { + return 0; + } + + if (NULL != imp_dbh->conn) { + PGresult* result = 0; + ExecStatusType commitstatus, beginstatus; + + /* execute commit */ + result = PQexec(imp_dbh->conn, "commit"); + commitstatus = result ? PQresultStatus(result) : -1; + PQclear(result); + + /* check result */ + if (commitstatus != PGRES_COMMAND_OK) { + /* Only put the error message in DBH->errstr */ + pg_error(dbh, commitstatus, PQerrorMessage(imp_dbh->conn)); + } + + /* start new transaction. AutoCommit must be FALSE, ref. 20 lines up */ + result = PQexec(imp_dbh->conn, "begin"); + beginstatus = result ? PQresultStatus(result) : -1; + PQclear(result); + if (beginstatus != PGRES_COMMAND_OK) { + /* Maybe add some loud barf here? Raising some very high error? */ + pg_error(dbh, beginstatus, "begin failed\n"); + return 0; + } + + /* if the initial COMMIT failed, return 0 now */ + if (commitstatus != PGRES_COMMAND_OK) { + return 0; + } + + return 1; + } + + return 0; +} + + +int +dbd_db_rollback (dbh, imp_dbh) + SV *dbh; + imp_dbh_t *imp_dbh; +{ + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_rollback\n"); } + + /* no rollback if AutoCommit = on */ + if (DBIc_has(imp_dbh, DBIcf_AutoCommit) != FALSE) { + return 0; + } + + if (NULL != imp_dbh->conn) { + PGresult* result = 0; + ExecStatusType status; + + /* execute rollback */ + result = PQexec(imp_dbh->conn, "rollback"); + status = result ? PQresultStatus(result) : -1; + PQclear(result); + + /* check result */ + if (status != PGRES_COMMAND_OK) { + pg_error(dbh, status, "rollback failed\n"); + return 0; + } + + /* start new transaction. AutoCommit must be FALSE, ref. 20 lines up */ + result = PQexec(imp_dbh->conn, "begin"); + status = result ? PQresultStatus(result) : -1; + PQclear(result); + if (status != PGRES_COMMAND_OK) { + pg_error(dbh, status, "begin failed\n"); + return 0; + } + + return 1; + } + + return 0; +} + + +int +dbd_db_disconnect (dbh, imp_dbh) + SV *dbh; + imp_dbh_t *imp_dbh; +{ + dTHR; + + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_disconnect\n"); } + + /* We assume that disconnect will always work */ + /* since most errors imply already disconnected. */ + DBIc_ACTIVE_off(imp_dbh); + + if (NULL != imp_dbh->conn) { + /* rollback if AutoCommit = off */ + if (DBIc_has(imp_dbh, DBIcf_AutoCommit) == FALSE) { + PGresult* result = 0; + ExecStatusType status; + result = PQexec(imp_dbh->conn, "rollback"); + status = result ? PQresultStatus(result) : -1; + PQclear(result); + if (status != PGRES_COMMAND_OK) { + pg_error(dbh, status, "rollback failed\n"); + return 0; + } + if (dbis->debug >= 2) { PerlIO_printf(DBILOGFP, "dbd_db_disconnect: AutoCommit=off -> rollback\n"); } + } + + PQfinish(imp_dbh->conn); + + imp_dbh->conn = NULL; + } + + /* We don't free imp_dbh since a reference still exists */ + /* The DESTROY method is the only one to 'free' memory. */ + /* Note that statement objects may still exists for this dbh! */ + return 1; +} + + +void +dbd_db_destroy (dbh, imp_dbh) + SV *dbh; + imp_dbh_t *imp_dbh; +{ + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_destroy\n"); } + + if (DBIc_ACTIVE(imp_dbh)) { + dbd_db_disconnect(dbh, imp_dbh); + } + + /* Nothing in imp_dbh to be freed */ + DBIc_IMPSET_off(imp_dbh); +} + + +int +dbd_db_STORE_attrib (dbh, imp_dbh, keysv, valuesv) + SV *dbh; + imp_dbh_t *imp_dbh; + SV *keysv; + SV *valuesv; +{ + STRLEN kl; + char *key = SvPV(keysv,kl); + int newval = SvTRUE(valuesv); + + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_STORE\n"); } + + if (kl==10 && strEQ(key, "AutoCommit")) { + int oldval = DBIc_has(imp_dbh, DBIcf_AutoCommit); + DBIc_set(imp_dbh, DBIcf_AutoCommit, newval); + if (oldval == FALSE && newval != FALSE && imp_dbh->init_commit) { + /* do nothing, fall through */ + if (dbis->debug >= 2) { PerlIO_printf(DBILOGFP, "dbd_db_STORE: initialize AutoCommit to on\n"); } + } else if (oldval == FALSE && newval != FALSE) { + if (NULL != imp_dbh->conn) { + /* commit any outstanding changes */ + PGresult* result = 0; + ExecStatusType status; + result = PQexec(imp_dbh->conn, "commit"); + status = result ? PQresultStatus(result) : -1; + PQclear(result); + if (status != PGRES_COMMAND_OK) { + pg_error(dbh, status, "commit failed\n"); + return 0; + } + } + if (dbis->debug >= 2) { PerlIO_printf(DBILOGFP, "dbd_db_STORE: switch AutoCommit to on: commit\n"); } + } else if ((oldval != FALSE && newval == FALSE) || (oldval == FALSE && newval == FALSE && imp_dbh->init_commit)) { + if (NULL != imp_dbh->conn) { + /* start new transaction */ + PGresult* result = 0; + ExecStatusType status; + result = PQexec(imp_dbh->conn, "begin"); + status = result ? PQresultStatus(result) : -1; + PQclear(result); + if (status != PGRES_COMMAND_OK) { + pg_error(dbh, status, "begin failed\n"); + return 0; + } + } + if (dbis->debug >= 2) { PerlIO_printf(DBILOGFP, "dbd_db_STORE: switch AutoCommit to off: begin\n"); } + } + /* only needed once */ + imp_dbh->init_commit = 0; + return 1; + } else if (kl==14 && strEQ(key, "pg_auto_escape")) { + imp_dbh->pg_auto_escape = newval; + } else if (kl==10 && strEQ(key, "pg_bool_tf")) { + imp_dbh->pg_bool_tf = newval; +#ifdef SvUTF8_off + } else if (kl==14 && strEQ(key, "pg_enable_utf8")) { + imp_dbh->pg_enable_utf8 = newval; +#endif + } else { + return 0; + } +} + + +SV * +dbd_db_FETCH_attrib (dbh, imp_dbh, keysv) + SV *dbh; + imp_dbh_t *imp_dbh; + SV *keysv; +{ + STRLEN kl; + char *key = SvPV(keysv,kl); + SV *retsv = Nullsv; + + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_FETCH\n"); } + + if (kl==10 && strEQ(key, "AutoCommit")) { + retsv = boolSV(DBIc_has(imp_dbh, DBIcf_AutoCommit)); + } else if (kl==14 && strEQ(key, "pg_auto_escape")) { + retsv = newSViv((IV)imp_dbh->pg_auto_escape); + } else if (kl==10 && strEQ(key, "pg_bool_tf")) { + retsv = newSViv((IV)imp_dbh->pg_bool_tf); +#ifdef SvUTF8_off + } else if (kl==14 && strEQ(key, "pg_enable_utf8")) { + retsv = newSViv((IV)imp_dbh->pg_enable_utf8); +#endif + } else if (kl==11 && strEQ(key, "pg_INV_READ")) { + retsv = newSViv((IV)INV_READ); + } else if (kl==12 && strEQ(key, "pg_INV_WRITE")) { + retsv = newSViv((IV)INV_WRITE); + } + + if (!retsv) { + return Nullsv; + } + if (retsv == &sv_yes || retsv == &sv_no) { + return retsv; /* no need to mortalize yes or no */ + } + return sv_2mortal(retsv); +} + + +/* driver specific functins */ + + +int +pg_db_lo_open (dbh, lobjId, mode) + SV *dbh; + unsigned int lobjId; + int mode; +{ + D_imp_dbh(dbh); + return lo_open(imp_dbh->conn, lobjId, mode); +} + + +int +pg_db_lo_close (dbh, fd) + SV *dbh; + int fd; +{ + D_imp_dbh(dbh); + return lo_close(imp_dbh->conn, fd); +} + + +int +pg_db_lo_read (dbh, fd, buf, len) + SV *dbh; + int fd; + char *buf; + int len; +{ + D_imp_dbh(dbh); + return lo_read(imp_dbh->conn, fd, buf, len); +} + + +int +pg_db_lo_write (dbh, fd, buf, len) + SV *dbh; + int fd; + char *buf; + int len; +{ + D_imp_dbh(dbh); + return lo_write(imp_dbh->conn, fd, buf, len); +} + + +int +pg_db_lo_lseek (dbh, fd, offset, whence) + SV *dbh; + int fd; + int offset; + int whence; +{ + D_imp_dbh(dbh); + return lo_lseek(imp_dbh->conn, fd, offset, whence); +} + + +unsigned int +pg_db_lo_creat (dbh, mode) + SV *dbh; + int mode; +{ + D_imp_dbh(dbh); + return lo_creat(imp_dbh->conn, mode); +} + + +int +pg_db_lo_tell (dbh, fd) + SV *dbh; + int fd; +{ + D_imp_dbh(dbh); + return lo_tell(imp_dbh->conn, fd); +} + + +int +pg_db_lo_unlink (dbh, lobjId) + SV *dbh; + unsigned int lobjId; +{ + D_imp_dbh(dbh); + return lo_unlink(imp_dbh->conn, lobjId); +} + + +unsigned int +pg_db_lo_import (dbh, filename) + SV *dbh; + char *filename; +{ + D_imp_dbh(dbh); + return lo_import(imp_dbh->conn, filename); +} + + +int +pg_db_lo_export (dbh, lobjId, filename) + SV *dbh; + unsigned int lobjId; + char *filename; +{ + D_imp_dbh(dbh); + return lo_export(imp_dbh->conn, lobjId, filename); +} + + +int +pg_db_putline (dbh, buffer) + SV *dbh; + char *buffer; +{ + D_imp_dbh(dbh); + return PQputline(imp_dbh->conn, buffer); +} + + +int +pg_db_getline (dbh, buffer, length) + SV *dbh; + char *buffer; + int length; +{ + D_imp_dbh(dbh); + return PQgetline(imp_dbh->conn, buffer, length); +} + + +int +pg_db_endcopy (dbh) + SV *dbh; +{ + D_imp_dbh(dbh); + return PQendcopy(imp_dbh->conn); +} + + +/* ================================================================== */ + + +int +dbd_st_prepare (sth, imp_sth, statement, attribs) + SV *sth; + imp_sth_t *imp_sth; + char *statement; + SV *attribs; +{ + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_prepare: statement = >%s<\n", statement); } + + /* scan statement for '?', ':1' and/or ':foo' style placeholders */ + dbd_preparse(imp_sth, statement); + + /* initialize new statement handle */ + imp_sth->result = 0; + imp_sth->cur_tuple = 0; + + DBIc_IMPSET_on(imp_sth); + return 1; +} + + +static void +dbd_preparse (imp_sth, statement) + imp_sth_t *imp_sth; + char *statement; +{ + bool in_literal = FALSE; + char in_comment = '\0'; + char *src, *start, *dest; + phs_t phs_tpl; + SV *phs_sv; + int idx=0; + char *style="", *laststyle=Nullch; + STRLEN namelen; + + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_preparse: statement = >%s<\n", statement); } + + /* allocate room for copy of statement with spare capacity */ + /* for editing '?' or ':1' into ':p1'. */ + /* */ + /* Note: the calculated length used here for the safemalloc */ + /* isn't related in any way to the actual worst case length */ + /* of the translated statement, but allowing for 3 times */ + /* the length of the original statement should be safe... */ + imp_sth->statement = (char*)safemalloc(strlen(statement) * 3 + 1); + + /* initialise phs ready to be cloned per placeholder */ + memset(&phs_tpl, 0, sizeof(phs_tpl)); + phs_tpl.ftype = 1043; /* VARCHAR */ + + src = statement; + dest = imp_sth->statement; + while(*src) { + + if (in_comment) { + /* SQL-style and C++-style */ + if ((in_comment == '-' || in_comment == '/') && *src == '\n') { + in_comment = '\0'; + } + /* C-style */ + else if (in_comment == '*' && *src == '*' && *(src+1) == '/') { + *dest++ = *src++; /* avoids asterisk-slash-asterisk issues */ + in_comment = '\0'; + } + *dest++ = *src++; + continue; + } + + if (in_literal) { + /* check if literal ends but keep quotes in literal */ + if (*src == in_literal) { + int bs=0; + char *str; + str = src-1; + while (*(str-bs) == '\\') + bs++; + if (!(bs & 1)) + in_literal = 0; + } + *dest++ = *src++; + continue; + } + + /* Look for comments: SQL-style or C++-style or C-style */ + if ((*src == '-' && *(src+1) == '-') || + (*src == '/' && *(src+1) == '/') || + (*src == '/' && *(src+1) == '*')) + { + in_comment = *(src+1); + /* We know *src & the next char are to be copied, so do */ + /* it. In the case of C-style comments, it happens to */ + /* help us avoid slash-asterisk-slash oddities. */ + *dest++ = *src++; + *dest++ = *src++; + continue; + } + + /* check if no placeholders */ + if (*src != ':' && *src != '?') { + if (*src == '\'' || *src == '"') { + in_literal = *src; + } + *dest++ = *src++; + continue; + } + + /* check for cast operator */ + if (*src == ':' && (*(src-1) == ':' || *(src+1) == ':')) { + *dest++ = *src++; + continue; + } + + /* only here for : or ? outside of a comment or literal and no cast */ + + start = dest; /* save name inc colon */ + *dest++ = *src++; + if (*start == '?') { /* X/Open standard */ + sprintf(start,":p%d", ++idx); /* '?' -> ':p1' (etc) */ + dest = start+strlen(start); + style = "?"; + + } else if (isDIGIT(*src)) { /* ':1' */ + idx = atoi(src); + *dest++ = 'p'; /* ':1'->':p1' */ + if (idx <= 0) { + croak("Placeholder :%d invalid, placeholders must be >= 1", idx); + } + while(isDIGIT(*src)) { + *dest++ = *src++; + } + style = ":1"; + + } else if (isALNUM(*src)) { /* ':foo' */ + while(isALNUM(*src)) { /* includes '_' */ + *dest++ = *src++; + } + style = ":foo"; + } else { /* perhaps ':=' PL/SQL construct */ + continue; + } + *dest = '\0'; /* handy for debugging */ + namelen = (dest-start); + if (laststyle && style != laststyle) { + croak("Can't mix placeholder styles (%s/%s)",style,laststyle); + } + laststyle = style; + if (imp_sth->all_params_hv == NULL) { + imp_sth->all_params_hv = newHV(); + } + phs_tpl.sv = &sv_undef; + phs_sv = newSVpv((char*)&phs_tpl, sizeof(phs_tpl)+namelen+1); + hv_store(imp_sth->all_params_hv, start, namelen, phs_sv, 0); + strcpy( ((phs_t*)(void*)SvPVX(phs_sv))->name, start); + } + *dest = '\0'; + if (imp_sth->all_params_hv) { + DBIc_NUM_PARAMS(imp_sth) = (int)HvKEYS(imp_sth->all_params_hv); + if (dbis->debug >= 2) { PerlIO_printf(DBILOGFP, " dbd_preparse scanned %d distinct placeholders\n", (int)DBIc_NUM_PARAMS(imp_sth)); } + } +} + + +/* if it LOOKS like a string, this function will determine whether the type needs to be surrounded in single quotes */ +static int pg_sql_needquote (sql_type) + int sql_type; +{ + if (sql_type > 1000 || sql_type == 17 || sql_type == 25 ) { + return 1; + } + return 0; +} + + + +static int +pg_sql_type (imp_sth, name, sql_type) + imp_sth_t *imp_sth; + char *name; + int sql_type; +{ + switch (sql_type) { + case SQL_CHAR: + return 1042; /* bpchar */ + case SQL_NUMERIC: + return 700; /* float4 */ + case SQL_DECIMAL: + return 700; /* float4 */ + case SQL_INTEGER: + return 23; /* int4 */ + case SQL_SMALLINT: + return 21; /* int2 */ + case SQL_FLOAT: + return 700; /* float4 */ + case SQL_REAL: + return 701; /* float8 */ + case SQL_DOUBLE: + return 20; /* int8 */ + case SQL_VARCHAR: + return 1043; /* varchar */ + case SQL_BINARY: + return 17; /* bytea */ + default: + if (DBIc_WARN(imp_sth) && imp_sth && name) { + warn("SQL type %d for '%s' is not fully supported, bound as VARCHAR instead", + sql_type, name); + } + return pg_sql_type(imp_sth, name, SQL_VARCHAR); + } +} + +static int +sql_pg_type (imp_sth, name, sql_type) + imp_sth_t *imp_sth; + char *name; + int sql_type; +{ + if (dbis->debug >= 1) { + PerlIO_printf(DBILOGFP, "sql_pg_type name '%s' type '%d'\n", name, sql_type ); + } + + switch (sql_type) { + case 17: /* bytea */ + return SQL_BINARY; + case 20: /* int8 */ + return SQL_DOUBLE; + case 21: /* int2 */ + return SQL_SMALLINT; + case 23: /* int4 */ + return SQL_INTEGER; + case 700: /* float4 */ + return SQL_NUMERIC; + case 701: /* float8 */ + return SQL_REAL; + case 1042: /* bpchar */ + return SQL_CHAR; + case 1043: /* varchar */ + return SQL_VARCHAR; + case 1082: /* date */ + return SQL_DATE; + case 1083: /* time */ + return SQL_TIME; + case 1296: /* date */ + return SQL_TIMESTAMP; + + default: + return sql_type; + } +} + + +static int +dbd_rebind_ph (sth, imp_sth, phs) + SV *sth; + imp_sth_t *imp_sth; + phs_t *phs; +{ + STRLEN value_len; + + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_rebind\n"); } + + /* convert to a string ASAP */ + if (!SvPOK(phs->sv) && SvOK(phs->sv)) { + sv_2pv(phs->sv, &na); + } + + if (dbis->debug >= 2) { + char *val = neatsvpv(phs->sv,0); + PerlIO_printf(DBILOGFP, " bind %s <== %.1000s (", phs->name, val); + if (SvOK(phs->sv)) { + PerlIO_printf(DBILOGFP, "size %ld/%ld/%ld, ", (long)SvCUR(phs->sv),(long)SvLEN(phs->sv),phs->maxlen); + } else { + PerlIO_printf(DBILOGFP, "NULL, "); + } + PerlIO_printf(DBILOGFP, "ptype %d, otype %d%s)\n", (int)SvTYPE(phs->sv), phs->ftype, (phs->is_inout) ? ", inout" : ""); + } + + /* At the moment we always do sv_setsv() and rebind. */ + /* Later we may optimise this so that more often we can */ + /* just copy the value & length over and not rebind. */ + + if (phs->is_inout) { /* XXX */ + if (SvREADONLY(phs->sv)) { + croak(no_modify); + } + /* phs->sv _is_ the real live variable, it may 'mutate' later */ + /* pre-upgrade high to reduce risk of SvPVX realloc/move */ + (void)SvUPGRADE(phs->sv, SVt_PVNV); + /* ensure room for result, 28 is magic number (see sv_2pv) */ + SvGROW(phs->sv, (phs->maxlen < 28) ? 28 : phs->maxlen+1); + } + else { + /* phs->sv is copy of real variable, upgrade to at least string */ + (void)SvUPGRADE(phs->sv, SVt_PV); + } + + /* At this point phs->sv must be at least a PV with a valid buffer, */ + /* even if it's undef (null) */ + /* Here we set phs->progv, phs->indp, and value_len. */ + if (SvOK(phs->sv)) { + phs->progv = SvPV(phs->sv, value_len); + phs->indp = 0; + } + else { /* it's null but point to buffer in case it's an out var */ + phs->progv = SvPVX(phs->sv); + phs->indp = -1; + value_len = 0; + } + phs->sv_type = SvTYPE(phs->sv); /* part of mutation check */ + phs->maxlen = SvLEN(phs->sv)-1; /* avail buffer space */ + if (phs->maxlen < 0) { /* can happen with nulls */ + phs->maxlen = 0; + } + + phs->alen = value_len + phs->alen_incnull; + + imp_sth->all_params_len += SvOK(phs->sv) ? phs->alen : 4; /* NULL */ + + if (dbis->debug >= 3) { + PerlIO_printf(DBILOGFP, " bind %s <== '%.*s' (size %ld/%ld, otype %d, indp %d)\n", + phs->name, + (int)(phs->alen>SvIV(DBIS->neatsvpvlen) ? SvIV(DBIS->neatsvpvlen) : phs->alen), + (phs->progv) ? phs->progv : "", + (long)phs->alen, (long)phs->maxlen, phs->ftype, phs->indp); + } + + return 1; +} + + +void dereference(value) +SV** value; +{ + AV* buf; + SV* val; + char *src; + int is_ref; + STRLEN len; + + if (SvTYPE(SvRV(*value)) != SVt_PVAV) + croak("Not an array reference (%s)", neatsvpv(*value,0)); + + buf = (AV *) SvRV(*value); + sv_setpv(*value, "{"); + while ( SvOK(val = av_shift(buf)) ) { + is_ref = SvROK(val); + if (is_ref) + dereference(&val); + else + sv_catpv(*value, "\""); + /* Quote */ + src = SvPV(val, len); + while (len--) { + if (!is_ref && *src == '\"') + sv_catpv(*value, "\\"); + sv_catpvn(*value, src++, 1); + } + /* End of quote */ + if (!is_ref) + sv_catpv(*value, "\""); + if (av_len(buf) > -1) + sv_catpv(*value, array_delimiter); + } + sv_catpv(*value, "}"); + av_clear(buf); +} + +int +dbd_bind_ph (sth, imp_sth, ph_namesv, newvalue, sql_type, attribs, is_inout, maxlen) + SV *sth; + imp_sth_t *imp_sth; + SV *ph_namesv; + SV *newvalue; + IV sql_type; + SV *attribs; + int is_inout; + IV maxlen; +{ + SV **phs_svp; + STRLEN name_len; + char *name; + char namebuf[30]; + phs_t *phs; + + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_bind_ph\n"); } + + /* check if placeholder was passed as a number */ + + if (SvGMAGICAL(ph_namesv)) { /* eg if from tainted expression */ + mg_get(ph_namesv); + } + if (!SvNIOKp(ph_namesv)) { + name = SvPV(ph_namesv, name_len); + } + if (SvNIOKp(ph_namesv) || (name && isDIGIT(name[0]))) { + sprintf(namebuf, ":p%d", (int)SvIV(ph_namesv)); + name = namebuf; + name_len = strlen(name); + } + assert(name != Nullch); + + if (SvTYPE(newvalue) > SVt_PVLV) { /* hook for later array logic */ + croak("Can't bind a non-scalar value (%s)", neatsvpv(newvalue,0)); + } + if (SvROK(newvalue) && !IS_DBI_HANDLE(newvalue)) { + /* dbi handle allowed for cursor variables */ + dereference(&newvalue); + } + if (SvTYPE(newvalue) == SVt_PVLV && is_inout) { /* may allow later */ + croak("Can't bind ``lvalue'' mode scalar as inout parameter (currently)"); + } + + if (dbis->debug >= 2) { + PerlIO_printf(DBILOGFP, " bind %s <== %s (type %ld", name, neatsvpv(newvalue,0), (long)sql_type); + if (is_inout) { + PerlIO_printf(DBILOGFP, ", inout 0x%lx, maxlen %ld", (long)newvalue, (long)maxlen); + } + if (attribs) { + PerlIO_printf(DBILOGFP, ", attribs: %s", neatsvpv(attribs,0)); + } + PerlIO_printf(DBILOGFP, ")\n"); + } + + phs_svp = hv_fetch(imp_sth->all_params_hv, name, name_len, 0); + if (phs_svp == NULL) { + croak("Can't bind unknown placeholder '%s' (%s)", name, neatsvpv(ph_namesv,0)); + } + phs = (phs_t*)(void*)SvPVX(*phs_svp); /* placeholder struct */ + + if (phs->sv == &sv_undef) { /* first bind for this placeholder */ + phs->ftype = 1043; /* our default type VARCHAR */ + phs->is_inout = is_inout; + if (is_inout) { + /* phs->sv assigned in the code below */ + ++imp_sth->has_inout_params; + /* build array of phs's so we can deal with out vars fast */ + if (!imp_sth->out_params_av) { + imp_sth->out_params_av = newAV(); + } + av_push(imp_sth->out_params_av, SvREFCNT_inc(*phs_svp)); + } + + if (attribs) { /* only look for pg_type on first bind of var */ + SV **svp; + /* Setup / Clear attributes as defined by attribs. */ + /* XXX If attribs is EMPTY then reset attribs to default? */ + if ( (svp = hv_fetch((HV*)SvRV(attribs), "pg_type", 7, 0)) != NULL) { + int pg_type = SvIV(*svp); + if (!pgtype_bind_ok(pg_type)) { + croak("Can't bind %s, pg_type %d not supported by DBD::Pg", phs->name, pg_type); + } + if (sql_type) { + croak("Can't specify both TYPE (%d) and pg_type (%d) for %s", sql_type, pg_type, phs->name); + } + phs->ftype = pg_type; + } + } + if (sql_type) { + /* SQL_BINARY (-2) is deprecated. */ + if (sql_type == -2 && DBIc_WARN(imp_sth)) { + warn("Use of SQL type SQL_BINARY (%d) is deprecated. Use { pg_type => DBD::Pg::PG_BYTEA } instead.", sql_type); + } + phs->ftype = pg_sql_type(imp_sth, phs->name, sql_type); + } + } /* was first bind for this placeholder */ + + /* check later rebinds for any changes */ + else if (is_inout || phs->is_inout) { + croak("Can't rebind or change param %s in/out mode after first bind (%d => %d)", phs->name, phs->is_inout , is_inout); + } + else if (sql_type && phs->ftype != pg_sql_type(imp_sth, phs->name, sql_type)) { + croak("Can't change TYPE of param %s to %d after initial bind", phs->name, sql_type); + } + + phs->maxlen = maxlen; /* 0 if not inout */ + + if (!is_inout) { /* normal bind to take a (new) copy of current value */ + if (phs->sv == &sv_undef) { /* (first time bind) */ + phs->sv = newSV(0); + } + sv_setsv(phs->sv, newvalue); + } else if (newvalue != phs->sv) { + if (phs->sv) { + SvREFCNT_dec(phs->sv); + } + phs->sv = SvREFCNT_inc(newvalue); /* point to live var */ + } + + return dbd_rebind_ph(sth, imp_sth, phs); +} + + +int +dbd_st_execute (sth, imp_sth) /* <= -2:error, >=0:ok row count, (-1=unknown count) */ + SV *sth; + imp_sth_t *imp_sth; +{ + dTHR; + + D_imp_dbh_from_sth; + ExecStatusType status = -1; + char *cmdStatus; + char *cmdTuples; + char *statement; + int ret = -2; + int num_fields; + int i; + STRLEN len; + bool in_literal = FALSE; + char in_comment = '\0'; + char *src; + char *dest; + char *val; + char namebuf[30]; + phs_t *phs; + SV **svp; + + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_execute\n"); } + + /* + here we get the statement from the statement handle where + it has been stored when creating a blank sth during prepare + svp = hv_fetch((HV *)SvRV(sth), "Statement", 9, FALSE); + statement = SvPV(*svp, na); + */ + + if (NULL == imp_dbh->conn) { + pg_error(sth, -1, "execute on disconnected handle"); + return -2; + } + + statement = imp_sth->statement; + if (! statement) { + /* are we prepared ? */ + pg_error(sth, -1, "statement not prepared\n"); + return -2; + } + + /* do we have input parameters ? */ + if ((int)DBIc_NUM_PARAMS(imp_sth) > 0) { + /* + we have to allocate some additional memory for possible escaping + quotes and backslashes: + max_len = length of statement + + total length of all params allowing for worst case all + characters binary-escaped (\\xxx) + + null terminator + Note: parameters look like :p1 at this point, so there's no + need to explicitly allow for surrounding quotes because '' is + shorter than :p1 + */ + int max_len = strlen(imp_sth->statement) + imp_sth->all_params_len * 5 + 1; + statement = (char*)safemalloc( max_len ); + dest = statement; + src = imp_sth->statement; + /* scan statement for ':p1' style placeholders */ + while(*src) { + + if (in_comment) { + /* SQL-style and C++-style */ + if ((in_comment == '-' || in_comment == '/') && *src == '\n') { + in_comment = '\0'; + } + /* C-style */ + else if (in_comment == '*' && *src == '*' && *(src+1) == '/') { + *dest++ = *src++; /* avoids asterisk-slash-asterisk issues */ + in_comment = '\0'; + } + *dest++ = *src++; + continue; + } + + if (in_literal) { + /* check if literal ends but keep quotes in literal */ + if (*src == in_literal) { + int bs=0; + char *str; + str = src-1; + while (*(str-bs) == '\\') + bs++; + if (!(bs & 1)) + in_literal = 0; + } + *dest++ = *src++; + continue; + } + + /* Look for comments: SQL-style or C++-style or C-style */ + if ((*src == '-' && *(src+1) == '-') || + (*src == '/' && *(src+1) == '/') || + (*src == '/' && *(src+1) == '*')) + { + in_comment = *(src+1); + /* We know *src & the next char are to be copied, so do */ + /* it. In the case of C-style comments, it happens to */ + /* help us avoid slash-asterisk-slash oddities. */ + *dest++ = *src++; + *dest++ = *src++; + continue; + } + + /* check if no placeholders */ + if (*src != ':' && *src != '?') { + if (*src == '\'' || *src == '"') { + in_literal = *src; + } + *dest++ = *src++; + continue; + } + + /* check for cast operator */ + if (*src == ':' && (*(src-1) == ':' || *(src+1) == ':')) { + *dest++ = *src++; + continue; + } + + + i = 0; + namebuf[i++] = *src++; /* ':' */ + namebuf[i++] = *src++; /* 'p' */ + + while (isDIGIT(*src) && i < (sizeof(namebuf)-1) ) { + namebuf[i++] = *src++; + } + if ( i == (sizeof(namebuf) - 1)) { + pg_error(sth, -1, "namebuf buffer overrun\n"); + return -2; + } + namebuf[i] = '\0'; + svp = hv_fetch(imp_sth->all_params_hv, namebuf, i, 0); + if (svp == NULL) { + pg_error(sth, -1, "parameter unknown\n"); + return -2; + } + /* get attribute */ + phs = (phs_t*)(void*)SvPVX(*svp); + /* replace undef with NULL */ + if(!SvOK(phs->sv)) { + val = "NULL"; + len = 4; + } else { + val = SvPV(phs->sv, len); + } + /* quote string attribute */ + if(!SvNIOK(phs->sv) && SvOK(phs->sv) && pg_sql_needquote(phs->ftype)) { /* avoid quoting NULL, tpf: bind_param as numeric */ + *dest++ = '\''; + } + while (len--) { + if (imp_dbh->pg_auto_escape) { + /* if the parameter was bound as PG_BYTEA, escape nonprintables */ + if (phs->ftype == 17 && !isPRINT(*val)) { /* escape null character */ + dest+=snprintf(dest, (statement + max_len) - dest, "\\\\%03o", *((unsigned char *)val)); + if (dest > statement + max_len) { + pg_error(sth, -1, "statement buffer overrun\n"); + return -2; + } + val++; + continue; /* do not copy the null */ + } + /* escape quote */ + if (*val == '\'') { + *dest++ = '\''; + } + /* escape backslash */ + if (*val == '\\') { + if (phs->ftype == 17) { /* four backslashes. really. */ + *dest++ = '\\'; + *dest++ = '\\'; + *dest++ = '\\'; + } else { + *dest++ = '\\'; + } + } + } + /* copy attribute to statement */ + *dest++ = *val++; + } + /* quote string attribute */ + if(!SvNIOK(phs->sv) && SvOK(phs->sv) && pg_sql_needquote(phs->ftype)) { /* avoid quoting NULL, tpf: bind_param as numeric */ + *dest++ = '\''; + } + } + *dest = '\0'; + } + + if (dbis->debug >= 2) { PerlIO_printf(DBILOGFP, "dbd_st_execute: statement = >%s<\n", statement); } + + /* clear old result (if any) */ + if (imp_sth->result) { + PQclear(imp_sth->result); + } + + /* execute statement */ + imp_sth->result = PQexec(imp_dbh->conn, statement); + + /* free statement string in case of input parameters */ + if ((int)DBIc_NUM_PARAMS(imp_sth) > 0) { + Safefree(statement); + } + + /* check status */ + status = imp_sth->result ? PQresultStatus(imp_sth->result) : -1; + cmdStatus = imp_sth->result ? (char *)PQcmdStatus(imp_sth->result) : ""; + cmdTuples = imp_sth->result ? (char *)PQcmdTuples(imp_sth->result) : ""; + + if (PGRES_TUPLES_OK == status) { + /* select statement */ + num_fields = PQnfields(imp_sth->result); + imp_sth->cur_tuple = 0; + DBIc_NUM_FIELDS(imp_sth) = num_fields; + DBIc_ACTIVE_on(imp_sth); + ret = PQntuples(imp_sth->result); + } else if (PGRES_COMMAND_OK == status) { + /* non-select statement */ + if (! strncmp(cmdStatus, "DELETE", 6) || ! strncmp(cmdStatus, "INSERT", 6) || ! strncmp(cmdStatus, "UPDATE", 6)) { + ret = atoi(cmdTuples); + } else { + ret = -1; + } + } else if (PGRES_COPY_OUT == status || PGRES_COPY_IN == status) { + /* Copy Out/In data transfer in progress */ + ret = -1; + } else { + pg_error(sth, status, PQerrorMessage(imp_dbh->conn)); + ret = -2; + } + + /* store the number of affected rows */ + imp_sth->rows = ret; + + return ret; +} + + +int +is_high_bit_set(val) + char *val; +{ + while (*val++) + if (*val & 0x80) return 1; + return 0; +} + +AV * +dbd_st_fetch (sth, imp_sth) + SV *sth; + imp_sth_t *imp_sth; +{ + D_imp_dbh_from_sth; + int num_fields; + int i; + AV *av; + + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_fetch\n"); } + + /* Check that execute() was executed sucessfully */ + if ( !DBIc_ACTIVE(imp_sth) ) { + pg_error(sth, 1, "no statement executing\n"); + + return Nullav; + } + + if ( imp_sth->cur_tuple == PQntuples(imp_sth->result) ) { + imp_sth->cur_tuple = 0; + DBIc_ACTIVE_off(imp_sth); + return Nullav; /* we reached the last tuple */ + } + + av = DBIS->get_fbav(imp_sth); + num_fields = AvFILL(av)+1; + + for(i = 0; i < num_fields; ++i) { + + SV *sv = AvARRAY(av)[i]; + if (PQgetisnull(imp_sth->result, imp_sth->cur_tuple, i)) { + sv_setsv(sv, &sv_undef); + } else { + char *val = (char*)PQgetvalue(imp_sth->result, imp_sth->cur_tuple, i); + int val_len = strlen(val); + int type = PQftype(imp_sth->result, i); /* hopefully these hard coded values will not change */ + if (16 == type && ! imp_dbh->pg_bool_tf) { + *val = (*val == 'f') ? '0' : '1'; /* bool: translate postgres into perl */ + } + if (17 == type) { /* decode \001 -> chr(1), etc, in-place */ + char *p = val; /* points to next available pos */ + char *s = val; /* points to current scanning pos */ + int c1,c2,c3; + while (*s) { + if (*s == '\\') { + if (*(s+1) == '\\') { /* double backslash */ + *p++ = '\\'; + s += 2; + continue; + } + else if ( isdigit(c1=(*(s+1))) && + isdigit(c2=(*(s+2))) && + isdigit(c3=(*(s+3))) ) { + *p++ = (c1 - '0') * 64 + (c2 - '0') * 8 + (c3 - '0'); + s += 4; + continue; + } + } + *p++ = *s++; + } + val_len = (p - val); + } + else if (1042 == type && DBIc_has(imp_sth,DBIcf_ChopBlanks)) { + char *str = val; + while((val_len > 0) && (str[val_len-1] == ' ')) { + val_len--; + } + val[val_len] = '\0'; + } + sv_setpvn(sv, val, val_len); +#ifdef SvUTF8_off + if (imp_dbh->pg_enable_utf8) { + SvUTF8_off(sv); + /* XXX Is this all the character data types? */ + if (18 == type || 25 == type || 1042 ==type || 1043 == type) { + if (is_high_bit_set(val) && is_utf8_string(val, val_len)) + SvUTF8_on(sv); + } + } +#endif + } + } + + imp_sth->cur_tuple += 1; + + return av; +} + + +int +dbd_st_blob_read (sth, imp_sth, lobjId, offset, len, destrv, destoffset) + SV *sth; + imp_sth_t *imp_sth; + int lobjId; + long offset; + long len; + SV *destrv; + long destoffset; +{ + D_imp_dbh_from_sth; + int ret, lobj_fd, nbytes, nread; + PGresult* result; + ExecStatusType status; + SV *bufsv; + char *tmp; + + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_blob_read\n"); } + /* safety check */ + if (lobjId <= 0) { + pg_error(sth, -1, "dbd_st_blob_read: lobjId <= 0"); + return 0; + } + if (offset < 0) { + pg_error(sth, -1, "dbd_st_blob_read: offset < 0"); + return 0; + } + if (len < 0) { + pg_error(sth, -1, "dbd_st_blob_read: len < 0"); + return 0; + } + if (! SvROK(destrv)) { + pg_error(sth, -1, "dbd_st_blob_read: destrv not a reference"); + return 0; + } + if (destoffset < 0) { + pg_error(sth, -1, "dbd_st_blob_read: destoffset < 0"); + return 0; + } + + /* dereference destination and ensure it's writable string */ + bufsv = SvRV(destrv); + if (! destoffset) { + sv_setpvn(bufsv, "", 0); + } + + /* execute begin + result = PQexec(imp_dbh->conn, "begin"); + status = result ? PQresultStatus(result) : -1; + PQclear(result); + if (status != PGRES_COMMAND_OK) { + pg_error(sth, status, PQerrorMessage(imp_dbh->conn)); + return 0; + } + */ + + /* open large object */ + lobj_fd = lo_open(imp_dbh->conn, lobjId, INV_READ); + if (lobj_fd < 0) { + pg_error(sth, -1, PQerrorMessage(imp_dbh->conn)); + return 0; + } + + /* seek on large object */ + if (offset > 0) { + ret = lo_lseek(imp_dbh->conn, lobj_fd, offset, SEEK_SET); + if (ret < 0) { + pg_error(sth, -1, PQerrorMessage(imp_dbh->conn)); + return 0; + } + } + + /* read from large object */ + nread = 0; + SvGROW(bufsv, destoffset + nread + BUFSIZ + 1); + tmp = (SvPVX(bufsv)) + destoffset + nread; + while ((nbytes = lo_read(imp_dbh->conn, lobj_fd, tmp, BUFSIZ)) > 0) { + nread += nbytes; + /* break if user wants only a specified chunk */ + if (len > 0 && nread > len) { + nread = len; + break; + } + SvGROW(bufsv, destoffset + nread + BUFSIZ + 1); + tmp = (SvPVX(bufsv)) + destoffset + nread; + } + + /* terminate string */ + SvCUR_set(bufsv, destoffset + nread); + *SvEND(bufsv) = '\0'; + + /* close large object */ + ret = lo_close(imp_dbh->conn, lobj_fd); + if (ret < 0) { + pg_error(sth, -1, PQerrorMessage(imp_dbh->conn)); + return 0; + } + + /* execute end + result = PQexec(imp_dbh->conn, "end"); + status = result ? PQresultStatus(result) : -1; + PQclear(result); + if (status != PGRES_COMMAND_OK) { + pg_error(sth, status, PQerrorMessage(imp_dbh->conn)); + return 0; + } + */ + + return nread; +} + + +int +dbd_st_rows (sth, imp_sth) + SV *sth; + imp_sth_t *imp_sth; +{ + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_rows\n"); } + + return imp_sth->rows; +} + + +int +dbd_st_finish (sth, imp_sth) + SV *sth; + imp_sth_t *imp_sth; +{ + dTHR; + + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_finish\n"); } + + if (DBIc_ACTIVE(imp_sth) && imp_sth->result) { + PQclear(imp_sth->result); + imp_sth->result = 0; + imp_sth->rows = 0; + } + + DBIc_ACTIVE_off(imp_sth); + return 1; +} + + +void +dbd_st_destroy (sth, imp_sth) + SV *sth; + imp_sth_t *imp_sth; +{ + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_destroy\n"); } + + /* Free off contents of imp_sth */ + + Safefree(imp_sth->statement); + if (imp_sth->result) { + PQclear(imp_sth->result); + imp_sth->result = 0; + } + + if (imp_sth->out_params_av) + sv_free((SV*)imp_sth->out_params_av); + + if (imp_sth->all_params_hv) { + HV *hv = imp_sth->all_params_hv; + SV *sv; + char *key; + I32 retlen; + hv_iterinit(hv); + while( (sv = hv_iternextsv(hv, &key, &retlen)) != NULL ) { + if (sv != &sv_undef) { + phs_t *phs_tpl = (phs_t*)(void*)SvPVX(sv); + sv_free(phs_tpl->sv); + } + } + sv_free((SV*)imp_sth->all_params_hv); + } + + DBIc_IMPSET_off(imp_sth); /* let DBI know we've done it */ +} + + +int +dbd_st_STORE_attrib (sth, imp_sth, keysv, valuesv) + SV *sth; + imp_sth_t *imp_sth; + SV *keysv; + SV *valuesv; +{ + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_STORE\n"); } + + return FALSE; +} + + +SV * +dbd_st_FETCH_attrib (sth, imp_sth, keysv) + SV *sth; + imp_sth_t *imp_sth; + SV *keysv; +{ + STRLEN kl; + char *key = SvPV(keysv,kl); + int i, sz; + SV *retsv = Nullsv; + + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_FETCH\n"); } + + if (! imp_sth->result) { + return Nullsv; + } + + i = DBIc_NUM_FIELDS(imp_sth); + + if (kl == 4 && strEQ(key, "NAME")) { + AV *av = newAV(); + retsv = newRV(sv_2mortal((SV*)av)); + while(--i >= 0) { + av_store(av, i, newSVpv(PQfname(imp_sth->result, i),0)); + } + } else if ( kl== 4 && strEQ(key, "TYPE")) { + /* Need to convert the Pg type to ANSI/SQL type. */ + AV *av = newAV(); + retsv = newRV(sv_2mortal((SV*)av)); + while(--i >= 0) { + av_store(av, i, newSViv(sql_pg_type( imp_sth, + PQfname(imp_sth->result, i), + PQftype(imp_sth->result, i)))); + } + } else if (kl==9 && strEQ(key, "PRECISION")) { + AV *av = newAV(); + retsv = newRV(sv_2mortal((SV*)av)); + while(--i >= 0) { + sz = PQfsize(imp_sth->result, i); + av_store(av, i, sz > 0 ? newSViv(sz) : &sv_undef); + } + } else if (kl==5 && strEQ(key, "SCALE")) { + AV *av = newAV(); + retsv = newRV(sv_2mortal((SV*)av)); + while(--i >= 0) { + av_store(av, i, &sv_undef); + } + } else if (kl==8 && strEQ(key, "NULLABLE")) { + AV *av = newAV(); + retsv = newRV(sv_2mortal((SV*)av)); + while(--i >= 0) { + av_store(av, i, newSViv(2)); + } + } else if (kl==10 && strEQ(key, "CursorName")) { + retsv = &sv_undef; + } else if (kl==11 && strEQ(key, "RowsInCache")) { + retsv = &sv_undef; + } else if (kl==7 && strEQ(key, "pg_size")) { + AV *av = newAV(); + retsv = newRV(sv_2mortal((SV*)av)); + while(--i >= 0) { + av_store(av, i, newSViv(PQfsize(imp_sth->result, i))); + } + } else if (kl==7 && strEQ(key, "pg_type")) { + AV *av = newAV(); + char *type_nam; + retsv = newRV(sv_2mortal((SV*)av)); + while(--i >= 0) { + switch (PQftype(imp_sth->result, i)) { + case 16: + type_nam = "bool"; + break; + case 17: + type_nam = "bytea"; + break; + case 18: + type_nam = "char"; + break; + case 19: + type_nam = "name"; + break; + case 20: + type_nam = "int8"; + break; + case 21: + type_nam = "int2"; + break; + case 22: + type_nam = "int28"; + break; + case 23: + type_nam = "int4"; + break; + case 24: + type_nam = "regproc"; + break; + case 25: + type_nam = "text"; + break; + case 26: + type_nam = "oid"; + break; + case 27: + type_nam = "tid"; + break; + case 28: + type_nam = "xid"; + break; + case 29: + type_nam = "cid"; + break; + case 30: + type_nam = "oid8"; + break; + case 32: + type_nam = "SET"; + break; + case 210: + type_nam = "smgr"; + break; + case 600: + type_nam = "point"; + break; + case 601: + type_nam = "lseg"; + break; + case 602: + type_nam = "path"; + break; + case 603: + type_nam = "box"; + break; + case 604: + type_nam = "polygon"; + break; + case 605: + type_nam = "filename"; + break; + case 628: + type_nam = "line"; + break; + case 629: + type_nam = "_line"; + break; + case 700: + type_nam = "float4"; + break; + case 701: + type_nam = "float8"; + break; + case 702: + type_nam = "abstime"; + break; + case 703: + type_nam = "reltime"; + break; + case 704: + type_nam = "tinterval"; + break; + case 705: + type_nam = "unknown"; + break; + case 718: + type_nam = "circle"; + break; + case 719: + type_nam = "_circle"; + break; + case 790: + type_nam = "money"; + break; + case 791: + type_nam = "_money"; + break; + case 810: + type_nam = "oidint2"; + break; + case 910: + type_nam = "oidint4"; + break; + case 911: + type_nam = "oidname"; + break; + case 1000: + type_nam = "_bool"; + break; + case 1001: + type_nam = "_bytea"; + break; + case 1002: + type_nam = "_char"; + break; + case 1003: + type_nam = "_name"; + break; + case 1005: + type_nam = "_int2"; + break; + case 1006: + type_nam = "_int28"; + break; + case 1007: + type_nam = "_int4"; + break; + case 1008: + type_nam = "_regproc"; + break; + case 1009: + type_nam = "_text"; + break; + case 1028: + type_nam = "_oid"; + break; + case 1010: + type_nam = "_tid"; + break; + case 1011: + type_nam = "_xid"; + break; + case 1012: + type_nam = "_cid"; + break; + case 1013: + type_nam = "_oid8"; + break; + case 1014: + type_nam = "_lock"; + break; + case 1015: + type_nam = "_stub"; + break; + case 1016: + type_nam = "_ref"; + break; + case 1017: + type_nam = "_point"; + break; + case 1018: + type_nam = "_lseg"; + break; + case 1019: + type_nam = "_path"; + break; + case 1020: + type_nam = "_box"; + break; + case 1021: + type_nam = "_float4"; + break; + case 1022: + type_nam = "_float8"; + break; + case 1023: + type_nam = "_abstime"; + break; + case 1024: + type_nam = "_reltime"; + break; + case 1025: + type_nam = "_tinterval"; + break; + case 1026: + type_nam = "_filename"; + break; + case 1027: + type_nam = "_polygon"; + break; + case 1033: + type_nam = "aclitem"; + break; + case 1034: + type_nam = "_aclitem"; + break; + case 1042: + type_nam = "bpchar"; + break; + case 1043: + type_nam = "varchar"; + break; + case 1082: + type_nam = "date"; + break; + case 1083: + type_nam = "time"; + break; + case 1182: + type_nam = "_date"; + break; + case 1183: + type_nam = "_time"; + break; + case 1184: + type_nam = "datetime"; + break; + case 1185: + type_nam = "_datetime"; + break; + case 1186: + type_nam = "timespan"; + break; + case 1187: + type_nam = "_timespan"; + break; + case 1231: + type_nam = "_numeric"; + break; + case 1296: + type_nam = "timestamp"; + break; + case 1700: + type_nam = "numeric"; + break; + + default: + type_nam = "unknown"; + + } + av_store(av, i, newSVpv(type_nam, 0)); + } + } else if (kl==13 && strEQ(key, "pg_oid_status")) { + retsv = newSVpv((char *)PQoidStatus(imp_sth->result), 0); + } else if (kl==13 && strEQ(key, "pg_cmd_status")) { + retsv = newSVpv((char *)PQcmdStatus(imp_sth->result), 0); + } else { + return Nullsv; + } + + return sv_2mortal(retsv); +} + + +/* end of dbdimp.c */ diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/dbdimp.h b/install/5.005/DBD-Pg-1.22-fixvercmp/dbdimp.h new file mode 100644 index 0000000..58c105b --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/dbdimp.h @@ -0,0 +1,81 @@ +/* + $Id: dbdimp.h,v 1.1 2004-04-29 09:21:28 ivan Exp $ + + Copyright (c) 1997,1998,1999,2000 Edmund Mergl + Portions Copyright (c) 1994,1995,1996,1997 Tim Bunce + + You may distribute under the terms of either the GNU General Public + License or the Artistic License, as specified in the Perl README file. +*/ + +#ifdef WIN32 +#define snprintf _snprintf +#endif + +/* Define drh implementor data structure */ +struct imp_drh_st { + dbih_drc_t com; /* MUST be first element in structure */ +}; + +/* Define dbh implementor data structure */ +struct imp_dbh_st { + dbih_dbc_t com; /* MUST be first element in structure */ + + PGconn * conn; /* connection structure */ + int init_commit; /* initialize AutoCommit */ + int pg_auto_escape; /* initialize AutoEscape */ + int pg_bool_tf; /* do bools return 't'/'f' */ +#ifdef SvUTF8_off + int pg_enable_utf8; /* should we attempt to make utf8 strings? */ +#endif +}; + +/* Define sth implementor data structure */ +struct imp_sth_st { + dbih_stc_t com; /* MUST be first element in structure */ + + PGresult* result; /* result structure */ + int cur_tuple; /* current tuple */ + int rows; /* number of affected rows */ + + /* Input Details */ + char *statement; /* sql (see sth_scan) */ + HV *all_params_hv; /* all params, keyed by name */ + AV *out_params_av; /* quick access to inout params */ + int pg_pad_empty; /* convert ""->" " when binding */ + int all_params_len; /* length-sum of all params */ + + /* (In/)Out Parameter Details */ + bool has_inout_params; +}; + + +#define sword signed int +#define sb2 signed short +#define ub2 unsigned short + +typedef struct phs_st phs_t; /* scalar placeholder */ + +struct phs_st { /* scalar placeholder EXPERIMENTAL */ + sword ftype; /* external OCI field type */ + + SV *sv; /* the scalar holding the value */ + int sv_type; /* original sv type at time of bind */ + bool is_inout; + + IV maxlen; /* max possible len (=allocated buffer) */ + + /* these will become an array */ + sb2 indp; /* null indicator */ + char *progv; + ub2 arcode; + IV alen; /* effective length ( <= maxlen ) */ + + int alen_incnull; /* 0 or 1 if alen should include null */ + char name[1]; /* struct is malloc'd bigger as needed */ +}; + + +SV * dbd_db_pg_notifies (SV *dbh, imp_dbh_t *imp_dbh); + +/* end of dbdimp.h */ diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/eg/ApacheDBI.pl b/install/5.005/DBD-Pg-1.22-fixvercmp/eg/ApacheDBI.pl new file mode 100755 index 0000000..b084f70 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/eg/ApacheDBI.pl @@ -0,0 +1,70 @@ +#!/usr/local/bin/perl + +# $Id: ApacheDBI.pl,v 1.1 2004-04-29 09:21:28 ivan Exp $ + +# don't forget to create in postgres the user who is running +# the httpd, eg 'createuser nobody' ! +# +# demo script, tested with: +# - PostgreSQL-7.1.1 +# - apache_1.3.12 +# - mod_perl-1.23 +# - perl5.6.0 +# - DBI-1.14 + +use CGI; +use DBI; +use strict; + +my $query = new CGI; + +print $query->header, + $query->start_html(-title=>'A Simple Example'), + $query->startform, + "<CENTER><H3>Testing Module DBI</H3></CENTER>", + "<P><CENTER><TABLE CELLPADDING=4 CELLSPACING=2 BORDER=1>", + "<TR><TD>Enter the data source: </TD>", + "<TD>", $query->textfield(-name=>'data_source', -size=>40, -default=>'dbi:Pg:dbname=template1'), "</TD>", + "</TR>", + "<TR><TD>Enter the user name: </TD>", + "<TD>", $query->textfield(-name=>'username'), "</TD>", + "</TR>", + "<TR><TD>Enter the password: </TD>", + "<TD>", $query->textfield(-name=>'auth'), "</TD>", + "</TR>", + "<TR><TD>Enter the select command: </TD>", + "<TD>", $query->textfield(-name=>'cmd', -size=>40), "</TD>", + "</TR>", + "</TABLE></CENTER><P>", + "<CENTER>", $query->submit(-value=>'Submit'), "</CENTER>", + $query->endform; + +if ($query->param) { + + my $data_source = $query->param('data_source'); + my $username = $query->param('username'); + my $auth = $query->param('auth'); + my $cmd = $query->param('cmd'); + my $dbh = DBI->connect($data_source, $username, $auth); + if ($dbh) { + my $sth = $dbh->prepare($cmd); + my $ret = $sth->execute; + if ($ret) { + my($i, $ary_ref); + print "<P><CENTER><TABLE CELLPADDING=4 CELLSPACING=2 BORDER=1>\n"; + while ($ary_ref = $sth->fetchrow_arrayref) { + print "<TR><TD>", join("</TD><TD>", @$ary_ref), "</TD></TR>\n"; + } + print "</TABLE></CENTER><P>\n"; + $sth->finish; + } else { + print "<CENTER><H2>", $DBI::errstr, "</H2></CENTER>\n"; + } + $dbh->disconnect; + } else { + print "<CENTER><H2>", $DBI::errstr, "</H2></CENTER>\n"; + } +} + +print $query->end_html; + diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/eg/lotest.pl b/install/5.005/DBD-Pg-1.22-fixvercmp/eg/lotest.pl new file mode 100644 index 0000000..6192c49 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/eg/lotest.pl @@ -0,0 +1,74 @@ +#!/usr/bin/perl -w + +use strict; + +use DBI; +use DBD::Pg; + +my $dsn = "dbname=p1"; +my $dbh = DBI->connect('dbi:Pg:dbname=p1', undef, undef, { AutoCommit => 1 }); + +my $buf = 'abcdefghijklmnopqrstuvwxyz' x 400; + +my $id = write_blob($dbh, undef, $buf); + +my $dat = read_blob($dbh, $id); + +print "Done\n"; + +sub write_blob { + my ($dbh, $lobj_id, $data) = @_; + + # begin transaction + $dbh->{AutoCommit} = 0; + + # Create a new lo if we are not passed an lo object ID. + unless ($lobj_id) { + # Create the object. + $lobj_id = $dbh->func($dbh->{'pg_INV_WRITE'}, 'lo_creat'); + } + + # Open it to get a file descriptor. + my $lobj_fd = $dbh->func($lobj_id, $dbh->{'pg_INV_WRITE'}, 'lo_open'); + + $dbh->func($lobj_fd, 0, 0, 'lo_lseek'); + + # Write some data to it. + my $len = $dbh->func($lobj_fd, $data, length($data), 'lo_write'); + + die "Errors writing lo\n" if $len != length($data); + + # Close 'er up. + $dbh->func($lobj_fd, 'lo_close') or die "Problems closing lo object\n"; + + # end transaction + $dbh->{AutoCommit} = 1; + + return $lobj_id; +} + +sub read_blob { + my ($dbh, $lobj_id) = @_; + my $data = ''; + my $read_len = 256; + my $chunk = ''; + + # begin transaction + $dbh->{AutoCommit} = 0; + + my $lobj_fd = $dbh->func($lobj_id, $dbh->{'pg_INV_READ'}, 'lo_open'); + + $dbh->func($lobj_fd, 0, 0, 'lo_lseek'); + + # Pull out all the data. + while ($dbh->func($lobj_fd, $chunk, $read_len, 'lo_read')) { + $data .= $chunk; + } + + $dbh->func($lobj_fd, 'lo_close') or die "Problems closing lo object\n"; + + # end transaction + $dbh->{AutoCommit} = 1; + + return $data; +} diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/eg/notify_test.patch b/install/5.005/DBD-Pg-1.22-fixvercmp/eg/notify_test.patch new file mode 100644 index 0000000..6f8acf8 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/eg/notify_test.patch @@ -0,0 +1,82 @@ +diff -r --unified DBD-Pg-1.00/test.pl DBD-Pg-1.00.alex/test.pl +--- DBD-Pg-1.00/test.pl Sun May 27 10:10:13 2001 ++++ DBD-Pg-1.00.alex/test.pl Sun Jun 10 15:38:09 2001 +@@ -40,7 +40,7 @@ + my $dsn_main = "dbi:Pg:dbname=$dbmain"; + my $dsn_test = "dbi:Pg:dbname=$dbtest"; + +-my ($dbh0, $dbh, $sth); ++my ($dbh0, $dbh, $dbh1, $sth); + + #DBI->trace(3); # make your choice + +@@ -445,16 +445,56 @@ + # end transaction + $dbh->{AutoCommit} = 1; + ++# compare large objects ++ + ( $dbh->func($lobjId, 'lo_unlink') ) + and print "\$dbh->func(lo_unlink) ...... ok\n" + or print "\$dbh->func(lo_unlink) ...... not ok\n"; + +-# compare large objects +- + ( $pgin cmp $buf and $pgin cmp $blob ) + and print "compare blobs .............. not ok\n" + or print "compare blobs .............. ok\n"; + ++my $fd; ++( $fd=$dbh->func( 'getfd') ) ++ and print "\$dbh->func(getfd) .......... ok\n" ++ or print "\$dbh->func(getfd) .......... not ok\n"; ++ ++( $dbh->do( 'LISTEN test ') ) ++ and print "\$dbh->do('LISTEN test') .... ok\n" ++ or print "\$dbh->do('LISTEN test') .... not ok\n"; ++ ++( $dbh1 = DBI->connect("$dsn_test", '', '', { AutoCommit => 1 }) ) ++ and print "DBI->connect (for notify)... ok\n" ++ or die "DBI->connect (for notify)... not ok: ", $DBI::errstr; ++ ++# there should be no data for read on $fd , until we send a notify ++ ++ my $rout; ++ my $rin = ''; ++ vec($rin,$fd,1) = 1; ++ my $nfound = select( $rout=$rin, undef, undef, 0); ++ ++( $nfound==0 ) ++ and print "select(\$fd) returns no data. ok\n" ++ or die "select(\$fd) returns no data. not ok\n"; ++ ++( $dbh1->do( 'NOTIFY test ') ) ++ and print "\$dbh1->do('NOTIFY test') ... ok\n" ++ or print "\$dbh1->do('NOTIFY test') ... not ok\n"; ++ ++ my $nfound = select( $rout=$rin, undef, undef, 1); ++ ++( $nfound==1 ) ++ and print "select(\$fd) returns data.... ok\n" ++ or die "select(\$fd) returns data.... not ok\n"; ++ ++my $notify_r; ++ ++( $notify_r = $dbh->func('notifies') ) ++ and print "\$dbh->func('notifies')...... ok\n" ++ or die "\$dbh->func('notifies')...... not ok\n"; ++ + ######################### disconnect and drop test database + + # disconnect +@@ -462,6 +502,10 @@ + ( $dbh->disconnect ) + and print "\$dbh->disconnect ........... ok\n" + or die "\$dbh->disconnect ........... not ok: ", $DBI::errstr; ++ ++( $dbh1->disconnect ) ++ and print "\$dbh1->disconnect .......... ok\n" ++ or die "\$dbh1->disconnect .......... not ok: ", $DBI::errstr; + + $dbh0->do("DROP DATABASE $dbtest"); + $dbh0->disconnect; diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/00basic.t b/install/5.005/DBD-Pg-1.22-fixvercmp/t/00basic.t new file mode 100644 index 0000000..1c0cb28 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/00basic.t @@ -0,0 +1,10 @@ +print "1..1\n"; + +use DBI; +use DBD::Pg; + +if ($DBD::Pg::VERSION) { + print "ok 1\n"; +} else { + print "not ok 1\n"; +} diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/01connect.t b/install/5.005/DBD-Pg-1.22-fixvercmp/t/01connect.t new file mode 100644 index 0000000..be17b50 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/01connect.t @@ -0,0 +1,26 @@ +use strict; +use DBI; +use Test::More; + +if (defined $ENV{DBI_DSN}) { + plan tests => 2; +} else { + plan skip_all => 'cannot test without DB info'; +} + +my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS}, + {RaiseError => 1, AutoCommit => 0} + ); + +ok((defined $dbh and $dbh->disconnect()), + 'connect with transaction' + ); + +undef $dbh; +$dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS}, + {RaiseError => 1, AutoCommit => 1}); + +ok((defined $dbh and $dbh->disconnect()), + 'connect without transaction' + ); + diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/01constants.t b/install/5.005/DBD-Pg-1.22-fixvercmp/t/01constants.t new file mode 100644 index 0000000..09907e9 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/01constants.t @@ -0,0 +1,25 @@ +use strict; +use Test::More tests => 20; + +use DBD::Pg qw(:pg_types); + +ok(PG_BOOL == 16, 'PG_BOOL'); +ok(PG_BYTEA == 17, 'PG_BYTEA'); +ok(PG_CHAR == 18, 'PG_CHAR'); +ok(PG_INT8 == 20, 'PG_INT8'); +ok(PG_INT2 == 21, 'PG_INT2'); +ok(PG_INT4 == 23, 'PG_INT4'); +ok(PG_TEXT == 25, 'PG_TEXT'); +ok(PG_OID == 26, 'PG_OID'); +ok(PG_FLOAT4 == 700, 'PG_FLOAT4'); +ok(PG_FLOAT8 == 701, 'PG_FLOAT8'); +ok(PG_ABSTIME == 702, 'PG_ABSTIME'); +ok(PG_RELTIME == 703, 'PG_RELTIME'); +ok(PG_TINTERVAL == 704, 'PG_TINTERVAL'); +ok(PG_BPCHAR == 1042, 'PG_BPCHAR'); +ok(PG_VARCHAR == 1043, 'PG_VARCHAR'); +ok(PG_DATE == 1082, 'PG_DATE'); +ok(PG_TIME == 1083, 'PG_TIME'); +ok(PG_DATETIME == 1184, 'PG_DATETIME'); +ok(PG_TIMESPAN == 1186, 'PG_TIMESPAN'); +ok(PG_TIMESTAMP == 1296, 'PG_TIMESTAMP'); diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/01setup.t b/install/5.005/DBD-Pg-1.22-fixvercmp/t/01setup.t new file mode 100644 index 0000000..d0b57a3 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/01setup.t @@ -0,0 +1,38 @@ +use strict; +use DBI; +use Test::More; + +if (defined $ENV{DBI_DSN}) { + plan tests => 3; +} else { + plan skip_all => 'cannot test without DB info'; +} + +my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS}, + {RaiseError => 1, AutoCommit => 1}); +ok(defined $dbh,'connect without transaction'); +{ + local $dbh->{PrintError} = 0; + local $dbh->{RaiseError} = 0; + $dbh->do(q{DROP TABLE test}); +} + +my $sql = <<SQL; +CREATE TABLE test ( + id int, + name text, + val text, + score float, + date timestamp default 'now()', + array text[][] +) +SQL + +ok($dbh->do($sql), + 'create table' + ); + +ok($dbh->disconnect(), + 'disconnect' + ); + diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/02prepare.t b/install/5.005/DBD-Pg-1.22-fixvercmp/t/02prepare.t new file mode 100644 index 0000000..373aca2 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/02prepare.t @@ -0,0 +1,84 @@ +use strict; +use DBI; +use Test::More; + +if (defined $ENV{DBI_DSN}) { + plan tests => 8; +} else { + plan skip_all => 'cannot test without DB info'; +} + +my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS}, + {RaiseError => 1, AutoCommit => 0} + ); +ok(defined $dbh, + 'connect with transaction' + ); + +my $sql = <<SQL; + SELECT * + FROM test +SQL + +ok($dbh->prepare($sql), + "prepare: $sql" + ); + +$sql = <<SQL; + SELECT id + FROM test +SQL + +ok($dbh->prepare($sql), + "prepare: $sql" + ); + +$sql = <<SQL; + SELECT id + , name + FROM test +SQL + +ok($dbh->prepare($sql), + "prepare: $sql" + ); + +$sql = <<SQL; + SELECT id + , name + FROM test + WHERE id = 1 +SQL + +ok($dbh->prepare($sql), + "prepare: $sql" + ); + +$sql = <<SQL; + SELECT id + , name + FROM test + WHERE id = ? +SQL + +ok($dbh->prepare($sql), + "prepare: $sql" + ); + +$sql = <<SQL; + SELECT * + FROM test + WHERE id = ? + AND name = ? + AND value = ? + AND score = ? + and data = ? +SQL + +ok($dbh->prepare($sql), + "prepare: $sql" + ); + +ok($dbh->disconnect(), + 'disconnect' + ); diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/03bind.t b/install/5.005/DBD-Pg-1.22-fixvercmp/t/03bind.t new file mode 100644 index 0000000..df7c884 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/03bind.t @@ -0,0 +1,85 @@ +use strict; +use DBI; +use Test::More; + +if (defined $ENV{DBI_DSN}) { + plan tests => 11; +} else { + plan skip_all => 'cannot test without DB info'; +} + +my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS}, + {RaiseError => 1, AutoCommit => 0} + ); +ok(defined $dbh, + 'connect with transaction' + ); + +my $sql = <<SQL; + SELECT id + , name + FROM test + WHERE id = ? +SQL +my $sth = $dbh->prepare($sql); +ok(defined $sth, + "prepare: $sql" + ); + +ok($sth->bind_param(1, 'foo'), + 'bind int column with string' + ); + +ok($sth->bind_param(1, 1), + 'rebind int column with int' + ); + +$sql = <<SQL; + SELECT id + , name + FROM test + WHERE id = ? + AND name = ? +SQL +$sth = $dbh->prepare($sql); +ok(defined $sth, + "prepare: $sql" + ); + +ok($sth->bind_param(1, 'foo'), + 'bind int column with string', + ); +ok($sth->bind_param(2, 'bar'), + 'bind string column with text' + ); +ok($sth->bind_param(2, 'baz'), + 'rebind string column with text' + ); + +ok($sth->finish(), + 'finish' + ); + +# Make sure that we get warnings when we try to use SQL_BINARY. +{ + local $SIG{__WARN__} = + sub { ok($_[0] =~ /^Use of SQL type SQL_BINARY/, + 'warning with SQL_BINARY' + ); + }; + + $sql = <<SQL; + SELECT id + , name + FROM test + WHERE id = ? + AND name = ? +SQL + $sth = $dbh->prepare($sql); + + $sth->bind_param(1, 'foo', DBI::SQL_BINARY); +} + +ok($dbh->disconnect(), + 'disconnect' + ); diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/04execute.t b/install/5.005/DBD-Pg-1.22-fixvercmp/t/04execute.t new file mode 100644 index 0000000..9643878 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/04execute.t @@ -0,0 +1,113 @@ +use strict; +use DBI; +use Test::More; + +if (defined $ENV{DBI_DSN}) { + plan tests => 13; +} else { + plan skip_all => 'cannot test without DB info'; +} + +my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS}, + {RaiseError => 1, AutoCommit => 0} + ); +ok(defined $dbh, + 'connect with transaction' + ); + +my $sql = <<SQL; + SELECT id + , name + FROM test + WHERE id = ? +SQL +my $sth = $dbh->prepare($sql); +ok(defined $sth, + "prepare: $sql" + ); + +$sth->bind_param(1, 1); +ok($sth->execute(), + 'exectute with one bind param' + ); + +$sth->bind_param(1, 2); +ok($sth->execute(), + 'exectute with rebinding one param' + ); + +$sql = <<SQL; + SELECT id + , name + FROM test + WHERE id = ? + AND name = ? +SQL +$sth = $dbh->prepare($sql); +ok(defined $sth, + "prepare: $sql" + ); + +$sth->bind_param(1, 2); +$sth->bind_param(2, 'foo'); +ok($sth->execute(), + 'exectute with two bind params' + ); + +eval { + local $dbh->{PrintError} = 0; + $sth = $dbh->prepare($sql); + $sth->bind_param(1, 2); + $sth->execute(); +}; +ok(!$@, + 'execute with only first of two params bound' + ); + +eval { + local $dbh->{PrintError} = 0; + $sth = $dbh->prepare($sql); + $sth->bind_param(2, 'foo'); + $sth->execute(); +}; +ok(!$@, + 'execute with only second of two params bound' + ); + +eval { + local $dbh->{PrintError} = 0; + $sth = $dbh->prepare($sql); + $sth->execute(); +}; +ok(!$@, + 'execute with neither of two params bound' + ); + +$sth = $dbh->prepare($sql); +ok($sth->execute(1, 'foo'), + 'execute with both params bound in execute' + ); + +eval { + local $dbh->{PrintError} = 0; + $sth = $dbh->prepare(q{ + SELECT id + , name + FROM test + WHERE id = ? + AND name = ? + }); + $sth->execute(1); +}; +ok($@, + 'execute with only one of two params bound in execute' + ); + + +ok($sth->finish(), + 'finish' + ); + +ok($dbh->disconnect(), + 'disconnect' + ); diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/05fetch.t b/install/5.005/DBD-Pg-1.22-fixvercmp/t/05fetch.t new file mode 100644 index 0000000..b6f8f66 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/05fetch.t @@ -0,0 +1,131 @@ +use strict; +use DBI; +use Test::More; + +if (defined $ENV{DBI_DSN}) { + plan tests => 10; +} else { + plan skip_all => 'cannot test without DB info'; +} + +my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS}, + {RaiseError => 1, AutoCommit => 0} + ); +ok(defined $dbh, + 'connect with transaction' + ); + +$dbh->do(q{INSERT INTO test (id, name, val) VALUES (1, 'foo', 'horse')}); +$dbh->do(q{INSERT INTO test (id, name, val) VALUES (2, 'bar', 'chicken')}); +$dbh->do(q{INSERT INTO test (id, name, val) VALUES (3, 'baz', 'pig')}); +ok($dbh->commit(), + 'commit' + ); + +my $sql = <<SQL; + SELECT id + , name + FROM test +SQL +my $sth = $dbh->prepare($sql); +$sth->execute(); + +my $rows = 0; +while (my ($id, $name) = $sth->fetchrow_array()) { + if (defined($id) && defined($name)) { + $rows++; + } +} +$sth->finish(); +ok($rows == 3, + 'fetch three rows' + ); + +$sql = <<SQL; + SELECT id + , name + FROM test + WHERE 1 = 0 +SQL +$sth = $dbh->prepare($sql); +$sth->execute(); + +$rows = 0; +while (my ($id, $name) = $sth->fetchrow_array()) { + $rows++; +} +$sth->finish(); + +ok($rows == 0, + 'fetch zero rows' + ); + +$sql = <<SQL; + SELECT id + , name + FROM test + WHERE id = ? +SQL +$sth = $dbh->prepare($sql); +$sth->execute(1); + +$rows = 0; +while (my ($id, $name) = $sth->fetchrow_array()) { + if (defined($id) && defined($name)) { + $rows++; + } +} +$sth->finish(); + +ok($rows == 1, + 'fetch one row on id' + ); + +# Attempt to test whether or not we can get unicode out of the database +# correctly. Reuse the previous sth. +SKIP: { + eval "use Encode"; + skip "need Encode module for unicode tests", 3 if $@; + local $dbh->{pg_enable_utf8} = 1; + $dbh->do("INSERT INTO test (id, name, val) VALUES (4, '\001\000dam', 'cow')"); + $sth->execute(4); + my ($id, $name) = $sth->fetchrow_array(); + ok(Encode::is_utf8($name), + 'returned data has utf8 bit set' + ); + is(length($name), 4, + 'returned utf8 data is not corrupted' + ); + $sth->finish(); + $sth->execute(1); + my ($id2, $name2) = $sth->fetchrow_array(); + ok(! Encode::is_utf8($name2), + 'returned ASCII data has not got utf8 bit set' + ); + $sth->finish(); +} + +$sql = <<SQL; + SELECT id + , name + FROM test + WHERE name = ? +SQL +$sth = $dbh->prepare($sql); +$sth->execute('foo'); + +$rows = 0; +while (my ($id, $name) = $sth->fetchrow_array()) { + if (defined($id) && defined($name)) { + $rows++; + } +} +$sth->finish(); + +ok($rows == 1, + 'fetch one row on name' + ); + +ok($dbh->disconnect(), + 'disconnect' + ); diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/06disconnect.t b/install/5.005/DBD-Pg-1.22-fixvercmp/t/06disconnect.t new file mode 100644 index 0000000..5d76bc0 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/06disconnect.t @@ -0,0 +1,31 @@ +use strict; +use DBI; +use Test::More; + +if (defined $ENV{DBI_DSN}) { + plan tests => 3; +} else { + plan skip_all => 'cannot test without DB info'; +} + +my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS}, + {RaiseError => 1, AutoCommit => 0} + ); +ok(defined $dbh, + 'connect with transaction' + ); + +ok($dbh->disconnect(), + 'disconnect' + ); + +$dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS}, + {RaiseError => 1, AutoCommit => 0} + ); + +$dbh->disconnect(); +$dbh->disconnect(); +$dbh->disconnect(); +ok($dbh->disconnect(), + 'disconnect on already disconnected dbh' + ); diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/07reuse.t b/install/5.005/DBD-Pg-1.22-fixvercmp/t/07reuse.t new file mode 100644 index 0000000..d09dfc0 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/07reuse.t @@ -0,0 +1,28 @@ +use strict; +use DBI; +use Test::More; + +if (defined $ENV{DBI_DSN}) { + plan tests => 3; +} else { + plan skip_all => 'cannot test without DB info'; +} + +my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS}, + {RaiseError => 1, PrintError => 0, AutoCommit => 0} + ); +ok(defined $dbh, + 'connect with transaction' + ); + +my $sth = $dbh->prepare(q{SELECT * FROM test}); +ok($dbh->disconnect(), + 'disconnect with un-finished statement' + ); + +eval { + $sth->execute(); +}; +ok($@, + 'execute on disconnected statement' + ); diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/08txn.t b/install/5.005/DBD-Pg-1.22-fixvercmp/t/08txn.t new file mode 100644 index 0000000..467aa31 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/08txn.t @@ -0,0 +1,102 @@ +use strict; +use DBI; +use Test::More; + +if (defined $ENV{DBI_DSN}) { + plan tests => 18; +} else { + plan skip_all => 'cannot test without DB info'; +} + +my $dbh1 = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS}, + {RaiseError => 1, AutoCommit => 0} + ); +ok(defined $dbh1, + 'connect first dbh' + ); + +my $dbh2 = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS}, + {RaiseError => 1, AutoCommit => 0} + ); +ok(defined $dbh2, + 'connect second dbh' + ); + +$dbh1->do(q{DELETE FROM test}); +ok($dbh1->commit(), + 'delete' + ); + +my $rows = ($dbh1->selectrow_array(q{SELECT COUNT(*) FROM test}))[0]; +ok($rows == 0, + 'fetch on empty table from dbh1' + ); + +$rows = ($dbh2->selectrow_array(q{SELECT COUNT(*) FROM test}))[0]; +ok($rows == 0, + 'fetch on empty table from dbh2' + ); + +$dbh1->do(q{INSERT INTO test (id, name, val) VALUES (1, 'foo', 'horse')}); +$dbh1->do(q{INSERT INTO test (id, name, val) VALUES (2, 'bar', 'chicken')}); +$dbh1->do(q{INSERT INTO test (id, name, val) VALUES (3, 'baz', 'pig')}); + +$rows = ($dbh1->selectrow_array(q{SELECT COUNT(*) FROM test}))[0]; +ok($rows == 3, + 'fetch three rows on dbh1' + ); + +$rows = ($dbh2->selectrow_array(q{SELECT COUNT(*) FROM test}))[0]; +ok($rows == 0, + 'fetch on dbh2 before commit' + ); + +ok($dbh1->commit(), + 'commit work' + ); + +$rows = ($dbh1->selectrow_array(q{SELECT COUNT(*) FROM test}))[0]; +ok($rows == 3, + 'fetch on dbh1 after commit' + ); + +$rows = ($dbh2->selectrow_array(q{SELECT COUNT(*) FROM test}))[0]; +ok($rows == 3, + 'fetch on dbh2 after commit' + ); + +ok($dbh1->do(q{DELETE FROM test}), + 'delete' + ); + +$rows = ($dbh1->selectrow_array(q{SELECT COUNT(*) FROM test}))[0]; +ok($rows == 0, + 'fetch on empty table from dbh1' + ); + +$rows = ($dbh2->selectrow_array(q{SELECT COUNT(*) FROM test}))[0]; +ok($rows == 3, + 'fetch on from dbh2 without commit' + ); + +ok($dbh1->rollback(), + 'rollback' + ); + +$rows = ($dbh1->selectrow_array(q{SELECT COUNT(*) FROM test}))[0]; +ok($rows == 3, + 'fetch on from dbh1 after rollback' + ); + +$rows = ($dbh2->selectrow_array(q{SELECT COUNT(*) FROM test}))[0]; +ok($rows == 3, + 'fetch on from dbh2 after rollback' + ); + +ok($dbh1->disconnect(), + 'disconnect on dbh1' +); + +ok($dbh2->disconnect(), + 'disconnect on dbh2' +); diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/09autocommit.t b/install/5.005/DBD-Pg-1.22-fixvercmp/t/09autocommit.t new file mode 100644 index 0000000..9b1b69f --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/09autocommit.t @@ -0,0 +1,68 @@ +use strict; +use DBI; +use Test::More; + +if (defined $ENV{DBI_DSN}) { + plan tests => 12; +} else { + plan skip_all => 'cannot test without DB info'; +} + +my $dbh1 = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS}, + {RaiseError => 1, AutoCommit => 1} + ); +ok(defined $dbh1, + 'connect first dbh' + ); + +my $dbh2 = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS}, + {RaiseError => 1, AutoCommit => 1} + ); +ok(defined $dbh2, + 'connect second dbh' + ); + +ok($dbh1->do(q{DELETE FROM test}), + 'delete' + ); + +my $rows = ($dbh1->selectrow_array(q{SELECT COUNT(*) FROM test}))[0]; +ok($rows == 0, + 'fetch on empty table from dbh1' + ); + +$rows = ($dbh2->selectrow_array(q{SELECT COUNT(*) FROM test}))[0]; +ok($rows == 0, + 'fetch on empty table from dbh2' + ); + +ok($dbh1->do(q{INSERT INTO test (id, name, val) VALUES (1, 'foo', 'horse')}), + 'insert' + ); + +$rows = ($dbh1->selectrow_array(q{SELECT COUNT(*) FROM test}))[0]; +ok($rows == 1, + 'fetch one row from dbh1' + ); + +$rows = ($dbh2->selectrow_array(q{SELECT COUNT(*) FROM test}))[0]; +ok($rows == 1, + 'fetch one row from dbh1' + ); + +local $SIG{__WARN__} = sub {}; +ok(!$dbh1->commit(), + 'commit' + ); + +ok(!$dbh1->rollback(), + 'rollback' + ); + +ok($dbh1->disconnect(), + 'disconnect on dbh1' +); + +ok($dbh2->disconnect(), + 'disconnect on dbh2' +); diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/11quoting.t b/install/5.005/DBD-Pg-1.22-fixvercmp/t/11quoting.t new file mode 100644 index 0000000..afec963 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/11quoting.t @@ -0,0 +1,50 @@ +use strict; +use DBI; +use Test::More; + +if (defined $ENV{DBI_DSN}) { + plan tests => 8; +} else { + plan skip_all => 'cannot test without DB info'; +} + +my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS}, + {RaiseError => 1, AutoCommit => 0} + ); +ok(defined $dbh, + 'connect with transaction' + ); + +my %tests = ( + one=>["'", "'\\" . sprintf("%03o", ord("'")) . "'"], + two=>["''", "'" . ("\\" . sprintf("%03o", ord("'")))x2 . "'"], + three=>["\\", "'\\" . sprintf("%03o", ord("\\")) . "'"], + four=>["\\'", sprintf("'\\%03o\\%03o'", ord("\\"), ord("'"))], + five=>["\\'?:", sprintf("'\\%03o\\%03o?:'", ord("\\"), ord("'"))], + ); + +foreach my $test (keys %tests) { + my ($unq, $quo, $ref); + + $unq = $tests{$test}->[0]; + $ref = $tests{$test}->[1]; + $quo = $dbh->quote($unq); + + ok($quo eq $ref, + "$test: $unq -> expected $quo got $ref" + ); +} + +# Make sure that SQL_BINARY doesn't work. +# eval { $dbh->quote('foo', { TYPE => DBI::SQL_BINARY })}; +eval { + local $dbh->{PrintError} = 0; + $dbh->quote('foo', DBI::SQL_BINARY); +}; +ok($@ && $@ =~ /Use of SQL_BINARY invalid in quote/, + 'SQL_BINARY' +); + +ok($dbh->disconnect(), + 'disconnect' + ); diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/12placeholders.t b/install/5.005/DBD-Pg-1.22-fixvercmp/t/12placeholders.t new file mode 100644 index 0000000..bd79ea7 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/12placeholders.t @@ -0,0 +1,125 @@ +use strict; +use DBI; +use Test::More; + +if (defined $ENV{DBI_DSN}) { + plan tests => 9; +} else { + plan skip_all => 'cannot test without DB info'; +} + +my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS}, + {RaiseError => 1, AutoCommit => 0} + ); +ok(defined $dbh, + 'connect with transaction' + ); + +my $quo = $dbh->quote("\\'?:"); +my $sth = $dbh->prepare(qq{ + INSERT INTO test (name) VALUES ($quo) + }); +$sth->execute(); + +my $sql = <<SQL; + SELECT name + FROM test + WHERE name = $quo; +SQL +$sth = $dbh->prepare($sql); +$sth->execute(); + +my ($retr) = $sth->fetchrow_array(); +ok((defined($retr) && $retr eq "\\'?:"), + 'fetch' + ); + +eval { + local $dbh->{PrintError} = 0; + $sth->execute('foo'); +}; +ok($@, + 'execute with one bind param where none expected' + ); + +$sql = <<SQL; + SELECT name + FROM test + WHERE name = ? +SQL +$sth = $dbh->prepare($sql); + +$sth->execute("\\'?:"); + +($retr) = $sth->fetchrow_array(); +ok((defined($retr) && $retr eq "\\'?:"), + 'execute with ? placeholder' + ); + +$sql = <<SQL; + SELECT name + FROM test + WHERE name = :1 +SQL +$sth = $dbh->prepare($sql); + +$sth->execute("\\'?:"); + +($retr) = $sth->fetchrow_array(); +ok((defined($retr) && $retr eq "\\'?:"), + 'execute with :1 placeholder' + ); + +$sql = <<SQL; + SELECT name + FROM test + WHERE name = '?' +SQL +$sth = $dbh->prepare($sql); + +eval { + local $dbh->{PrintError} = 0; + $sth->execute('foo'); +}; +ok($@, + 'execute with quoted ?' + ); + +$sql = <<SQL; + SELECT name + FROM test + WHERE name = ':1' +SQL +$sth = $dbh->prepare($sql); + +eval { + local $dbh->{PrintError} = 0; + $sth->execute('foo'); +}; +ok($@, + 'execute with quoted :1' + ); + +$sql = <<SQL; + SELECT name + FROM test + WHERE name = '\\\\' + AND name = '?' +SQL +$sth = $dbh->prepare($sql); + +eval { + local $dbh->{PrintError} = 0; + local $sth->{PrintError} = 0; + $sth->execute('foo'); +}; +ok($@, + 'execute with quoted ?' + ); + +$sth->finish(); +$dbh->rollback(); + +ok($dbh->disconnect(), + 'disconnect' + ); diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/13pgtype.t b/install/5.005/DBD-Pg-1.22-fixvercmp/t/13pgtype.t new file mode 100644 index 0000000..8db819e --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/13pgtype.t @@ -0,0 +1,43 @@ +use strict; +use DBI; +use Test::More; + +if (defined $ENV{DBI_DSN}) { + plan tests => 3; +} else { + plan skip_all => 'cannot test without DB info'; +} + +my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS}, + {RaiseError => 1, AutoCommit => 0} + ); +ok(defined $dbh, + 'connect with transaction' + ); + +eval { + local $dbh->{PrintError} = 0; + $dbh->do(q{DROP TABLE tt}); + $dbh->commit(); +}; +$dbh->rollback(); + +$dbh->do(q{CREATE TABLE tt (blah numeric(5,2), foo text)}); +my $sth = $dbh->prepare(qq{ + SELECT * FROM tt WHERE FALSE + }); +$sth->execute(); + +my @types = @{$sth->{pg_type}}; + +ok($types[0] eq 'numeric', + 'type numeric' + ); + +ok($types[1] eq 'text', + 'type text' + ); + +$sth->finish(); +$dbh->rollback(); +$dbh->disconnect(); diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/15funct.t b/install/5.005/DBD-Pg-1.22-fixvercmp/t/15funct.t new file mode 100644 index 0000000..1bc2cf9 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/15funct.t @@ -0,0 +1,353 @@ +#!/usr/bin/perl -w -I./t +$| = 1; + +# vim:ts=2:sw=2:ai:aw:nu: +use DBI qw(:sql_types); +use Data::Dumper; +use strict; +use Test::More; +if (defined $ENV{DBI_DSN}) { + plan tests => 59; +} else { + plan skip_all => 'cannot test without DB info'; +} + +my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS}, + {RaiseError => 1, AutoCommit => 0} + ); +ok(defined $dbh, + 'connect with transaction' + ); + +# +# Test the different methods, so are expected to fail. +# + +my $sth; + +# foreach (@{ $DBI::EXPORT_TAGS{sql_types} }) { +# no strict 'refs'; +# printf "%s=%d\n", $_, &{"DBI::$_"}; +# } + +my $get_info = { + SQL_DBMS_NAME => 17 + , SQL_DBMS_VER => 18 + , SQL_IDENTIFIER_QUOTE_CHAR => 29 + , SQL_CATALOG_NAME_SEPARATOR => 41 + , SQL_CATALOG_LOCATION => 114 +}; + +# Ping + eval { + ok( $dbh->ping(), "Testing Ping" ); + }; +ok ( !$@, "Ping Tested" ); + +# Get Info + eval { + $sth = $dbh->get_info(); + }; +ok ($@, "Call to get_info with 0 arguements, error expected: $@" ); +$sth = undef; + +# Table Info + eval { + $sth = $dbh->table_info(); + }; +ok ((!$@ and defined $sth), "table_info tested" ); +$sth = undef; + +# Column Info + eval { + $sth = $dbh->column_info(); + }; +ok ((!$@ and defined $sth), "column_info tested" ); +#ok ($@, "Call to column_info with 0 arguements, error expected: $@" ); +$sth = undef; + + +# Tables + eval { + $sth = $dbh->tables(); + }; +ok ((!$@ and defined $sth), "tables tested" ); +$sth = undef; + +# Type Info All + eval { + $sth = $dbh->type_info_all(); + }; +ok ((!$@ and defined $sth), "type_info_all tested" ); +$sth = undef; + +# Type Info + eval { + my @types = $dbh->type_info(); + die unless @types; + }; +ok (!$@, "type_info(undef)"); +$sth = undef; + +# Quote + eval { + my $val = $dbh->quote(); + die unless $val; + }; +ok ($@, "quote error expected: $@"); + +$sth = undef; +# Tests for quote: +my @qt_vals = (1, 2, undef, 'NULL', "ThisIsAString", "This is Another String"); +my @expt_vals = (q{'1'}, q{'2'}, "NULL", q{'NULL'}, q{'ThisIsAString'}, q{'This is Another String'}); +for (my $x = 0; $x <= $#qt_vals; $x++) { + local $^W = 0; + my $val = $dbh->quote( $qt_vals[$x] ); + is( $val, $expt_vals[$x], "$x: quote on $qt_vals[$x] returned $val" ); +} + +is( $dbh->quote( 1, SQL_INTEGER() ), 1, "quote(1, SQL_INTEGER)" ); + + +# Quote Identifier + eval { + my $val = $dbh->quote_identifier(); + die unless $val; + }; + +ok ($@, "quote_identifier error expected: $@"); +$sth = undef; + +SKIP: { + skip("get_info() not yet implemented", 1); + # , SQL_IDENTIFIER_QUOTE_CHAR => 29 + # , SQL_CATALOG_NAME_SEPARATOR => 41 + my $qt = $dbh->get_info( $get_info->{SQL_IDENTIFIER_QUOTE_CHAR} ); + my $sep = $dbh->get_info( $get_info->{SQL_CATALOG_NAME_SEPARATOR} ); + + # Uncomment this line and remove the next line when get_info() is implemented. +# my $cmp_str = qq{${qt}link${qt}${sep}${qt}schema${qt}${sep}${qt}table${qt}}; + my $cmp_str = ''; + is( $dbh->quote_identifier( "link", "schema", "table" ) + , $cmp_str + , q{quote_identifier( "link", "schema", "table" )} + ); +} + +# Test ping + +ok ($dbh->ping, "Ping the current connection ..." ); + +# Test Get Info. + +# SQL_KEYWORDS +# SQL_CATALOG_TERM +# SQL_DATA_SOURCE_NAME +# SQL_DBMS_NAME +# SQL_DBMS_VERSION +# SQL_DRIVER_NAME +# SQL_DRIVER_VER +# SQL_PROCEDURE_TERM +# SQL_SCHEMA_TERM +# SQL_TABLE_TERM +# SQL_USER_NAME + +SKIP: { + skip("get_info() not yet implemented", 5); + foreach my $info (sort keys %$get_info) { + my $type = $dbh->get_info($get_info->{$info}); + ok( defined $type, "get_info($info) ($get_info->{$info}) " . + ($type || '') ); + } +} + +# Test Table Info +$sth = $dbh->table_info( undef, undef, undef ); +ok( defined $sth, "table_info(undef, undef, undef) tested" ); +DBI::dump_results($sth) if defined $sth; +$sth = undef; + +$sth = $dbh->table_info( undef, undef, undef, "VIEW" ); +ok( defined $sth, "table_info(undef, undef, undef, \"VIEW\") tested" ); +DBI::dump_results($sth) if defined $sth; +$sth = undef; + +# Test Table Info Rule 19a +$sth = $dbh->table_info( '%', '', ''); +ok( defined $sth, "table_info('%', '', '',) tested" ); +DBI::dump_results($sth) if defined $sth; +$sth = undef; + +# Test Table Info Rule 19b +$sth = $dbh->table_info( '', '%', ''); +ok( defined $sth, "table_info('', '%', '',) tested" ); +DBI::dump_results($sth) if defined $sth; +$sth = undef; + +# Test Table Info Rule 19c +$sth = $dbh->table_info( '', '', '', '%'); +ok( defined $sth, "table_info('', '', '', '%',) tested" ); +DBI::dump_results($sth) if defined $sth; +$sth = undef; + +# Test to see if this database contains any of the defined table types. +$sth = $dbh->table_info( '', '', '', '%'); +ok( defined $sth, "table_info('', '', '', '%',) tested" ); +if ($sth) { + my $ref = $sth->fetchall_hashref( 'TABLE_TYPE' ); + foreach my $type ( sort keys %$ref ) { + my $tsth = $dbh->table_info( undef, undef, undef, $type ); + ok( defined $tsth, "table_info(undef, undef, undef, $type) tested" ); + DBI::dump_results($tsth) if defined $tsth; + $tsth->finish; + } + $sth->finish; +} +$sth = undef; + +# Test Column Info +$sth = $dbh->column_info( undef, undef, undef, undef ); +ok( defined $sth, "column_info(undef, undef, undef, undef) tested" ); +DBI::dump_results($sth) if defined $sth; +$sth = undef; + +$sth = $dbh->column_info( undef, "'auser'", undef, undef ); +ok( defined $sth, "column_info(undef, 'auser', undef, undef) tested" ); +DBI::dump_results($sth) if defined $sth; +$sth = undef; + +$sth = $dbh->column_info( undef, "'ause%'", undef, undef ); +ok( defined $sth, "column_info(undef, 'ause%', undef, undef) tested" ); +DBI::dump_results($sth) if defined $sth; +$sth = undef; + +$sth = $dbh->column_info( undef, "'auser','replicator'", undef, undef ); +ok( defined $sth, "column_info(undef, 'auser','replicator', undef, undef) tested" ); +DBI::dump_results($sth) if defined $sth; +$sth = undef; + +$sth = $dbh->column_info( undef, "'auser','repl%'", undef, undef ); +ok( defined $sth, "column_info(undef, 'auser','repl%', undef, undef) tested" ); +DBI::dump_results($sth) if defined $sth; +$sth = undef; + +$sth = $dbh->column_info( undef, "'fred','repl%'", undef, undef ); +ok( defined $sth, "column_info(undef, 'fred','repl%', undef, undef) tested" ); +DBI::dump_results($sth) if defined $sth; +$sth = undef; + +$sth = $dbh->column_info( undef, "'fred','jim'", undef, undef ); +ok( defined $sth, "column_info(undef, 'fred','jim', undef, undef) tested" ); +DBI::dump_results($sth) if defined $sth; +$sth = undef; + +$sth = $dbh->column_info( undef, "'auser'", "'pga_schema'", undef ); +ok( defined $sth, "column_info(undef, 'auser', 'pga_schema', undef) tested" ); +DBI::dump_results($sth) if defined $sth; +$sth = undef; + +$sth = $dbh->column_info( undef, "'auser'", "'pga_%'", undef ); +ok( defined $sth, "column_info(undef, 'auser', 'pga_%', undef) tested" ); +DBI::dump_results($sth) if defined $sth; +$sth = undef; + +$sth = $dbh->column_info( undef, "'ause%'", "'pga_%'", undef ); +ok( defined $sth, "column_info(undef, 'ause%', 'pga_%', undef) tested" ); +DBI::dump_results($sth) if defined $sth; +$sth = undef; + +$sth = $dbh->column_info( undef, "'auser'", "'pga_schema'", "'schemaname'" ); +ok( defined $sth, "column_info(undef, 'auser', 'pga_schema', 'schemaname') tested" ); +DBI::dump_results($sth) if defined $sth; +$sth = undef; + +$sth = $dbh->column_info( undef, "'auser'", "'pga_schema'", "'schema%'" ); +ok( defined $sth, "column_info(undef, 'auser', 'pga_schema', 'schema%') tested" ); +DBI::dump_results($sth) if defined $sth; +$sth = undef; + +$sth = $dbh->column_info( undef, "'auser'", "'pga_%'", "'schema%'" ); +ok( defined $sth, "column_info(undef, 'auser', 'pga_%', 'schema%') tested" ); +DBI::dump_results($sth) if defined $sth; +$sth = undef; + +$sth = $dbh->column_info( undef, "'ause%'", "'pga_%'", "'schema%'" ); +ok( defined $sth, "column_info(undef, 'ause%', 'pga_%', 'schema%') tested" ); +DBI::dump_results($sth) if defined $sth; +$sth = undef; + +# Test call to primary_key_info +local ($dbh->{Warn}, $dbh->{PrintError}); +$dbh->{PrintError} = $dbh->{Warn} = 0; + +# Primary Key Info +eval { + $sth = $dbh->primary_key_info(); + die unless $sth; +}; +ok ($@, "Call to primary_key_info with 0 arguements, error expected: $@" ); +$sth = undef; + +# Primary Key +eval { + $sth = $dbh->primary_key(); + die unless $sth; +}; +ok ($@, "Call to primary_key with 0 arguements, error expected: $@" ); +$sth = undef; + +$sth = $dbh->primary_key_info(undef, undef, undef ); + +ok( defined $sth, "Statement handle defined for primary_key_info()" ); + +if ( defined $sth ) { + while( my $row = $sth->fetchrow_arrayref ) { + local $^W = 0; + # print join( ", ", @$row, "\n" ); + } + + undef $sth; + +} + +$sth = $dbh->primary_key_info(undef, undef, undef ); +ok( defined $sth, "Statement handle defined for primary_key_info()" ); + +my ( %catalogs, %schemas, %tables); + +my $cnt = 0; +while( my ($catalog, $schema, $table) = $sth->fetchrow_array ) { + local $^W = 0; + $catalogs{$catalog}++ if $catalog; + $schemas{$schema}++ if $schema; + $tables{$table}++ if $table; + $cnt++; +} +ok( $cnt > 0, "At least one table has a primary key." ); + +$sth = $dbh->primary_key_info(undef, qq{'$ENV{DBI_USER}'}, undef ); +ok( + defined $sth + , "Getting primary keys for tables owned by $ENV{DBI_USER}"); +DBI::dump_results($sth) if defined $sth; + +undef $sth; + +SKIP: { + # foreign_key_info + local ($dbh->{Warn}, $dbh->{PrintError}); + $dbh->{PrintError} = $dbh->{Warn} = 0; + eval { + $sth = $dbh->foreign_key_info(); + die unless $sth; + }; + skip "foreign_key_info not supported by driver", 1 if $@; + ok( defined $sth, "Statement handle defined for foreign_key_info()" ); + DBI::dump_results($sth) if defined $sth; + $sth = undef; +} + +ok( $dbh->disconnect, "Disconnect from database" ); + +exit(0); + diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/99cleanup.t b/install/5.005/DBD-Pg-1.22-fixvercmp/t/99cleanup.t new file mode 100644 index 0000000..e7563ab --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/99cleanup.t @@ -0,0 +1,24 @@ +use strict; +use DBI; +use Test::More; + +if (defined $ENV{DBI_DSN}) { + plan tests => 3; +} else { + plan skip_all => 'cannot test without DB info'; +} + +my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS}, + {RaiseError => 1, AutoCommit => 0} + ); +ok(defined $dbh, + 'connect with transaction' + ); + +ok($dbh->do(q{DROP TABLE test}), + 'drop' + ); + +ok($dbh->disconnect(), + 'disconnect' + ); diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info.pm b/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info.pm new file mode 100644 index 0000000..417247f --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info.pm @@ -0,0 +1,1167 @@ +package App::Info; + +# $Id: Info.pm,v 1.1 2004-04-29 09:21:28 ivan Exp $ + +=head1 NAME + +App::Info - Information about software packages on a system + +=head1 SYNOPSIS + + use App::Info::Category::FooApp; + + my $app = App::Info::Category::FooApp->new; + + if ($app->installed) { + print "App name: ", $app->name, "\n"; + print "Version: ", $app->version, "\n"; + print "Bin dir: ", $app->bin_dir, "\n"; + } else { + print "App not installed on your system. :-(\n"; + } + +=head1 DESCRIPTION + +App::Info is an abstract base class designed to provide a generalized +interface for subclasses that provide metadata about software packages +installed on a system. The idea is that these classes can be used in Perl +application installers in order to determine whether software dependencies +have been fulfilled, and to get necessary metadata about those software +packages. + +App::Info provides an event model for handling events triggered by App::Info +subclasses. The events are classified as "info", "error", "unknown", and +"confirm" events, and multiple handlers may be specified to handle any or all +of these event types. This allows App::Info clients to flexibly handle events +in any way they deem necessary. Implementing new event handlers is +straight-forward, and use the triggering of events by App::Info subclasses is +likewise kept easy-to-use. + +A few L<sample subclasses|"SEE ALSO"> are provided with the distribution, but +others are invited to write their own subclasses and contribute them to the +CPAN. Contributors are welcome to extend their subclasses to provide more +information relevant to the application for which data is to be provided (see +L<App::Info::HTTPD::Apache|App::Info::HTTPD::Apache> for an example), but are +encouraged to, at a minimum, implement the abstract methods defined here and +in the category abstract base classes (e.g., +L<App::Info::HTTPD|App::Info::HTTPD> and L<App::Info::Lib|App::Info::Lib>). +See L<Subclassing|"SUBCLASSING"> for more information on implementing new +subclasses. + +=cut + +use strict; +use Carp (); +use App::Info::Handler; +use App::Info::Request; +use vars qw($VERSION); + +$VERSION = '0.23'; + +############################################################################## +############################################################################## +# This code ref is used by the abstract methods to throw an exception when +# they're called directly. +my $croak = sub { + my ($caller, $meth) = @_; + $caller = ref $caller || $caller; + if ($caller eq __PACKAGE__) { + $meth = __PACKAGE__ . '::' . $meth; + Carp::croak(__PACKAGE__ . " is an abstract base class. Attempt to " . + " call non-existent method $meth"); + } else { + Carp::croak("Class $caller inherited from the abstract base class " . + __PACKAGE__ . ", but failed to redefine the $meth() " . + "method. Attempt to call non-existent method " . + "${caller}::$meth"); + } +}; + +############################################################################## +# This code reference is used by new() and the on_* error handler methods to +# set the error handlers. +my $set_handlers = sub { + my $on_key = shift; + # Default is to do nothing. + return [] unless $on_key; + my $ref = ref $on_key; + if ($ref) { + $on_key = [$on_key] unless $ref eq 'ARRAY'; + # Make sure they're all handlers. + foreach my $h (@$on_key) { + if (my $r = ref $h) { + Carp::croak("$r object is not an App::Info::Handler") + unless UNIVERSAL::isa($h, 'App::Info::Handler'); + } else { + # Look up the handler. + $h = App::Info::Handler->new( key => $h); + } + } + # Return 'em! + return $on_key; + } else { + # Look up the handler. + return [ App::Info::Handler->new( key => $on_key) ]; + } +}; + +############################################################################## +############################################################################## + +=head1 INTERFACE + +This section documents the public interface of App::Info. + +=head2 Constructor + +=head3 new + + my $app = App::Info::Category::FooApp->new(@params); + +Constructs an App::Info object and returns it. The @params arguments define +how the App::Info object will respond to certain events, and correspond to +their like-named methods. See the L<"Event Handler Object Methods"> section +for more information on App::Info events and how to handle them. The +parameters to C<new()> for the different types of App::Info events are: + +=over 4 + +=item on_info + +=item on_error + +=item on_unknown + +=item on_confirm + +=back + +When passing event handlers to C<new()>, the list of handlers for each type +should be an anonymous array, for example: + + my $app = App::Info::Category::FooApp->new( on_info => \@handlers ); + +=cut + +sub new { + my ($pkg, %p) = @_; + my $class = ref $pkg || $pkg; + # Fail if the method isn't overridden. + $croak->($pkg, 'new') if $class eq __PACKAGE__; + + # Set up handlers. + for (qw(on_error on_unknown on_info on_confirm)) { + $p{$_} = $set_handlers->($p{$_}); + } + + # Do it! + return bless \%p, $class; +} + +############################################################################## +############################################################################## + +=head2 Metadata Object Methods + +These are abstract methods in App::Info and must be provided by its +subclasses. They provide the essential metadata of the software package +supported by the App::Info subclass. + +=head3 key_name + + my $key_name = $app->key_name; + +Returns a string that uniquely identifies the software for which the App::Info +subclass provides data. This value should be unique across all App::Info +classes. Typically, it's simply the name of the software. + +=cut + +sub key_name { $croak->(shift, 'key_name') } + +=head3 installed + + if ($app->installed) { + print "App is installed.\n" + } else { + print "App is not installed.\n" + } + +Returns a true value if the application is installed, and a false value if it +is not. + +=cut + +sub installed { $croak->(shift, 'installed') } + +############################################################################## + +=head3 name + + my $name = $app->name; + +Returns the name of the application. + +=cut + +sub name { $croak->(shift, 'name') } + +############################################################################## + +=head3 version + + my $version = $app->version; + +Returns the full version number of the application. + +=cut + +############################################################################## + +sub version { $croak->(shift, 'version') } + +=head3 major_version + + my $major_version = $app->major_version; + +Returns the major version number of the application. For example, if +C<version()> returns "7.1.2", then this method returns "7". + +=cut + +sub major_version { $croak->(shift, 'major_version') } + +############################################################################## + +=head3 minor_version + + my $minor_version = $app->minor_version; + +Returns the minor version number of the application. For example, if +C<version()> returns "7.1.2", then this method returns "1". + +=cut + +sub minor_version { $croak->(shift, 'minor_version') } + +############################################################################## + +=head3 patch_version + + my $patch_version = $app->patch_version; + +Returns the patch version number of the application. For example, if +C<version()> returns "7.1.2", then this method returns "2". + +=cut + +sub patch_version { $croak->(shift, 'patch_version') } + +############################################################################## + +=head3 bin_dir + + my $bin_dir = $app->bin_dir; + +Returns the full path the application's bin directory, if it exists. + +=cut + +sub bin_dir { $croak->(shift, 'bin_dir') } + +############################################################################## + +=head3 inc_dir + + my $inc_dir = $app->inc_dir; + +Returns the full path the application's include directory, if it exists. + +=cut + +sub inc_dir { $croak->(shift, 'inc_dir') } + +############################################################################## + +=head3 lib_dir + + my $lib_dir = $app->lib_dir; + +Returns the full path the application's lib directory, if it exists. + +=cut + +sub lib_dir { $croak->(shift, 'lib_dir') } + +############################################################################## + +=head3 so_lib_dir + + my $so_lib_dir = $app->so_lib_dir; + +Returns the full path the application's shared library directory, if it +exists. + +=cut + +sub so_lib_dir { $croak->(shift, 'so_lib_dir') } + +############################################################################## + +=head3 home_url + + my $home_url = $app->home_url; + +The URL for the software's home page. + +=cut + +sub home_url { $croak->(shift, 'home_url') } + +############################################################################## + +=head3 download_url + + my $download_url = $app->download_url; + +The URL for the software's download page. + +=cut + +sub download_url { $croak->(shift, 'download_url') } + +############################################################################## +############################################################################## + +=head2 Event Handler Object Methods + +These methods provide control over App::Info event handling. Events can be +handled by one or more objects of subclasses of App::Info::Handler. The first +to return a true value will be the last to execute. This approach allows +handlers to be stacked, and makes it relatively easy to create new handlers. +L<App::Info::Handler|App::Info::Handler> for information on writing event +handlers. + +Each of the event handler methods takes a list of event handlers as its +arguments. If none are passed, the existing list of handlers for the relevant +event type will be returned. If new handlers are passed in, they will be +returned. + +The event handlers may be specified as one or more objects of the +App::Info::Handler class or subclasses, as one or more strings that tell +App::Info construct such handlers itself, or a combination of the two. The +strings can only be used if the relevant App::Info::Handler subclasses have +registered strings with App::Info. For example, the App::Info::Handler::Print +class included in the App::Info distribution registers the strings "stderr" +and "stdout" when it starts up. These strings may then be used to tell +App::Info to construct App::Info::Handler::Print objects that print to STDERR +or to STDOUT, respectively. See the App::Info::Handler subclasses for what +strings they register with App::Info. + +=head3 on_info + + my @handlers = $app->on_info; + $app->on_info(@handlers); + +Info events are triggered when the App::Info subclass wants to send an +informational status message. By default, these events are ignored, but a +common need is for such messages to simply print to STDOUT. Use the +L<App::Info::Handler::Print|App::Info::Handler::Print> class included with the +App::Info distribution to have info messages print to STDOUT: + + use App::Info::Handler::Print; + $app->on_info('stdout'); + # Or: + my $stdout_handler = App::Info::Handler::Print->new('stdout'); + $app->on_info($stdout_handler); + +=cut + +sub on_info { + my $self = shift; + $self->{on_info} = $set_handlers->(\@_) if @_; + return @{ $self->{on_info} }; +} + +=head3 on_error + + my @handlers = $app->on_error; + $app->on_error(@handlers); + +Error events are triggered when the App::Info subclass runs into an unexpected +but not fatal problem. (Note that fatal problems will likely throw an +exception.) By default, these events are ignored. A common way of handling +these events is to print them to STDERR, once again using the +L<App::Info::Handler::Print|App::Info::Handler::Print> class included with the +App::Info distribution: + + use App::Info::Handler::Print; + my $app->on_error('stderr'); + # Or: + my $stderr_handler = App::Info::Handler::Print->new('stderr'); + $app->on_error($stderr_handler); + +Another approach might be to turn such events into fatal exceptions. Use the +included L<App::Info::Handler::Carp|App::Info::Handler::Carp> class for this +purpose: + + use App::Info::Handler::Carp; + my $app->on_error('croak'); + # Or: + my $croaker = App::Info::Handler::Carp->new('croak'); + $app->on_error($croaker); + +=cut + +sub on_error { + my $self = shift; + $self->{on_error} = $set_handlers->(\@_) if @_; + return @{ $self->{on_error} }; +} + +=head3 on_unknown + + my @handlers = $app->on_unknown; + $app->on_uknown(@handlers); + +Unknown events are trigged when the App::Info subclass cannot find the value +to be returned by a method call. By default, these events are ignored. A +common way of handling them is to have the application prompt the user for the +relevant data. The App::Info::Handler::Prompt class included with the +App::Info distribution can do just that: + + use App::Info::Handler::Prompt; + my $app->on_unknown('prompt'); + # Or: + my $prompter = App::Info::Handler::Prompt; + $app->on_unknown($prompter); + +See L<App::Info::Handler::Prompt|App::Info::Handler::Prompt> for information +on how it works. + +=cut + +sub on_unknown { + my $self = shift; + $self->{on_unknown} = $set_handlers->(\@_) if @_; + return @{ $self->{on_unknown} }; +} + +=head3 on_confirm + + my @handlers = $app->on_confirm; + $app->on_confirm(@handlers); + +Confirm events are triggered when the App::Info subclass has found an +important piece of information (such as the location of the executable it'll +use to collect information for the rest of its methods) and wants to confirm +that the information is correct. These events will most often be triggered +during the App::Info subclass object construction. Here, too, the +App::Info::Handler::Prompt class included with the App::Info distribution can +help out: + + use App::Info::Handler::Prompt; + my $app->on_confirm('prompt'); + # Or: + my $prompter = App::Info::Handler::Prompt; + $app->on_confirm($prompter); + +=cut + +sub on_confirm { + my $self = shift; + $self->{on_confirm} = $set_handlers->(\@_) if @_; + return @{ $self->{on_confirm} }; +} + +############################################################################## +############################################################################## + +=head1 SUBCLASSING + +As an abstract base class, App::Info is not intended to be used directly. +Instead, you'll use concrete subclasses that implement the interface it +defines. These subclasses each provide the metadata necessary for a given +software package, via the interface outlined above (plus any additional +methods the class author deems sensible for a given application). + +This section describes the facilities App::Info provides for subclassing. The +goal of the App::Info design has been to make subclassing straight-forward, so +that developers can focus on gathering the data they need for their +application and minimize the work necessary to handle unknown values or to +confirm values. As a result, there are essentially three concepts that +developers need to understand when subclassing App::Info: organization, +utility methods, and events. + +=head2 Organization + +The organizational idea behind App::Info is to name subclasses by broad +software categories. This approach allows the categories themselves to +function as abstract base classes that extend App::Info, so that they can +specify more methods for all of their base classes to implement. For example, +App::Info::HTTPD has specified the C<httpd_root()> abstract method that its +subclasses must implement. So as you get ready to implement your own subclass, +think about what category of software you're gathering information about. +New categories can be added as necessary. + +=head2 Utility Methods + +Once you've decided on the proper category, you can start implementing your +App::Info concrete subclass. As you do so, take advantage of App::Info::Util, +wherein I've tried to encapsulate common functionality to make subclassing +easier. I found that most of what I was doing repetitively was looking for +files and directories, and searching through files. Thus, App::Info::Util +subclasses L<File::Spec|File::Spec> in order to offer easy access to +commonly-used methods from that class, e.g., C<path()>. Plus, it has several +of its own methods to assist you in finding files and directories in lists of +files and directories, as well as methods for searching through files and +returning the values found in those files. See +L<App::Info::Util|App::Info::Util> for more information, and the App::Info +subclasses in this distribution for usage examples. + +I recommend the use of a package-scoped lexical App::Info::Util object. That +way it's nice and handy when you need to carry out common tasks. If you find +you're doing something over and over that's not already addressed by an +App::Info::Util method, consider submitting a patch to App::Info::Util to add +the functionality you need. + +=head2 Events + +Use the methods described below to trigger events. Events are designed to +provide a simple way for App::Info subclass developers to send status messages +and errors, to confirm data values, and to request a value when the class +caonnot determine a value itself. Events may optionally be handled by module +users who assign App::Info::Handler subclass objects to your App::Info +subclass object using the event handling methods described in the L<"Event +Handler Object Methods"> section. + +=cut + +############################################################################## +# This code reference is used by the event methods to manage the stack of +# event handlers that may be available to handle each of the events. +my $handler = sub { + my ($self, $meth, $params) = @_; + + # Sanity check. We really want to keep control over this. + Carp::croak("Cannot call protected method $meth()") + unless UNIVERSAL::isa($self, scalar caller(1)); + + # Create the request object. + $params->{type} ||= $meth; + my $req = App::Info::Request->new(%$params); + + # Do the deed. The ultimate handling handler may die. + foreach my $eh (@{$self->{"on_$meth"}}) { + last if $eh->handler($req); + } + + # Return the requst. + return $req; +}; + +############################################################################## + +=head3 info + + $self->info(@message); + +Use this method to display status messages for the user. You may wish to use +it to inform users that you're searching for a particular file, or attempting +to parse a file or some other resource for the data you need. For example, a +common use might be in the object constructor: generally, when an App::Info +object is created, some important initial piece of information is being +sought, such as an executable file. That file may be in one of many locations, +so it makes sense to let the user know that you're looking for it: + + $self->info("Searching for executable"); + +Note that, due to the nature of App::Info event handlers, your informational +message may be used or displayed any number of ways, or indeed not at all (as +is the default behavior). + +The C<@message> will be joined into a single string and stored in the +C<message> attribute of the App::Info::Request object passed to info event +handlers. + +=cut + +sub info { + my $self = shift; + # Execute the handler sequence. + my $req = $handler->($self, 'info', { message => join '', @_ }); +} + +############################################################################## + +=head3 error + + $self->error(@error); + +Use this method to inform the user that something unexpected has happened. An +example might be when you invoke another program to parse its output, but it's +output isn't what you expected: + + $self->error("Unable to parse version from `/bin/myapp -c`"); + +As with all events, keep in mind that error events may be handled in any +number of ways, or not at all. + +The C<@erorr> will be joined into a single string and stored in the C<message> +attribute of the App::Info::Request object passed to error event handlers. If +that seems confusing, think of it as an "error message" rather than an "error +error." :-) + +=cut + +sub error { + my $self = shift; + # Execute the handler sequence. + my $req = $handler->($self, 'error', { message => join '', @_ }); +} + +############################################################################## + +=head3 unknown + + my $val = $self->unknown(@params); + +Use this method when a value is unknown. This will give the user the option -- +assuming the appropriate handler handles the event -- to provide the needed +data. The value entered will be returned by C<unknown()>. The parameters are +as follows: + +=over 4 + +=item key + +The C<key> parameter uniquely identifies the data point in your class, and is +used by App::Info to ensure that an unknown event is handled only once, no +matter how many times the method is called. The same value will be returned by +subsequent calls to C<unknown()> as was returned by the first call, and no +handlers will be activated. Typical values are "version" and "lib_dir". + +=item prompt + +The C<prompt> parameter is the prompt to be displayed should an event handler +decide to prompt for the appropriate value. Such a prompt might be something +like "Path to your httpd executable?". If this parameter is not provided, +App::Info will construct one for you using your class' C<key_name()> method +and the C<key> parameter. The result would be something like "Enter a valid +FooApp version". The C<prompt> parameter value will be stored in the +C<message> attribute of the App::Info::Request object passed to event +handlers. + +=item callback + +Assuming a handler has collected a value for your unknown data point, it might +make sense to validate the value. For example, if you prompt the user for a +directory location, and the user enters one, it makes sense to ensure that the +directory actually exists. The C<callback> parameter allows you to do this. It +is a code reference that takes the new value or values as its arguments, and +returns true if the value is valid, and false if it is not. For the sake of +convenience, the first argument to the callback code reference is also stored +in C<$_> .This makes it easy to validate using functions or operators that, +er, operate on C<$_> by default, but still allows you to get more information +from C<@_> if necessary. For the directory example, a good callback might be +C<sub { -d }>. The C<callback> parameter code reference will be stored in the +C<callback> attribute of the App::Info::Request object passed to event +handlers. + +=item error + +The error parameter is the error message to display in the event that the +C<callback> code reference returns false. This message may then be used by the +event handler to let the user know what went wrong with the data she entered. +For example, if the unknown value was a directory, and the user entered a +value that the C<callback> identified as invalid, a message to display might +be something like "Invalid directory path". Note that if the C<error> +parameter is not provided, App::Info will supply the generic error message +"Invalid value". This value will be stored in the C<error> attribute of the +App::Info::Request object passed to event handlers. + +=back + +This may be the event method you use most, as it should be called in every +metadata method if you cannot provide the data needed by that method. It will +typically be the last part of the method. Here's an example demonstrating each +of the above arguments: + + my $dir = $self->unknown( key => 'lib_dir', + prompt => "Enter lib directory path", + callback => sub { -d }, + error => "Not a directory"); + +=cut + +sub unknown { + my ($self, %params) = @_; + my $key = delete $params{key} + or Carp::croak("No key parameter passed to unknown()"); + # Just return the value if we've already handled this value. Ideally this + # shouldn't happen. + return $self->{__unknown__}{$key} if exists $self->{__unknown__}{$key}; + + # Create a prompt and error message, if necessary. + $params{message} = delete $params{prompt} || + "Enter a valid " . $self->key_name . " $key"; + $params{error} ||= 'Invalid value'; + + # Execute the handler sequence. + my $req = $handler->($self, "unknown", \%params); + + # Mark that we've provided this value and then return it. + $self->{__unknown__}{$key} = $req->value; + return $self->{__unknown__}{$key}; +} + +############################################################################## + +=head3 confirm + + my $val = $self->confirm(@params); + +This method is very similar to C<unknown()>, but serves a different purpose. +Use this method for significant data points where you've found an appropriate +value, but want to ensure it's really the correct value. A "significant data +point" is usually a value essential for your class to collect metadata values. +For example, you might need to locate an executable that you can then call to +collect other data. In general, this will only happen once for an object -- +during object construction -- but there may be cases in which it is needed +more than that. But hopefully, once you've confirmed in the constructor that +you've found what you need, you can use that information to collect the data +needed by all of the metadata methods and can assume that they'll be right +because that first, significant data point has been confirmed. + +Other than where and how often to call C<confirm()>, its use is quite similar +to that of C<unknown()>. Its parameters are as follows: + +=over + +=item key + +Same as for C<unknown()>, a string that uniquely identifies the data point in +your class, and ensures that the event is handled only once for a given key. +The same value will be returned by subsequent calls to C<confirm()> as was +returned by the first call for a given key. + +=item prompt + +Same as for C<unknown()>. Although C<confirm()> is called to confirm a value, +typically the prompt should request the relevant value, just as for +C<unknown()>. The difference is that the handler I<should> use the C<value> +parameter as the default should the user not provide a value. The C<prompt> +parameter will be stored in the C<message> attribute of the App::Info::Request +object passed to event handlers. + +=item value + +The value to be confirmed. This is the value you've found, and it will be +provided to the user as the default option when they're prompted for a new +value. This value will be stored in the C<value> attribute of the +App::Info::Request object passed to event handlers. + +=item callback + +Same as for C<unknown()>. Because the user can enter data to replace the +default value provided via the C<value> parameter, you might want to validate +it. Use this code reference to do so. The callback will be stored in the +C<callback> attribute of the App::Info::Request object passed to event +handlers. + +=item error + +Same as for C<unknown()>: an error message to display in the event that a +value entered by the user isn't validated by the C<callback> code reference. +This value will be stored in the C<error> attribute of the App::Info::Request +object passed to event handlers. + +=back + +Here's an example usage demonstrating all of the above arguments: + + my $exe = $self->confirm( key => 'shell', + prompt => 'Path to your shell?', + value => '/bin/sh', + callback => sub { -x }, + error => 'Not an executable'); + + +=cut + +sub confirm { + my ($self, %params) = @_; + my $key = delete $params{key} + or Carp::croak("No key parameter passed to confirm()"); + return $self->{__confirm__}{$key} if exists $self->{__confirm__}{$key}; + + # Create a prompt and error message, if necessary. + $params{message} = delete $params{prompt} || + "Enter a valid " . $self->key_name . " $key"; + $params{error} ||= 'Invalid value'; + + # Execute the handler sequence. + my $req = $handler->($self, "confirm", \%params); + + # Mark that we've confirmed this value. + $self->{__confirm__}{$key} = $req->value; + + return $self->{__confirm__}{$key} +} + +1; +__END__ + +=head2 Event Examples + +Below I provide some examples demonstrating the use of the event methods. +These are meant to emphasize the contexts in which it's appropriate to use +them. + +Let's start with the simplest, first. Let's say that to find the version +number for an application, you need to search a file for the relevant data. +Your App::Info concrete subclass might have a private method that handles this +work, and this method is the appropriate place to use the C<info()> and, if +necessary, C<error()> methods. + + sub _find_version { + my $self = shift; + + # Try to find the revelant file. We cover this method below. + # Just return if we cant' find it. + my $file = $self->_find_file('version.conf') or return; + + # Send a status message. + $self->info("Searching '$file' file for version"); + + # Search the file. $util is an App::Info::Util object. + my $ver = $util->search_file($file, qr/^Version\s+(.*)$/); + + # Trigger an error message, if necessary. We really think we'll have the + # value, but we have to cover our butts in the unlikely event that we're + # wrong. + $self->error("Unable to find version in file '$file'") unless $ver; + + # Return the version number. + return $ver; + } + +Here we've used the C<info()> method to display a status message to let the +user know what we're doing. Then we used the C<error()> method when something +unexpected happened, which in this case was that we weren't able to find the +version number in the file. + +Note the C<_find_file()> method we've thrown in. This might be a method that +we call whenever we need to find a file that might be in one of a list of +directories. This method, too, will be an appropriate place for an C<info()> +method call. But rather than call the C<error()> method when the file can't be +found, you might want to give an event handler a chance to supply that value +for you. Use the C<unknown()> method for a case such as this: + + sub _find_file { + my ($self, $file) = @_; + + # Send a status message. + $self->info("Searching for '$file' file"); + + # Look for the file. See App::Info:Utility for its interface. + my @paths = qw(/usr/conf /etc/conf /foo/conf); + my $found = $util->first_cat_path($file, @paths); + + # If we didn't find it, trigger an unknown event to + # give a handler a chance to get the value. + $found ||= $self->unknown( key => "file_$file", + prompt => "Location of '$file' file?", + callback => sub { -f }, + error => "Not a file"); + + # Now return the file name, regardless of whether we found it or not. + return $found; + } + +Note how in this method, we've tried to locate the file ourselves, but if we +can't find it, we trigger an unknown event. This allows clients of our +App::Info subclass to try to establish the value themselves by having an +App::Info::Handler subclass handle the event. If a value is found by an +App::Info::Handler subclass, it will be returned by C<unknown()> and we can +continue. But we can't assume that the unknown event will even be handled, and +thus must expect that an unknown value may remain unknown. This is why the +C<_find_version()> method above simply returns if C<_find_file()> doesn't +return a file name; there's no point in searching through a file that doesn't +exist. + +Attentive readers may be left to wonder how to decide when to use C<error()> +and when to use C<unknown()>. To a large extent, this decision must be based +on one's own understanding of what's most appropriate. Nevertheless, I offer +the following simple guidelines: Use C<error()> when you expect something to +work and then it just doesn't (as when a file exists and should contain the +information you seek, but then doesn't). Use C<unknown()> when you're less +sure of your processes for finding the value, and also for any of the values +that should be returned by any of the L<metadata object methods|"Metadata +Object Methods">. And of course, C<error()> would be more appropriate when you +encounter an unexpected condition and don't think that it could be handled in +any other way. + +Now, more than likely, a method such C<_find_version()> would be called by the +C<version()> method, which is a metadata method mandated by the App::Info +abstract base class. This is an appropriate place to handle an unknown version +value. Indeed, every one of your metadata methods should make use of the +C<unknown()> method. The C<version()> method then should look something like +this: + + sub version { + my $self = shift; + + unless (exists $self->{version}) { + # Try to find the version number. + $self->{version} = $self->_find_version || + $self->unknown( key => 'version', + prompt => "Enter the version number"); + } + + # Now return the version number. + return $self->{version}; + } + +Note how this method only tries to find the version number once. Any +subsequent calls to C<version()> will return the same value that was returned +the first time it was called. Of course, thanks to the C<key> parameter in the +call to C<unknown()>, we could have have tried to enumerate the version number +every time, as C<unknown()> will return the same value every time it is called +(as, indeed, should C<_find_version()>. But by checking for the C<version> key +in C<$self> ourselves, we save some of the overhead. + +But as I said before, every metadata method should make use of the +C<unknown()> method. Thus, the C<major()> method might looks something like +this: + + sub major { + my $self = shift; + + unless (exists $self->{major}) { + # Try to get the major version from the full version number. + ($self->{major}) = $self->version =~ /^(\d+)\./; + # Handle an unknown value. + $self->{major} = $self->unknown( key => 'major', + prompt => "Enter major version", + callback => sub { /^\d+$/ }, + error => "Not a number") + unless defined $self->{major}; + } + + return $self->{version}; + } + +Finally, the C<confirm()> method should be used to verify core pieces of data +that significant numbers of other methods rely on. Typically such data are +executables or configuration files from which will be drawn other metadata. +Most often, such major data points will be sought in the object constructor. +Here's an example: + + sub new { + # Construct the object so that handlers will work properly. + my $self = shift->SUPER::new(@_); + + # Try to find the executable. + $self->info("Searching for executable"); + if (my $exe = $util->first_exe('/bin/myapp', '/usr/bin/myapp')) { + # Confirm it. + $self->{exe} = + $self->confirm( key => 'binary', + prompt => 'Path to your executable?', + value => $exe, + callback => sub { -x }, + error => 'Not an executable'); + } else { + # Handle an unknown value. + $self->{exe} = + $self->unknown( key => 'binary', + prompt => 'Path to your executable?', + callback => sub { -x }, + error => 'Not an executable'); + } + + # We're done. + return $self; + } + +By now, most of what's going on here should be quite familiar. The use of the +C<confirm()> method is quite similar to that of C<unknown()>. Really the only +difference is that the value is known, but we need verification or a new value +supplied if the value we found isn't correct. Such may be the case when +multiple copies of the executable have been installed on the system, we found +F</bin/myapp>, but the user may really be interested in F</usr/bin/myapp>. +Thus the C<confirm()> event gives the user the chance to change the value if +the confirm event is handled. + +The final thing to note about this constructor is the first line: + + my $self = shift->SUPER::new(@_); + +The first thing an App::Info subclass should do is execute this line to allow +the super class to construct the object first. Doing so allows any event +handling arguments to set up the event handlers, so that when we call +C<confirm()> or C<unknown()> the event will be handled as the client expects. + +If we needed our subclass constructor to take its own parameter argumente, the +approach is to specify the same C<key => $arg> syntax as is used by +App::Info's C<new()> method. Say we wanted to allow clients of our App::Info +subclass to pass in a list of alternate executable locations for us to search. +Such an argument would most make sense as an array reference. So we specify +that the key be C<alt_paths> and allow the user to construct an object like +this: + + my $app = App::Info::Category::FooApp->new( alt_paths => \@paths ); + +This approach allows the super class constructor arguments to pass unmolested +(as long as we use unique keys!): + + my $app = App::Info::Category::FooApp->new( on_error => \@handlers, + alt_paths => \@paths ); + +Then, to retrieve these paths inside our C<new()> constructor, all we need do +is access them directly from the object: + + my $self = shift->SUPER::new(@_); + my $alt_paths = $self->{alt_paths}; + +=head2 Subclassing Guidelines + +To summarize, here are some guidelines for subclassing App::Info. + +=over 4 + +=item * + +Always subclass an App::Info category subclass. This will help to keep the +App::Info namespace well-organized. New categories can be added as needed. + +=item * + +When you create the C<new()> constructor, always call C<SUPER::new(@_)>. This +ensures that the event handling methods methods defined by the App::Info base +classes (e.g., C<error()>) will work properly. + +=item * + +Use a package-scoped lexical App::Info::Util object to carry out common tasks. +If you find you're doing something over and over that's not already addressed +by an App::Info::Util method, and you think that others might find your +solution useful, consider submitting a patch to App::Info::Util to add the +functionality you need. See L<App::Info::Util|App::Info::Util> for complete +documentation of its interface. + +=item * + +Use the C<info()> event triggering method to send messages to users of your +subclass. + +=item * + +Use the C<error()> event triggering method to alert users of unexpected +conditions. Fatal errors should still be fatal; use C<Carp::croak()> to throw +exceptions for fatal errors. + +=item * + +Use the C<unknown()> event triggering method when a metadata or other +important value is unknown and you want to give any event handlers the chance +to provide the data. + +=item * + +Use the C<confirm()> event triggering method when a core piece of data is +known (such as the location of an executable in the C<new()> constructor) and +you need to make sure that you have the I<correct> information. + +=item * + +Be sure to implement B<all> of the abstract methods defined by App::Info and +by your category abstract base class -- even if they don't do anything. Doing +so ensures that all App::Info subclasses share a common interface, and can, if +necessary, be used without regard to subclass. Any method not implemented but +called on an object will generate a fatal exception. + +=back + +Otherwise, have fun! There are a lot of software packages for which relevant +information might be collected and aggregated into an App::Info concrete +subclass (witness all of the Automake macros in the world!), and folks who are +knowledgeable about particular software packages or categories of software are +warmly invited to contribute. As more subclasses are implemented, it will make +sense, I think, to create separate distributions based on category -- or even, +when necessary, on a single software package. Broader categories can then be +aggregated in Bundle distributions. + +But I get ahead of myself... + +=head1 BUGS + +Report all bugs via the CPAN Request Tracker at +L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=App-Info>. + +=head1 AUTHOR + +David Wheeler <L<david@wheeler.net|"david@wheeler.net">> + +=head1 SEE ALSO + +The following classes define a few software package categories in which +App::Info subclasses can be placed. Check them out for ideas on how to +create new category subclasses. + +=over 4 + +=item L<App::Info::HTTP|App::Info::HTTPD> + +=item L<App::Info::RDBMS|App::Info::RDBMS> + +=item L<App::Info::Lib|App::Info::Lib> + +=back + +The following classes implement the App::Info interface for various software +packages. Check them out for examples of how to implement new App::Info +concrete subclasses. + +=over + +=item L<App::Info::HTTPD::Apache|App::Info::HTTPD::Apache> + +=item L<App::Info::RDBMS::PostgreSQL|App::Info::RDBMS::PostgreSQL> + +=item L<App::Info::Lib::Expat|App::Info::Lib::Expat> + +=item L<App::Info::Lib::Iconv|App::Info::Lib::Iconv> + +=back + +L<App::Info::Util|App::Info::Util> provides utility methods for App::Info +subclasses. + +L<App::Info::Handler|App::Info::Handler> defines an interface for event +handlers to subclass. Consult its documentation for information on creating +custom event handlers. + +The following classes implement the App::Info::Handler interface to offer some +simple event handling. Check them out for examples of how to implement new +App::Info::Handler subclasses. + +=over 4 + +=item L<App::Info::Handler::Print|App::Info::Handler::Print> + +=item L<App::Info::Handler::Carp|App::Info::Handler::Carp> + +=item L<App::Info::Handler::Prompt|App::Info::Handler::Prompt> + +=back + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2002, David Wheeler. All Rights Reserved. + +This module is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=cut diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/Handler.pm b/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/Handler.pm new file mode 100644 index 0000000..65416a8 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/Handler.pm @@ -0,0 +1,305 @@ +package App::Info::Handler; + +# $Id: Handler.pm,v 1.1 2004-04-29 09:21:28 ivan Exp $ + +=head1 NAME + +App::Info::Handler - App::Info event handler base class + +=head1 SYNOPSIS + + use App::Info::Category::FooApp; + use App::Info::Handler; + + my $app = App::Info::Category::FooApp->new( on_info => ['default'] ); + +=head1 DESCRIPTION + +This class defines the interface for subclasses that wish to handle events +triggered by App::Info concrete subclasses. The different types of events +triggered by App::Info can all be handled by App::Info::Handler (indeed, by +default they're all handled by a single App::Info::Handler object), and +App::Info::Handler subclasses may be designed to handle whatever events they +wish. + +If you're interested in I<using> an App::Info event handler, this is probably +not the class you should look at, since all it does is define a simple handler +that does nothing with an event. Look to the L<App::Info::Handler +subclasses|"SEE ALSO"> included in this distribution to do more interesting +things with App::Info events. + +If, on the other hand, you're interested in implementing your own event +handlers, read on! + +=cut + +use strict; +use vars qw($VERSION); +$VERSION = '0.22'; + +my %handlers; + +=head1 INTERFACE + +This section documents the public interface of App::Info::Handler. + +=head2 Class Method + +=head3 register_handler + + App::Info::Handler->register_handler( $key => $code_ref ); + +This class method may be used by App::Info::Handler subclasses to register +themselves with App::Info::Handler. Multiple registrations are supported. The +idea is that a subclass can define different functionality by specifying +different strings that represent different modes of constructing an +App::Info::Handler subclass object. The keys are case-sensitve, and should be +unique across App::Info::Handler subclasses so that many subclasses can be +loaded and used separately. If the C<$key> is already registered, +C<register_handler()> will throw an exception. The values are code references +that, when executed, return the appropriate App::Info::Handler subclass +object. + +=cut + +sub register_handler { + my ($pkg, $key, $code) = @_; + Carp::croak("Handler '$key' already exists") + if $handlers{$key}; + $handlers{$key} = $code; +} + +# Register ourself. +__PACKAGE__->register_handler('default', sub { __PACKAGE__->new } ); + +############################################################################## + +=head2 Constructor + +=head3 new + + my $handler = App::Info::Handler->new; + $handler = App::Info::Handler->new( key => $key); + +Constructs an App::Info::Handler object and returns it. If the key parameter +is provided and has been registered by an App::Info::Handler subclass via the +C<register_handler()> class method, then the relevant code reference will be +executed and the resulting App::Info::Handler subclass object returned. This +approach provides a handy shortcut for having C<new()> behave as an abstract +factory method, returning an object of the subclass appropriate to the key +parameter. + +=cut + +sub new { + my ($pkg, %p) = @_; + my $class = ref $pkg || $pkg; + $p{key} ||= 'default'; + if ($class eq __PACKAGE__ && $p{key} ne 'default') { + # We were called directly! Handle it. + Carp::croak("No such handler '$p{key}'") unless $handlers{$p{key}}; + return $handlers{$p{key}}->(); + } else { + # A subclass called us -- just instantiate and return. + return bless \%p, $class; + } +} + +=head2 Instance Method + +=head3 handler + + $handler->handler($req); + +App::Info::Handler defines a single instance method that must be defined by +its subclasses, C<handler()>. This is the method that will be executed by an +event triggered by an App::Info concrete subclass. It takes as its single +argument an App::Info::Request object, and returns a true value if it has +handled the event request. Returning a false value declines the request, and +App::Info will then move on to the next handler in the chain. + +The C<handler()> method implemented in App::Info::Handler itself does nothing +more than return a true value. It thus acts as a very simple default event +handler. See the App::Info::Handler subclasses for more interesting handling +of events, or create your own! + +=cut + +sub handler { 1 } + +1; +__END__ + +=head1 SUBCLASSING + +I hatched the idea of the App::Info event model with its subclassable handlers +as a way of separating the aggregation of application metadata from writing a +user interface for handling certain conditions. I felt it a better idea to +allow people to create their own user interfaces, and instead to provide only +a few examples. The App::Info::Handler class defines the API interface for +handling these conditions, which App::Info refers to as "events". + +There are various types of events defined by App::Info ("info", "error", +"unknown", and "confirm"), but the App::Info::Handler interface is designed to +be flexible enough to handle any and all of them. If you're interested in +creating your own App::Info event handler, this is the place to learn how. + +=head2 The Interface + +To create an App::Info event handler, all one need do is subclass +App::Info::Handler and then implement the C<new()> constructor and the +C<handler()> method. The C<new()> constructor can do anything you like, and +take any arguments you like. However, I do recommend that the first thing +you do in your implementation is to call the super constructor: + + sub new { + my $pkg = shift; + my $self = $pkg->SUPER::new(@_); + # ... other stuff. + return $self; + } + +Although the default C<new()> constructor currently doesn't do much, that may +change in the future, so this call will keep you covered. What it does do is +take the parameterized arguments and assign them to the App::Info::Handler +object. Thus if you've specified a "mode" argument, where clients can +construct objects of you class like this: + + my $handler = FooHandler->new( mode => 'foo' ); + +You can access the mode parameter directly from the object, like so: + + sub new { + my $pkg = shift; + my $self = $pkg->SUPER::new(@_); + if ($self->{mode} eq 'foo') { + # ... + } + return $self; + } + +Just be sure not to use a parameter key name required by App::Info::Handler +itself. At the moment, the only parameter accepted by App::Info::Handler is +"key", so in general you'll be pretty safe. + +Next, I recommend that you take advantage of the C<register_handler()> method +to create some shortcuts for creating handlers of your class. For example, say +we're creating a handler subclass FooHandler. It has two modes, a default +"foo" mode and an advanced "bar" mode. To allow both to be constructed by +stringified shortcuts, the FooHandler class implementation might start like +this: + + package FooHandler; + + use strict; + use App::Info::Handler; + use vars qw(@ISA); + @ISA = qw(App::Info::Handler); + + foreach my $c (qw(foo bar)) { + App::Info::Handler->register_handler + ( $c => sub { __PACKAGE__->new( mode => $c) } ); + } + +The strings "foo" and "bar" can then be used by clients as shortcuts to have +App::Info objects automatically create and use handlers for certain events. +For example, if a client wanted to use a "bar" event handler for its info +events, it might do this: + + use App::Info::Category::FooApp; + use FooHandler; + + my $app = App::Info::Category::FooApp->new(on_info => ['bar']); + +Take a look at App::Info::Handler::Print and App::Info::Handler::Carp to see +concrete examples of C<register_handler()> usage. + +The final step in creating a new App::Info event handler is to implement the +C<handler()> method itself. This method takes a single argument, an +App::Info::Request object, and is expected to return true if it handled the +request, and false if it did not. The App::Info::Request object contains all +the metadata relevant to a request, including the type of event that triggered +it; see L<App::Info::Request|App::Info::Request> for its documentation. + +Use the App::Info::Request object however you like to handle the request +however you like. You are, however, expected to abide by a a few guidelines: + +=over 4 + +=item * + +For error and info events, you are expected (but not required) to somehow +display the info or error message for the user. How your handler chooses to do +so is up to you and the handler. + +=item * + +For unknown and confirm events, you are expected to prompt the user for a +value. If it's a confirm event, offer the known value (found in +C<$req-E<gt>value>) as a default. + +=item * + +For unknown and confirm events, you are expected to call C<$req-E<gt>callback> +and pass in the new value. If C<$req-E<gt>callback> returns a false value, you +are expected to display the error message in C<$req-E<gt>error> and prompt the +user again. Note that C<$req-E<gt>value> calls C<$req-E<gt>callback> +internally, and thus assigns the value and returns true if +C<$req-E<gt>callback> returns true, and does not assign the value and returns +false if C<$req-E<gt>callback> returns false. + +=item * + +For unknown and confirm events, if you've collected a new value and +C<$req-E<gt>callback> returns true for that value, you are expected to assign +the value by passing it to C<$req-E<gt>value>. This allows App::Info to give +the value back to the calling App::Info concrete subclass. + +=back + +Probably the easiest way to get started creating new App::Info event handlers +is to check out the simple handlers provided with the distribution and follow +their logical examples. Consult the App::Info documentation of the L<event +methods|App::Info/"Events"> for details on how App::Info constructs the +App::Info::Request object for each event type. + +=head1 BUGS + +Report all bugs via the CPAN Request Tracker at +L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=App-Info>. + +=head1 AUTHOR + +David Wheeler <L<david@wheeler.net|"david@wheeler.net">> + +=head1 SEE ALSO + +L<App::Info|App::Info> thoroughly documents the client interface for setting +event handlers, as well as the event triggering interface for App::Info +concrete subclasses. + +L<App::Info::Request|App::Info::Request> documents the interface for the +request objects passed to App::Info::Handler C<handler()> methods. + +The following App::Info::Handler subclasses offer examples for event handler +authors, and, of course, provide actual event handling functionality for +App::Info clients. + +=over 4 + +=item L<App::Info::Handler::Carp|App::Info::Handler::Carp> + +=item L<App::Info::Handler::Print|App::Info::Handler::Print> + +=item L<App::Info::Handler::Prompt|App::Info::Handler::Prompt> + +=back + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2002, David Wheeler. All Rights Reserved. + +This module is free software; you can redistribute it and/or modify it under the +same terms as Perl itself. + +=cut diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/Handler/Prompt.pm b/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/Handler/Prompt.pm new file mode 100644 index 0000000..47edd78 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/Handler/Prompt.pm @@ -0,0 +1,170 @@ +package App::Info::Handler::Prompt; + +# $Id: Prompt.pm,v 1.1 2004-04-29 09:21:29 ivan Exp $ + +=head1 NAME + +App::Info::Handler::Prompt - Prompting App::Info event handler + +=head1 SYNOPSIS + + use App::Info::Category::FooApp; + use App::Info::Handler::Print; + + my $prompter = App::Info::Handler::Print->new; + my $app = App::Info::Category::FooApp->new( on_unknown => $prompter ); + + # Or... + my $app = App::Info::Category::FooApp->new( on_confirm => 'prompt' ); + +=head1 DESCRIPTION + +App::Info::Handler::Prompt objects handle App::Info events by printing their +messages to C<STDOUT> and then accepting a new value from C<STDIN>. The new +value is validated by any callback supplied by the App::Info concrete subclass +that triggered the event. If the value is valid, App::Info::Handler::Prompt +assigns the new value to the event request. If it isn't it prints the error +message associated with the event request, and then prompts for the data +again. + +Although designed with unknown and confirm events in mind, +App::Info::Handler::Prompt handles info and error events as well. It will +simply print info event messages to C<STDOUT> and print error event messages +to C<STDERR>. For more interesting info and error event handling, see +L<App::Info::Handler::Print|App::Info::Handler::Print> and +L<App::Info::Handler::Carp|App::Info::Handler::Carp>. + +Upon loading, App::Info::Handler::Print registers itself with +App::Info::Handler, setting up a single string, "prompt", that can be passed +to an App::Info concrete subclass constructor. This string is a shortcut that +tells App::Info how to create an App::Info::Handler::Print object for handling +events. + +=cut + +use strict; +use App::Info::Handler; +use vars qw($VERSION @ISA); +$VERSION = '0.22'; +@ISA = qw(App::Info::Handler); + +# Register ourselves. +App::Info::Handler->register_handler + ('prompt' => sub { __PACKAGE__->new('prompt') } ); + +=head1 INTERFACE + +=head2 Constructor + +=head3 new + + my $prompter = App::Info::Handler::Prompt->new; + +Constructs a new App::Info::Handler::Prompt object and returns it. No special +arguments are required. + +=cut + +sub new { + my $pkg = shift; + my $self = $pkg->SUPER::new(@_); + $self->{tty} = -t STDIN && ( -t STDOUT || !( -f STDOUT || -c STDOUT ) ); + # We're done! + return $self; +} + +my $get_ans = sub { + my ($prompt, $tty, $def) = @_; + # Print the message. + local $| = 1; + local $\; + print $prompt; + + # Collect the answer. + my $ans; + if ($tty) { + $ans = <STDIN>; + if (defined $ans ) { + chomp $ans; + } else { # user hit ctrl-D + print "\n"; + } + } else { + print "$def\n" if defined $def; + } + return $ans; +}; + +sub handler { + my ($self, $req) = @_; + my $ans; + my $type = $req->type; + if ($type eq 'unknown' || $type eq 'confirm') { + # We'll want to prompt for a new value. + my $val = $req->value; + my ($def, $dispdef) = defined $val ? ($val, " [$val] ") : ('', ' '); + my $msg = $req->message or Carp::croak("No message in request"); + $msg .= $dispdef; + + # Get the answer. + $ans = $get_ans->($msg, $self->{tty}, $def); + # Just return if they entered an empty string or we couldnt' get an + # answer. + return 1 unless defined $ans && $ans ne ''; + + # Validate the answer. + my $err = $req->error; + while (!$req->value($ans)) { + print "$err: '$ans'\n"; + $ans = $get_ans->($msg, $self->{tty}, $def); + return 1 unless defined $ans && $ans ne ''; + } + + } elsif ($type eq 'info') { + # Just print the message. + print STDOUT $req->message, "\n"; + } elsif ($type eq 'error') { + # Just print the message. + print STDERR $req->message, "\n"; + } else { + # This shouldn't happen. + Carp::croak("Invalid request type '$type'"); + } + + # Return true to indicate that we've handled the request. + return 1; +} + +1; +__END__ + +=head1 BUGS + +Report all bugs via the CPAN Request Tracker at +L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=App-Info>. + +=head1 AUTHOR + +David Wheeler <L<david@wheeler.net|"david@wheeler.net">> + +=head1 SEE ALSO + +L<App::Info|App::Info> documents the event handling interface. + +L<App::Info::Handler::Carp|App::Info::Handler::Carp> handles events by +passing their messages Carp module functions. + +L<App::Info::Handler::Print|App::Info::Handler::Print> handles events by +printing their messages to a file handle. + +L<App::Info::Handler|App::Info::Handler> describes how to implement custom +App::Info event handlers. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2002, David Wheeler. All Rights Reserved. + +This module is free software; you can redistribute it and/or modify it under the +same terms as Perl itself. + +=cut diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/RDBMS.pm b/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/RDBMS.pm new file mode 100644 index 0000000..504d570 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/RDBMS.pm @@ -0,0 +1,55 @@ +package App::Info::RDBMS; + +# $Id: RDBMS.pm,v 1.1 2004-04-29 09:21:28 ivan Exp $ + +use strict; +use App::Info; +use vars qw(@ISA $VERSION); +@ISA = qw(App::Info); +$VERSION = '0.22'; + +1; +__END__ + +=head1 NAME + +App::Info::RDBMS - Information about databases on a system + +=head1 DESCRIPTION + +This class is an abstract base class for App::Info subclasses that provide +information about relational databases. Its subclasses are required to +implement its interface. See L<App::Info|App::Info> for a complete description +and L<App::Info::RDBMS::PostgreSQL|App::Info::RDBMS::PostgreSQL> for an example +implementation. + +=head1 INTERFACE + +Currently, App::Info::RDBMS adds no more methods than those from its parent +class, App::Info. + +=head1 BUGS + +Report all bugs via the CPAN Request Tracker at +L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=App-Info>. + +=head1 AUTHOR + +David Wheeler <L<david@wheeler.net|"david@wheeler.net">> + +=head1 SEE ALSO + +L<App::Info|App::Info>, +L<App::Info::RDBMS::PostgreSQL|App::Info::RDBMS::PostgreSQL> + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2002, David Wheeler. All Rights Reserved. + +This module is free software; you can redistribute it and/or modify it under the +same terms as Perl itself. + +=cut + + + diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/RDBMS/PostgreSQL.pm b/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/RDBMS/PostgreSQL.pm new file mode 100644 index 0000000..aef326c --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/RDBMS/PostgreSQL.pm @@ -0,0 +1,730 @@ +package App::Info::RDBMS::PostgreSQL; + +# $Id: PostgreSQL.pm,v 1.1 2004-04-29 09:21:29 ivan Exp $ + +=head1 NAME + +App::Info::RDBMS::PostgreSQL - Information about PostgreSQL + +=head1 SYNOPSIS + + use App::Info::RDBMS::PostgreSQL; + + my $pg = App::Info::RDBMS::PostgreSQL->new; + + if ($pg->installed) { + print "App name: ", $pg->name, "\n"; + print "Version: ", $pg->version, "\n"; + print "Bin dir: ", $pg->bin_dir, "\n"; + } else { + print "PostgreSQL is not installed. :-(\n"; + } + +=head1 DESCRIPTION + +App::Info::RDBMS::PostgreSQL supplies information about the PostgreSQL +database server installed on the local system. It implements all of the +methods defined by App::Info::RDBMS. Methods that trigger events will trigger +them only the first time they're called (See L<App::Info|App::Info> for +documentation on handling events). To start over (after, say, someone has +installed PostgreSQL) construct a new App::Info::RDBMS::PostgreSQL object to +aggregate new metadata. + +Some of the methods trigger the same events. This is due to cross-calling of +shared subroutines. However, any one event should be triggered no more than +once. For example, although the info event "Executing `pg_config --version`" +is documented for the methods C<name()>, C<version()>, C<major_version()>, +C<minor_version()>, and C<patch_version()>, rest assured that it will only be +triggered once, by whichever of those four methods is called first. + +=cut + +use strict; +use App::Info::RDBMS; +use App::Info::Util; +use vars qw(@ISA $VERSION); +@ISA = qw(App::Info::RDBMS); +$VERSION = '0.22'; + +my $u = App::Info::Util->new; + +=head1 INTERFACE + +=head2 Constructor + +=head3 new + + my $pg = App::Info::RDBMS::PostgreSQL->new(@params); + +Returns an App::Info::RDBMS::PostgreSQL object. See L<App::Info|App::Info> for +a complete description of argument parameters. + +When it called, C<new()> searches the file system for the F<pg_config> +application. If found, F<pg_config> will be called by the object methods below +to gather the data necessary for each. If F<pg_config> cannot be found, then +PostgreSQL is assumed not to be installed, and each of the object methods will +return C<undef>. + +App::Info::RDBMS::PostgreSQL searches for F<pg_config> along your path, as +defined by C<File::Spec-E<gt>path>. Failing that, it searches the following +directories: + +=over 4 + +=item /usr/local/pgsql/bin + +=item /usr/local/postgres/bin + +=item /opt/pgsql/bin + +=item /usr/local/bin + +=item /usr/local/sbin + +=item /usr/bin + +=item /usr/sbin + +=item /bin + +=back + +B<Events:> + +=over 4 + +=item info + +Looking for pg_config + +=item confirm + +Path to pg_config? + +=item unknown + +Path to pg_config? + +=back + +=cut + +sub new { + # Construct the object. + my $self = shift->SUPER::new(@_); + + # Find pg_config. + $self->info("Looking for pg_config"); + my @paths = ($u->path, + qw(/usr/local/pgsql/bin + /usr/local/postgres/bin + /opt/pgsql/bin + /usr/local/bin + /usr/local/sbin + /usr/bin + /usr/sbin + /bin)); + + if (my $cfg = $u->first_cat_exe('pg_config', @paths)) { + # We found it. Confirm. + $self->{pg_config} = $self->confirm( key => 'pg_config', + prompt => 'Path to pg_config?', + value => $cfg, + callback => sub { -x }, + error => 'Not an executable'); + } else { + # Handle an unknown value. + $self->{pg_config} = $self->unknown( key => 'pg_config', + prompt => 'Path to pg_config?', + callback => sub { -x }, + error => 'Not an executable'); + } + + return $self; +} + +# We'll use this code reference as a common way of collecting data. +my $get_data = sub { + return unless $_[0]->{pg_config}; + $_[0]->info("Executing `$_[0]->{pg_config} $_[1]`"); + my $info = `$_[0]->{pg_config} $_[1]`; + chomp $info; + return $info; +}; + +############################################################################## + +=head2 Class Method + +=head3 key_name + + my $key_name = App::Info::RDBMS::PostgreSQL->key_name; + +Returns the unique key name that describes this class. The value returned is +the string "PostgreSQL". + +=cut + +sub key_name { 'PostgreSQL' } + +############################################################################## + +=head2 Object Methods + +=head3 installed + + print "PostgreSQL is ", ($pg->installed ? '' : 'not '), "installed.\n"; + +Returns true if PostgreSQL is installed, and false if it is not. +App::Info::RDBMS::PostgreSQL determines whether PostgreSQL is installed based +on the presence or absence of the F<pg_config> application on the file system +as found when C<new()> constructed the object. If PostgreSQL does not appear +to be installed, then all of the other object methods will return empty +values. + +=cut + +sub installed { return $_[0]->{pg_config} ? 1 : undef } + +############################################################################## + +=head3 name + + my $name = $pg->name; + +Returns the name of the application. App::Info::RDBMS::PostgreSQL parses the +name from the system call C<`pg_config --version`>. + +B<Events:> + +=over 4 + +=item info + +Executing `pg_config --version` + +=item error + +Failed to find PostgreSQL version with `pg_config --version` + +Unable to parse name from string + +Unable to parse version from string + +Failed to parse PostgreSQL version parts from string + +=item unknown + +Enter a valid PostgreSQL name + +=back + +=cut + +# This code reference is used by name(), version(), major_version(), +# minor_version(), and patch_version() to aggregate the data they need. +my $get_version = sub { + my $self = shift; + $self->{'--version'} = 1; + my $data = $get_data->($self, '--version'); + unless ($data) { + $self->error("Failed to find PostgreSQL version with ". + "`$self->{pg_config} --version"); + return; + } + + chomp $data; + my ($name, $version) = split /\s+/, $data, 2; + + # Check for and assign the name. + $name ? + $self->{name} = $name : + $self->error("Unable to parse name from string '$data'"); + + # Parse the version number. + if ($version) { + my ($x, $y, $z) = $version =~ /(\d+)\.(\d+).(\d+)/; + if (defined $x and defined $y and defined $z) { + @{$self}{qw(version major minor patch)} = + ($version, $x, $y, $z); + } else { + $self->error("Failed to parse PostgreSQL version parts from " . + "string '$version'"); + } + } else { + $self->error("Unable to parse version from string '$data'"); + } +}; + +sub name { + my $self = shift; + return unless $self->{pg_config}; + + # Load data. + $get_version->($self) unless $self->{'--version'}; + + # Handle an unknown name. + $self->{name} ||= $self->unknown( key => 'name' ); + + # Return the name. + return $self->{name}; +} + +############################################################################## + +=head3 version + + my $version = $pg->version; + +Returns the PostgreSQL version number. App::Info::RDBMS::PostgreSQL parses the +version number from the system call C<`pg_config --version`>. + +B<Events:> + +=over 4 + +=item info + +Executing `pg_config --version` + +=item error + +Failed to find PostgreSQL version with `pg_config --version` + +Unable to parse name from string + +Unable to parse version from string + +Failed to parse PostgreSQL version parts from string + +=item unknown + +Enter a valid PostgreSQL version number + +=back + +=cut + +sub version { + my $self = shift; + return unless $self->{pg_config}; + + # Load data. + $get_version->($self) unless $self->{'--version'}; + + # Handle an unknown value. + unless ($self->{version}) { + # Create a validation code reference. + my $chk_version = sub { + # Try to get the version number parts. + my ($x, $y, $z) = /^(\d+)\.(\d+).(\d+)$/; + # Return false if we didn't get all three. + return unless $x and defined $y and defined $z; + # Save all three parts. + @{$self}{qw(major minor patch)} = ($x, $y, $z); + # Return true. + return 1; + }; + $self->{version} = $self->unknown( key => 'version number', + callback => $chk_version); + } + + return $self->{version}; +} + +############################################################################## + +=head3 major version + + my $major_version = $pg->major_version; + +Returns the PostgreSQL major version number. App::Info::RDBMS::PostgreSQL +parses the major version number from the system call C<`pg_config --version`>. +For example, C<version()> returns "7.1.2", then this method returns "7". + +B<Events:> + +=over 4 + +=item info + +Executing `pg_config --version` + +=item error + +Failed to find PostgreSQL version with `pg_config --version` + +Unable to parse name from string + +Unable to parse version from string + +Failed to parse PostgreSQL version parts from string + +=item unknown + +Enter a valid PostgreSQL major version number + +=back + +=cut + +# This code reference is used by major_version(), minor_version(), and +# patch_version() to validate a version number entered by a user. +my $is_int = sub { /^\d+$/ }; + +sub major_version { + my $self = shift; + return unless $self->{pg_config}; + # Load data. + $get_version->($self) unless exists $self->{'--version'}; + # Handle an unknown value. + $self->{major} = $self->unknown( key => 'major version number', + callback => $is_int) + unless $self->{major}; + return $self->{major}; +} + +############################################################################## + +=head3 minor version + + my $minor_version = $pg->minor_version; + +Returns the PostgreSQL minor version number. App::Info::RDBMS::PostgreSQL +parses the minor version number from the system call C<`pg_config --version`>. +For example, if C<version()> returns "7.1.2", then this method returns "2". + +B<Events:> + +=over 4 + +=item info + +Executing `pg_config --version` + +=item error + +Failed to find PostgreSQL version with `pg_config --version` + +Unable to parse name from string + +Unable to parse version from string + +Failed to parse PostgreSQL version parts from string + +=item unknown + +Enter a valid PostgreSQL minor version number + +=back + +=cut + +sub minor_version { + my $self = shift; + return unless $self->{pg_config}; + # Load data. + $get_version->($self) unless exists $self->{'--version'}; + # Handle an unknown value. + $self->{minor} = $self->unknown( key => 'minor version number', + callback => $is_int) + unless defined $self->{minor}; + return $self->{minor}; +} + +############################################################################## + +=head3 patch version + + my $patch_version = $pg->patch_version; + +Returns the PostgreSQL patch version number. App::Info::RDBMS::PostgreSQL +parses the patch version number from the system call C<`pg_config --version`>. +For example, if C<version()> returns "7.1.2", then this method returns "1". + +B<Events:> + +=over 4 + +=item info + +Executing `pg_config --version` + +=item error + +Failed to find PostgreSQL version with `pg_config --version` + +Unable to parse name from string + +Unable to parse version from string + +Failed to parse PostgreSQL version parts from string + +=item unknown + +Enter a valid PostgreSQL minor version number + +=back + +=cut + +sub patch_version { + my $self = shift; + return unless $self->{pg_config}; + # Load data. + $get_version->($self) unless exists $self->{'--version'}; + # Handle an unknown value. + $self->{patch} = $self->unknown( key => 'patch version number', + callback => $is_int) + unless defined $self->{patch}; + return $self->{patch}; +} + +############################################################################## + +=head3 bin_dir + + my $bin_dir = $pg->bin_dir; + +Returns the PostgreSQL binary directory path. App::Info::RDBMS::PostgreSQL +gathers the path from the system call C<`pg_config --bindir`>. + +B<Events:> + +=over 4 + +=item info + +Executing `pg_config --bindir` + +=item error + +Cannot find bin directory + +=item unknown + +Enter a valid PostgreSQL bin directory + +=back + +=cut + +# This code reference is used by bin_dir(), lib_dir(), and so_lib_dir() to +# validate a directory entered by the user. +my $is_dir = sub { -d }; + +sub bin_dir { + my $self = shift; + return unless $self->{pg_config}; + unless (exists $self->{bin_dir} ) { + if (my $dir = $get_data->($self, '--bindir')) { + $self->{bin_dir} = $dir; + } else { + # Handle an unknown value. + $self->error("Cannot find bin directory"); + $self->{bin_dir} = $self->unknown( key => 'bin directory', + callback => $is_dir) + } + } + + return $self->{bin_dir}; +} + +############################################################################## + +=head3 inc_dir + + my $inc_dir = $pg->inc_dir; + +Returns the PostgreSQL include directory path. App::Info::RDBMS::PostgreSQL +gathers the path from the system call C<`pg_config --includedir`>. + +B<Events:> + +=over 4 + +=item info + +Executing `pg_config --includedir` + +=item error + +Cannot find include directory + +=item unknown + +Enter a valid PostgreSQL include directory + +=back + +=cut + +sub inc_dir { + my $self = shift; + return unless $self->{pg_config}; + unless (exists $self->{inc_dir} ) { + if (my $dir = $get_data->($self, '--includedir')) { + $self->{inc_dir} = $dir; + } else { + # Handle an unknown value. + $self->error("Cannot find include directory"); + $self->{inc_dir} = $self->unknown( key => 'include directory', + callback => $is_dir) + } + } + + return $self->{inc_dir}; +} + +############################################################################## + +=head3 lib_dir + + my $lib_dir = $pg->lib_dir; + +Returns the PostgreSQL library directory path. App::Info::RDBMS::PostgreSQL +gathers the path from the system call C<`pg_config --libdir`>. + +B<Events:> + +=over 4 + +=item info + +Executing `pg_config --libdir` + +=item error + +Cannot find library directory + +=item unknown + +Enter a valid PostgreSQL library directory + +=back + +=cut + +sub lib_dir { + my $self = shift; + return unless $self->{pg_config}; + unless (exists $self->{lib_dir} ) { + if (my $dir = $get_data->($self, '--libdir')) { + $self->{lib_dir} = $dir; + } else { + # Handle an unknown value. + $self->error("Cannot find library directory"); + $self->{lib_dir} = $self->unknown( key => 'library directory', + callback => $is_dir) + } + } + + return $self->{lib_dir}; +} + +############################################################################## + +=head3 so_lib_dir + + my $so_lib_dir = $pg->so_lib_dir; + +Returns the PostgreSQL shared object library directory path. +App::Info::RDBMS::PostgreSQL gathers the path from the system call +C<`pg_config --pkglibdir`>. + +B<Events:> + +=over 4 + +=item info + +Executing `pg_config --pkglibdir` + +=item error + +Cannot find shared object library directory + +=item unknown + +Enter a valid PostgreSQL shared object library directory + +=back + +=cut + +# Location of dynamically loadable modules. +sub so_lib_dir { + my $self = shift; + return unless $self->{pg_config}; + unless (exists $self->{so_lib_dir} ) { + if (my $dir = $get_data->($self, '--pkglibdir')) { + $self->{so_lib_dir} = $dir; + } else { + # Handle an unknown value. + $self->error("Cannot find shared object library directory"); + $self->{so_lib_dir} = + $self->unknown( key => 'shared object library directory', + callback => $is_dir) + } + } + + return $self->{so_lib_dir}; +} + +############################################################################## + +=head3 home_url + + my $home_url = $pg->home_url; + +Returns the PostgreSQL home page URL. + +=cut + +sub home_url { "http://www.postgresql.org/" } + +############################################################################## + +=head3 download_url + + my $download_url = $pg->download_url; + +Returns the PostgreSQL download URL. + +=cut + +sub download_url { "http://www.ca.postgresql.org/sitess.html" } + +1; +__END__ + +=head1 BUGS + +Report all bugs via the CPAN Request Tracker at +L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=App-Info>. + +=head1 AUTHOR + +David Wheeler <L<david@wheeler.net|"david@wheeler.net">> based on code by Sam +Tregar <L<sam@tregar.com|"sam@tregar.com">>. + +=head1 SEE ALSO + +L<App::Info|App::Info> documents the event handling interface. + +L<App::Info::RDBMS|App::Info::RDBMS> is the App::Info::RDBMS::PostgreSQL +parent class. + +L<DBD::Pg|DBD::Pg> is the L<DBI|DBI> driver for connecting to PostgreSQL +databases. + +L<http://www.postgresql.org/> is the PostgreSQL home page. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2002, David Wheeler. All Rights Reserved. + +This module is free software; you can redistribute it and/or modify it under the +same terms as Perl itself. + +=cut diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/Request.pm b/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/Request.pm new file mode 100644 index 0000000..c02c97b --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/Request.pm @@ -0,0 +1,287 @@ +package App::Info::Request; + +# $Id: Request.pm,v 1.1 2004-04-29 09:21:28 ivan Exp $ + +=head1 NAME + +App::Info::Request - App::Info event handler request object + +=head1 SYNOPSIS + + # In an App::Info::Handler subclass: + sub handler { + my ($self, $req) = @_; + print "Event Type: ", $req->type; + print "Message: ", $req->message; + print "Error: ", $req->error; + print "Value: ", $req->value; + } + +=head1 DESCRIPTION + +Objects of this class are passed to the C<handler()> method of App::Info event +handlers. Generally, this class will be of most interest to App::Info::Handler +subclass implementers. + +The L<event triggering methods|App::Info/"Events"> in App::Info each construct +a new App::Info::Request object and initialize it with their arguments. The +App::Info::Request object is then the sole argument passed to the C<handler()> +method of any and all App::Info::Handler objects in the event handling chain. +Thus, if you'd like to create your own App::Info event handler, this is the +object you need to be familiar with. Consult the +L<App::Info::Handler|App::Info::Handler> documentation for details on creating +custom event handlers. + +Each of the App::Info event triggering methods constructs an +App::Info::Request object with different attribute values. Be sure to consult +the documentation for the L<event triggering methods|App::Info/"Events"> in +App::Info, where the values assigned to the App::Info::Request object are +documented. Then, in your event handler subclass, check the value returned by +the C<type()> method to determine what type of event request you're handling +to handle the request appropriately. + +=cut + +use strict; +use vars qw($VERSION); +$VERSION = '0.23'; + +############################################################################## + +=head1 INTERFACE + +The following sections document the App::Info::Request interface. + +=head2 Constructor + +=head3 new + + my $req = App::Info::Request->new(%params); + +This method is used internally by App::Info to construct new +App::Info::Request objects to pass to event handler objects. Generally, you +won't need to use it, other than perhaps for testing custom App::Info::Handler +classes. + +The parameters to C<new()> are passed as a hash of named parameters that +correspond to their like-named methods. The supported parameters are: + +=over 4 + +=item type + +=item message + +=item error + +=item value + +=item callback + +=back + +See the object methods documentation below for details on these object +attributes. + +=cut + +sub new { + my $pkg = shift; + + # Make sure we've got a hash of arguments. + Carp::croak("Odd number of parameters in call to " . __PACKAGE__ . + "->new() when named parameters expected" ) if @_ % 2; + my %params = @_; + + # Validate the callback. + if ($params{callback}) { + Carp::croak("Callback parameter '$params{callback}' is not a code ", + "reference") + unless UNIVERSAL::isa($params{callback}, 'CODE'); + } else { + # Otherwise just assign a default approve callback. + $params{callback} = sub { 1 }; + } + + # Validate type parameter. + if (my $t = $params{type}) { + Carp::croak("Invalid handler type '$t'") + unless $t eq 'error' or $t eq 'info' or $t eq 'unknown' + or $t eq 'confirm'; + } else { + $params{type} = 'info'; + } + + # Return the request object. + bless \%params, ref $pkg || $pkg; +} + +############################################################################## + +=head2 Object Methods + +=head3 message + + my $message = $req->message; + +Returns the message stored in the App::Info::Request object. The message is +typically informational, or an error message, or a prompt message. + +=cut + +sub message { $_[0]->{message} } + +############################################################################## + +=head3 error + + my $error = $req->error; + +Returns any error message associated with the App::Info::Request object. The +error message is typically there to display for users when C<callback()> +returns false. + +=cut + +sub error { $_[0]->{error} } + +############################################################################## + +=head3 type + + my $type = $req->type; + +Returns a string representing the type of event that triggered this request. +The types are the same as the event triggering methods defined in App::Info. +As of this writing, the supported types are: + +=over + +=item info + +=item error + +=item unknown + +=item confirm + +=back + +Be sure to consult the App::Info documentation for more details on the event +types. + +=cut + +sub type { $_[0]->{type} } + +############################################################################## + +=head3 callback + + if ($req->callback($value)) { + print "Value '$value' is valid.\n"; + } else { + print "Value '$value' is not valid.\n"; + } + +Executes the callback anonymous subroutine supplied by the App::Info concrete +base class that triggered the event. If the callback returns false, then +C<$value> is invalid. If the callback returns true, then C<$value> is valid +and can be assigned via the C<value()> method. + +Note that the C<value()> method itself calls C<callback()> if it was passed a +value to assign. See its documentation below for more information. + +=cut + +sub callback { + my $self = shift; + my $code = $self->{callback}; + local $_ = $_[0]; + $code->(@_); +} + +############################################################################## + +=head3 value + + my $value = $req->value; + if ($req->value($value)) { + print "Value '$value' successfully assigned.\n"; + } else { + print "Value '$value' not successfully assigned.\n"; + } + +When called without an argument, C<value()> simply returns the value currently +stored by the App::Info::Request object. Typically, the value is the default +value for a confirm event, or a value assigned to an unknown event. + +When passed an argument, C<value()> attempts to store the the argument as a +new value. However, C<value()> calls C<callback()> on the new value, and if +C<callback()> returns false, then C<value()> returns false and does not store +the new value. If C<callback()> returns true, on the other hand, then +C<value()> goes ahead and stores the new value and returns true. + +=cut + +sub value { + my $self = shift; + if ($#_ >= 0) { + # grab the value. + my $value = shift; + # Validate the value. + if ($self->callback($value)) { + # The value is good. Assign it and return true. + $self->{value} = $value; + return 1; + } else { + # Invalid value. Return false. + return; + } + } + # Just return the value. + return $self->{value}; +} + +1; +__END__ + +=head1 BUGS + +Report all bugs via the CPAN Request Tracker at +L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=App-Info>. + +=head1 AUTHOR + +David Wheeler <L<david@wheeler.net|"david@wheeler.net">> + +=head1 SEE ALSO + +L<App::Info|App::Info> documents the event triggering methods and how they +construct App::Info::Request objects to pass to event handlers. + +L<App::Info::Handler:|App::Info::Handler> documents how to create custom event +handlers, which must make use of the App::Info::Request object passed to their +C<handler()> object methods. + +The following classes subclass App::Info::Handler, and thus offer good +exemplars for using App::Info::Request objects when handling events. + +=over 4 + +=item L<App::Info::Handler::Carp|App::Info::Handler::Carp> + +=item L<App::Info::Handler::Print|App::Info::Handler::Print> + +=item L<App::Info::Handler::Prompt|App::Info::Handler::Prompt> + +=back + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2002, David Wheeler. All Rights Reserved. + +This module is free software; you can redistribute it and/or modify it under the +same terms as Perl itself. + +=cut diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/Util.pm b/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/Util.pm new file mode 100644 index 0000000..55bb333 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/Util.pm @@ -0,0 +1,456 @@ +package App::Info::Util; + +# $Id: Util.pm,v 1.1 2004-04-29 09:21:28 ivan Exp $ + +=head1 NAME + +App::Info::Util - Utility class for App::Info subclasses + +=head1 SYNOPSIS + + use App::Info::Util; + + my $util = App::Info::Util->new; + + # Subclasses File::Spec. + my @paths = $util->paths; + + # First directory that exists in a list. + my $dir = $util->first_dir(@paths); + + # First directory that exists in a path. + $dir = $util->first_path($ENV{PATH}); + + # First file that exists in a list. + my $file = $util->first_file('this.txt', '/that.txt', 'C:\\foo.txt'); + + # First file found among file base names and directories. + my $files = ['this.txt', 'that.txt']; + $file = $util->first_cat_file($files, @paths); + +=head1 DESCRIPTION + +This class subclasses L<File::Spec|File::Spec> and adds its own methods in +order to offer utility methods to L<App::Info|App::Info> classes. Although +intended to be used by App::Info subclasses, in truth App::Info::Util's +utility may be considered more general, so feel free to use it elsewhere. + +The methods added in addition to the usual File::Spec suspects are designed to +facilitate locating files and directories on the file system, as well as +searching those files. The assumption is that, in order to provide useful +metadata about a given software package, an App::Info subclass must find +relevant files and directories and parse them with regular expressions. This +class offers methods that simplify those tasks. + +=cut + +use strict; +use File::Spec (); +use vars qw(@ISA $VERSION); +@ISA = qw(File::Spec); +$VERSION = '0.22'; + +my %path_dems = (MacOS => qr',', + MSWin32 => qr';', + os2 => qr';', + VMS => undef, + epoc => undef); + +my $path_dem = exists $path_dems{$^O} ? $path_dems{$^O} : qr':'; + +=head1 CONSTRUCTOR + +=head2 new + + my $util = App::Info::Util->new; + +This is a very simple constructor that merely returns an App::Info::Util +object. Since, like its File::Spec super class, App::Info::Util manages no +internal data itself, all methods may be used as class methods, if one prefers +to. The constructor here is provided merely as a convenience. + +=cut + +sub new { bless {}, ref $_[0] || $_[0] } + +=head1 OBJECT METHODS + +In addition to all of the methods offered by its super class, +L<File::Spec|File::Spec>, App::Info::Util offers the following methods. + +=head2 first_dir + + my @paths = $util->paths; + my $dir = $util->first_dir(@dirs); + +Returns the first file system directory in @paths that exists on the local +file system. Only the first item in @paths that exists as a directory will be +returned; any other paths leading to non-directories will be ignored. + +=cut + +sub first_dir { + shift; + foreach (@_) { return $_ if -d } + return; +} + +=head2 first_path + + my $path = $ENV{PATH}; + $dir = $util->first_path($path); + +Takes the $path string and splits it into a list of directory paths, based on +the path demarcator on the local file system. Then calls C<first_dir()> to +return the first directoy in the path list that exists on the local file +system. The path demarcator is specified for the following file systems: + +=over 4 + +=item MacOS: "," + +=item MSWin32: ";" + +=item os2: ";" + +=item VMS: undef + +This method always returns undef on VMS. Patches welcome. + +=item epoc: undef + +This method always returns undef on epoch. Patches welcome. + +=item Unix: ":" + +All other operating systems are assumed to be Unix-based. + +=back + +=cut + +sub first_path { + return unless $path_dem; + shift->first_dir(split /$path_dem/, shift) +} + +=head2 first_file + + my $file = $util->first_file(@filelist); + +Examines each of the files in @filelist and returns the first one that exists +on the file system. The file must be a regular file -- directories will be +ignored. + +=cut + +sub first_file { + shift; + foreach (@_) { return $_ if -f } + return; +} + +=head2 first_exe + + my $exe = $util->first_exe(@exelist); + +Examines each of the files in @exelist and returns the first one that exists +on the file system as an executable file. Directories will be ignored. + +=cut + +sub first_exe { + shift; + foreach (@_) { return $_ if -f && -x } + return; +} + +=head2 first_cat_path + + my $file = $util->first_cat_path('ick.txt', @paths); + $file = $util->first_cat_path(['this.txt', 'that.txt'], @paths); + +The first argument to this method may be either a file or directory base name +(that is, a file or directory name without a full path specification), or a +reference to an array of file or directory base names. The remaining arguments +constitute a list of directory paths. C<first_cat_path()> processes each of +these directory paths, concatenates (by the method native to the local +operating system) each of the file or directory base names, and returns the +first one that exists on the file system. + +For example, let us say that we were looking for a file called either F<httpd> +or F<apache>, and it could be in any of the following paths: +F</usr/local/bin>, F</usr/bin/>, F</bin>. The method call looks like this: + + my $httpd = $util->first_cat_path(['httpd', 'apache'], '/usr/local/bin', + '/usr/bin/', '/bin'); + +If the OS is a Unix variant, C<first_cat_path()> will then look for the first +file that exists in this order: + +=over 4 + +=item /usr/local/bin/httpd + +=item /usr/local/bin/apache + +=item /usr/bin/httpd + +=item /usr/bin/apache + +=item /bin/httpd + +=item /bin/apache + +=back + +The first of these complete paths to be found will be returned. If none are +found, then undef will be returned. + +=cut + +sub first_cat_path { + my $self = shift; + my $files = ref $_[0] ? shift() : [shift()]; + foreach my $p (@_) { + foreach my $f (@$files) { + my $path = $self->catfile($p, $f); + return $path if -e $path; + } + } + return; +} + +=head2 first_cat_dir + + my $dir = $util->first_cat_dir('ick.txt', @paths); + $dir = $util->first_cat_dir(['this.txt', 'that.txt'], @paths); + +Funtionally identical to C<first_cat_path()>, except that it returns the +directory path in which the first file was found, rather than the full +concatenated path. Thus, in the above example, if the file found was +F</usr/bin/httpd>, while C<first_cat_path()> would return that value, +C<first_cat_dir()> would return F</usr/bin> instead. + +=cut + +sub first_cat_dir { + my $self = shift; + my $files = ref $_[0] ? shift() : [shift()]; + foreach my $p (@_) { + foreach my $f (@$files) { + my $path = $self->catfile($p, $f); + return $p if -e $path; + } + } + return; +} + +=head2 first_cat_exe + + my $exe = $util->first_cat_exe('ick.txt', @paths); + $exe = $util->first_cat_exe(['this.txt', 'that.txt'], @paths); + +Funtionally identical to C<first_cat_path()>, except that it returns the full +path to the first executable file found, rather than simply the first file +found. + +=cut + +sub first_cat_exe { + my $self = shift; + my $files = ref $_[0] ? shift() : [shift()]; + foreach my $p (@_) { + foreach my $f (@$files) { + my $path = $self->catfile($p, $f); + return $path if -f $path && -x $path; + } + } + return; +} + +=head2 search_file + + my $file = 'foo.txt'; + my $regex = qr/(text\s+to\s+find)/; + my $value = $util->search_file($file, $regex); + +Opens C<$file> and executes the C<$regex> regular expression against each line +in the file. Once the line matches and one or more values is returned by the +match, the file is closed and the value or values returned. + +For example, say F<foo.txt> contains the line "Version 6.5, patch level 8", +and you need to grab each of the three version parts. All three parts can +be grabbed like this: + + my $regex = qr/Version\s+(\d+)\.(\d+),[^\d]*(\d+)/; + my @nums = $util->search_file($file, $regex); + +Now C<@nums> will contain the values C<(6, 5, 8)>. Note that in a scalar +context, the above search would yeild an array reference: + + my $regex = qr/Version\s+(\d+)\.(\d+),[^\d]*(\d+)/; + my $nums = $util->search_file($file, $regex); + +So now C<$nums> contains C<[6, 5, 8]>. The same does not hold true if the +match returns only one value, however. Say F<foo.txt> contains the line +"king of the who?", and you wish to know who the king is king of. Either +of the following two calls would get you the data you need: + + my $minions = $util->search_file($file, qr/King\s+of\s+(.*)/); + my @minions = $util->search_file($file, qr/King\s+of\s+(.*)/); + +In the first case, because the regular expression contains only one set of +parentheses, C<search_file()> will simply return that value: C<$minions> +contains the string "the who?". In the latter case, C<@minions> of course +contains a single element: C<("the who?")>. + +Note that a regular expression without parentheses -- that is, one that +doesn't grab values and put them into $1, $2, etc., will never successfully +match a line in this method. You must include something to parentetically +match. If you just want to know the value of what was matched, parenthesize +the whole thing and if the value returns, you have a match. Also, if you need +to match patterns across lines, try using multiple regular expressions with +C<multi_search_file()>, instead. + +=cut + +sub search_file { + my ($self, $file, $regex) = @_; + return unless $file && $regex; + open F, "<$file" or Carp::croak "Cannot open $file: $!\n"; + my @ret; + while (<F>) { + # If we find a match, we're done. + (@ret) = /$regex/ and last; + } + close F; + # If the match returned an more than one value, always return the full + # array. Otherwise, return just the first value in a scalar context. + return unless @ret; + return wantarray ? @ret : $#ret <= 0 ? $ret[0] : \@ret; +} + +=head2 multi_search_file + + my @regexen = (qr/(one)/, qr/(two)\s+(three)/); + my @matches = $util->multi_search_file($file, @regexen); + +Like C<search_file()>, this mehod opens C<$file> and parses it for regular +expresion matches. This method, however, can take a list of regular +expressions to look for, and will return the values found for all of them. +Regular expressions that match and return multiple values will be returned as +array referernces, while those that match and return a single value will +return just that single value. + +For example, say you are parsing a file with lines like the following: + + #define XML_MAJOR_VERSION 1 + #define XML_MINOR_VERSION 95 + #define XML_MICRO_VERSION 2 + +You need to get each of these numbers, but calling C<search_file()> for each +of them would be wasteful, as each call to C<search_file()> opens the file and +parses it. With C<multi_search_file()>, on the other hand, the file will be +opened only once, and, once all of the regular expressions have returned +matches, the file will be closed and the matches returned. + +Thus the above values can be collected like this: + + my @regexen = ( qr/XML_MAJOR_VERSION\s+(\d+)$/, + qr/XML_MINOR_VERSION\s+(\d+)$/, + qr/XML_MICRO_VERSION\s+(\d+)$/ ); + + my @nums = $file->multi_search_file($file, @regexen); + +The result will be that C<@nums> contains C<(1, 95, 2)>. Note that +C<multi_file_search()> tries to do the right thing by only parsing the file +until all of the regular expressions have been matched. Thus, a large file +with the values you need near the top can be parsed very quickly. + +As with C<search_file()>, C<multi_search_file()> can take regular expressions +that match multiple values. These will be returned as array references. For +example, say the file you're parsing has files like this: + + FooApp Version 4 + Subversion 2, Microversion 6 + +To get all of the version numbers, you can either use three regular +expressions, as in the previous example: + + my @regexen = ( qr/FooApp\s+Version\s+(\d+)$/, + qr/Subversion\s+(\d+),/, + qr/Microversion\s+(\d$)$/ ); + + my @nums = $file->multi_search_file($file, @regexen); + +In which case C<@nums> will contain C<(4, 2, 6)>. Or, you can use just two +regular expressions: + + my @regexen = ( qr/FooApp\s+Version\s+(\d+)$/, + qr/Subversion\s+(\d+),\s+Microversion\s+(\d$)$/ ); + + my @nums = $file->multi_search_file($file, @regexen); + +In which case C<@nums> will contain C<(4, [2, 6])>. Note that the two +parentheses that return values in the second regular expression cause the +matches to be returned as an array reference. + +=cut + +sub multi_search_file { + my ($self, $file, @regexen) = @_; + return unless $file && @regexen; + my @each = @regexen; + open F, "<$file" or Carp::croak "Cannot open $file: $!\n"; + my %ret; + while (my $line = <F>) { + my @splice; + # Process each of the regular expresssions. + for (my $i = 0; $i < @each; $i++) { + if ((my @ret) = $line =~ /$each[$i]/) { + # We have a match! If there's one match returned, just grab + # it. If there's more than one, keep it as an array ref. + $ret{$each[$i]} = $#ret > 0 ? \@ret : $ret[0]; + # We got values for this regex, so not its place in the @each + # array. + push @splice, $i; + } + } + # Remove any regexen that have already found a match. + for (@splice) { splice @each, $_, 1 } + # If there are no more regexes, we're done -- no need to keep + # processing lines in the file! + last unless @each; + } + close F; + return unless %ret; + return wantarray ? @ret{@regexen} : \@ret{@regexen}; +} + +1; +__END__ + +=head1 BUGS + +Report all bugs via the CPAN Request Tracker at +L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=App-Info>. + +=head1 AUTHOR + +David Wheeler <L<david@wheeler.net|"david@wheeler.net">> + +=head1 SEE ALSO + +L<App::Info|App::Info>, L<File::Spec|File::Spec>, +L<App::Info::HTTPD::Apache|App::Info::HTTPD::Apache> +L<App::Info::RDBMS::PostgreSQL|App::Info::RDBMS::PostgreSQL> + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2002, David Wheeler. All Rights Reserved. + +This module is free software; you can redistribute it and/or modify it under the +same terms as Perl itself. + +=cut diff --git a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/Changes b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/Changes new file mode 100644 index 0000000..f413bd9 --- /dev/null +++ b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/Changes @@ -0,0 +1,62 @@ +Revision history for Perl extension DBIx::DBSchema. + +0.23 Mon Feb 16 17:35:54 PST 2004 + - Update Pg dependancy to 1.32 + - Update the simple load test so it skips DBIx::DBSchema::DBD::Pg if + DBD::Pg 1.32 is not installed. + +0.22 Thu Oct 23 15:18:21 PDT 2003 + - Pg reverse-engineering fix: varchar with no limit + - Pg needs (unreleased) DBD::Pg 1.30 (or deb 1.22-2... interesting) + +0.21 Thu Sep 19 05:04:18 PDT 2002 + - Pg reverse-engineering fix: now sets default + +0.20 Mon Mar 4 04:58:34 2002 + - documentation updates + - fix Column->new when using named params + - fix Pg driver reverse-engineering length of numeric columns: + translate 655362 to 10,2, etc. + - fix Pg driver reverse-engineering of text columns (don't have a + length) + +0.19 Tue Oct 23 08:49:12 2001 + - documentation for %typemap + - preliminary Sybase driver from Charles Shapiro + <charles.shapiro@numethods.com> and Mitchell J. Friedman + <mitchell.friedman@numethods.com>. + - Fix Column::line to return a scalar as documented, not a list. + - Should finally eliminate the Use of uninitialized value at + ... DBIx/DBSchema/Column.pm line 251 + +0.18 Fri Aug 10 17:07:28 2001 + - Added Table::delcolumn + - patch from Charles Shapiro <cshapiro@numethods.com> to add + `ORDER BY a.attnum' to the SQL in DBIx::DBSchema::DBD::Pg::columns + +0.17 Sat Jul 7 17:55:33 2001 + - Rework Table->new interface for named params + - Fixes for Pg blobs, yay! + - MySQL doesn't need non-standard index syntax anymore (since 3.22). + - patch from Mark Ethan Trostler <mark@zzo.com> for generating + tables without indices. + +0.16 Fri Jan 5 15:55:50 2001 + - Don't overflow index names. + +0.15 Fri Nov 24 23:39:16 2000 + - MySQL handling of BOOL type (change to TINYINT) + +0.14 Tue Oct 24 14:43:16 2000 + - MySQL handling of SERIAL type (change to INTEGER AUTO_INCREMENT) + +0.13 Wed Oct 11 10:47:13 2000 + - fixed up type mapping foo, added default values, added named + parameters to Column->new, fixed quoting of default values + +0.11 Sun Sep 28 02:16:25 2000 + - oops, original verison got 0.10, so this one will get 0.11 + +0.01 Sun Sep 17 07:57:35 2000 + - original version; created by h2xs 1.19 + diff --git a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema.pm b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema.pm new file mode 100644 index 0000000..fc4916d --- /dev/null +++ b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema.pm @@ -0,0 +1,367 @@ +package DBIx::DBSchema; + +use strict; +use vars qw(@ISA $VERSION); +#use Exporter; +use Carp qw(confess); +use DBI; +use FreezeThaw qw(freeze thaw cmpStr); +use DBIx::DBSchema::Table; +use DBIx::DBSchema::Column; +use DBIx::DBSchema::ColGroup::Unique; +use DBIx::DBSchema::ColGroup::Index; + +#@ISA = qw(Exporter); +@ISA = (); + +$VERSION = "0.23"; + +=head1 NAME + +DBIx::DBSchema - Database-independent schema objects + +=head1 SYNOPSIS + + use DBIx::DBSchema; + + $schema = new DBIx::DBSchema @dbix_dbschema_table_objects; + $schema = new_odbc DBIx::DBSchema $dbh; + $schema = new_odbc DBIx::DBSchema $dsn, $user, $pass; + $schema = new_native DBIx::DBSchema $dbh; + $schema = new_native DBIx::DBSchema $dsn, $user, $pass; + + $schema->save("filename"); + $schema = load DBIx::DBSchema "filename"; + + $schema->addtable($dbix_dbschema_table_object); + + @table_names = $schema->tables; + + $DBIx_DBSchema_table_object = $schema->table("table_name"); + + @sql = $schema->sql($dbh); + @sql = $schema->sql($dsn, $username, $password); + @sql = $schema->sql($dsn); #doesn't connect to database - less reliable + + $perl_code = $schema->pretty_print; + %hash = eval $perl_code; + use DBI qw(:sql_types); $schema = pretty_read DBIx::DBSchema \%hash; + +=head1 DESCRIPTION + +DBIx::DBSchema objects are collections of DBIx::DBSchema::Table objects and +represent a database schema. + +This module implements an OO-interface to database schemas. Using this module, +you can create a database schema with an OO Perl interface. You can read the +schema from an existing database. You can save the schema to disk and restore +it a different process. Most importantly, DBIx::DBSchema can write SQL +CREATE statements statements for different databases from a single source. + +Currently supported databases are MySQL and PostgreSQL. Sybase support is +partially implemented. DBIx::DBSchema will attempt to use generic SQL syntax +for other databases. Assistance adding support for other databases is +welcomed. See L<DBIx::DBSchema::DBD>, "Driver Writer's Guide and Base Class". + +=head1 METHODS + +=over 4 + +=item new TABLE_OBJECT, TABLE_OBJECT, ... + +Creates a new DBIx::DBSchema object. + +=cut + +sub new { + my($proto, @tables) = @_; + my %tables = map { $_->name, $_ } @tables; #check for duplicates? + + my $class = ref($proto) || $proto; + my $self = { + 'tables' => \%tables, + }; + + bless ($self, $class); + +} + +=item new_odbc DATABASE_HANDLE | DATA_SOURCE USERNAME PASSWORD [ ATTR ] + +Creates a new DBIx::DBSchema object from an existing data source, which can be +specified by passing an open DBI database handle, or by passing the DBI data +source name, username, and password. This uses the experimental DBI type_info +method to create a schema with standard (ODBC) SQL column types that most +closely correspond to any non-portable column types. Use this to import a +schema that you wish to use with many different database engines. Although +primary key and (unique) index information will only be read from databases +with DBIx::DBSchema::DBD drivers (currently MySQL and PostgreSQL), import of +column names and attributes *should* work for any database. Note that this +method only uses "ODBC" column types; it does not require or use an ODBC +driver. + +=cut + +sub new_odbc { + my($proto, $dbh) = (shift, shift); + $dbh = DBI->connect( $dbh, @_ ) or die $DBI::errstr unless ref($dbh); + $proto->new( + map { new_odbc DBIx::DBSchema::Table $dbh, $_ } _tables_from_dbh($dbh) + ); +} + +=item new_native DATABASE_HANDLE | DATA_SOURCE USERNAME PASSWORD [ ATTR ] + +Creates a new DBIx::DBSchema object from an existing data source, which can be +specified by passing an open DBI database handle, or by passing the DBI data +source name, username and password. This uses database-native methods to read +the schema, and will preserve any non-portable column types. The method is +only available if there is a DBIx::DBSchema::DBD for the corresponding database engine (currently, MySQL and PostgreSQL). + +=cut + +sub new_native { + my($proto, $dbh) = (shift, shift); + $dbh = DBI->connect( $dbh, @_ ) or die $DBI::errstr unless ref($dbh); + $proto->new( + map { new_native DBIx::DBSchema::Table ( $dbh, $_ ) } _tables_from_dbh($dbh) + ); +} + +=item load FILENAME + +Loads a DBIx::DBSchema object from a file. + +=cut + +sub load { + my($proto,$file)=@_; #use $proto ? + open(FILE,"<$file") or die "Can't open $file: $!"; + my($string)=join('',<FILE>); #can $string have newlines? pry not? + close FILE or die "Can't close $file: $!"; + my($self)=thaw $string; + #no bless needed? + $self; +} + +=item save FILENAME + +Saves a DBIx::DBSchema object to a file. + +=cut + +sub save { + my($self,$file)=@_; + my($string)=freeze $self; + open(FILE,">$file") or die "Can't open $file: $!"; + print FILE $string; + close FILE or die "Can't close file: $!"; + my($check_self)=thaw $string; + die "Verify error: Can't freeze and thaw dbdef $self" + if (cmpStr($self,$check_self)); +} + +=item addtable TABLE_OBJECT + +Adds the given DBIx::DBSchema::Table object to this DBIx::DBSchema. + +=cut + +sub addtable { + my($self,$table)=@_; + $self->{'tables'}->{$table->name} = $table; #check for dupliates? +} + +=item tables + +Returns a list of the names of all tables. + +=cut + +sub tables { + my($self)=@_; + keys %{$self->{'tables'}}; +} + +=item table TABLENAME + +Returns the specified DBIx::DBSchema::Table object. + +=cut + +sub table { + my($self,$table)=@_; + $self->{'tables'}->{$table}; +} + +=item sql [ DATABASE_HANDLE | DATA_SOURCE [ USERNAME PASSWORD [ ATTR ] ] ] + +Returns a list of SQL `CREATE' statements for this schema. + +The data source can be specified by passing an open DBI database handle, or by +passing the DBI data source name, username and password. + +Although the username and password are optional, it is best to call this method +with a database handle or data source including a valid username and password - +a DBI connection will be opened and the quoting and type mapping will be more +reliable. + +If passed a DBI data source (or handle) such as `DBI:mysql:database' or +`DBI:Pg:dbname=database', will use syntax specific to that database engine. +Currently supported databases are MySQL and PostgreSQL. + +If not passed a data source (or handle), or if there is no driver for the +specified database, will attempt to use generic SQL syntax. + +=cut + +sub sql { + my($self, $dbh) = (shift, shift); + my $created_dbh = 0; + unless ( ref($dbh) || ! @_ ) { + $dbh = DBI->connect( $dbh, @_ ) or die $DBI::errstr; + $created_dbh = 1; + } + my @r = map { $self->table($_)->sql_create_table($dbh); } $self->tables; + $dbh->disconnect if $created_dbh; + @r; +} + +=item pretty_print + +Returns the data in this schema as Perl source, suitable for assigning to a +hash. + +=cut + +sub pretty_print { + my($self) = @_; + join("},\n\n", + map { + my $table = $_; + "'$table' => {\n". + " 'columns' => [\n". + join("", map { + #cant because -w complains about , in qw() + # (also biiiig problems with empty lengths) + #" qw( $_ ". + #$self->table($table)->column($_)->type. " ". + #( $self->table($table)->column($_)->null ? 'NULL' : 0 ). " ". + #$self->table($table)->column($_)->length. " ),\n" + " '$_', ". + "'". $self->table($table)->column($_)->type. "', ". + "'". $self->table($table)->column($_)->null. "', ". + "'". $self->table($table)->column($_)->length. "', ". + "'". $self->table($table)->column($_)->default. "', ". + "'". $self->table($table)->column($_)->local. "',\n" + } $self->table($table)->columns + ). + " ],\n". + " 'primary_key' => '". $self->table($table)->primary_key. "',\n". + " 'unique' => [ ". join(', ', + map { "[ '". join("', '", @{$_}). "' ]" } + @{$self->table($table)->unique->lol_ref} + ). " ],\n". + " 'index' => [ ". join(', ', + map { "[ '". join("', '", @{$_}). "' ]" } + @{$self->table($table)->index->lol_ref} + ). " ],\n" + #" 'index' => [ ". " ],\n" + } $self->tables + ), "}\n"; +} + +=cut + +=item pretty_read HASHREF + +Creates a schema as specified by a data structure such as that created by +B<pretty_print> method. + +=cut + +sub pretty_read { + my($proto, $href) = @_; + my $schema = $proto->new( map { + my(@columns); + while ( @{$href->{$_}{'columns'}} ) { + push @columns, DBIx::DBSchema::Column->new( + splice @{$href->{$_}{'columns'}}, 0, 6 + ); + } + DBIx::DBSchema::Table->new( + $_, + $href->{$_}{'primary_key'}, + DBIx::DBSchema::ColGroup::Unique->new($href->{$_}{'unique'}), + DBIx::DBSchema::ColGroup::Index->new($href->{$_}{'index'}), + @columns, + ); + } (keys %{$href}) ); +} + +# private subroutines + +sub _load_driver { + my($dbh) = @_; + my $driver; + if ( ref($dbh) ) { + $driver = $dbh->{Driver}->{Name}; + } else { + $dbh =~ s/^dbi:(\w*?)(?:\((.*?)\))?://i #nicked from DBI->connect + or '' =~ /()/; # ensure $1 etc are empty if match fails + $driver = $1 or confess "can't parse data source: $dbh"; + } + + #require "DBIx/DBSchema/DBD/$driver.pm"; + #$driver; + eval 'require "DBIx/DBSchema/DBD/$driver.pm"' and $driver or die $@; +} + +sub _tables_from_dbh { + my($dbh) = @_; + my $sth = $dbh->table_info or die $dbh->errstr; + #map { $_->{TABLE_NAME} } grep { $_->{TABLE_TYPE} eq 'TABLE' } + # @{ $sth->fetchall_arrayref({ TABLE_NAME=>1, TABLE_TYPE=>1}) }; + map { $_->[0] } grep { $_->[1] =~ /^TABLE$/i } + @{ $sth->fetchall_arrayref([2,3]) }; +} + +=back + +=head1 AUTHOR + +Ivan Kohler <ivan-dbix-dbschema@420.am> + +Charles Shapiro <charles.shapiro@numethods.com> and Mitchell Friedman +<mitchell.friedman@numethods.com> contributed the start of a Sybase driver. + +=head1 COPYRIGHT + +Copyright (c) 2000 Ivan Kohler +Copyright (c) 2000 Mail Abuse Prevention System LLC +All rights reserved. +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=head1 BUGS + +Each DBIx::DBSchema object should have a name which corresponds to its name +within the SQL database engine (DBI data source). + +pretty_print is actually pretty ugly. + +Perhaps pretty_read should eval column types so that we can use DBI +qw(:sql_types) here instead of externally. + +=head1 SEE ALSO + +L<DBIx::DBSchema::Table>, L<DBIx::DBSchema::ColGroup>, +L<DBIx::DBSchema::ColGroup::Unique>, L<DBIx::DBSchema::ColGroup::Index>, +L<DBIx::DBSchema::Column>, L<DBIx::DBSchema::DBD>, +L<DBIx::DBSchema::DBD::mysql>, L<DBIx::DBSchema::DBD::Pg>, L<FS::Record>, +L<DBI> + +=cut + +1; + diff --git a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/ColGroup.pm b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/ColGroup.pm new file mode 100644 index 0000000..ceeb223 --- /dev/null +++ b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/ColGroup.pm @@ -0,0 +1,141 @@ +package DBIx::DBSchema::ColGroup; + +use strict; +use vars qw(@ISA); +#use Exporter; + +#@ISA = qw(Exporter); +@ISA = qw(); + +=head1 NAME + +DBIx::DBSchema::ColGroup - Column group objects + +=head1 SYNOPSIS + + use DBIx::DBSchema::ColGroup; + + $colgroup = new DBIx::DBSchema::ColGroup ( $lol_ref ); + $colgroup = new DBIx::DBSchema::ColGroup ( \@lol ); + $colgroup = new DBIx::DBSchema::ColGroup ( + [ + [ 'single_column' ], + [ 'multiple_columns', 'another_column', ], + ] + ); + + $lol_ref = $colgroup->lol_ref; + + @sql_lists = $colgroup->sql_list; + + @singles = $colgroup->singles; + +=head1 DESCRIPTION + +DBIx::DBSchema::ColGroup objects represent sets of sets of columns. (IOW a +"list of lists" - see L<perllol>.) + +=head1 METHODS + +=over 4 + +=item new [ LOL_REF ] + +Creates a new DBIx::DBSchema::ColGroup object. Pass a reference to a list of +lists of column names. + +=cut + +sub new { + my($proto, $lol) = @_; + + my $class = ref($proto) || $proto; + my $self = { + 'lol' => $lol, + }; + + bless ($self, $class); + +} + +=item lol_ref + +Returns a reference to a list of lists of column names. + +=cut + +sub lol_ref { + my($self) = @_; + $self->{'lol'}; +} + +=item sql_list + +Returns a flat list of comma-separated values, for SQL statements. + +For example: + + @lol = ( + [ 'single_column' ], + [ 'multiple_columns', 'another_column', ], + ); + + $colgroup = new DBIx::DBSchema::ColGroup ( \@lol ); + + print join("\n", $colgroup->sql_list), "\n"; + +Will print: + + single_column + multiple_columns, another_column + +=cut + +sub sql_list { #returns a flat list of comman-separates lists (for sql) + my($self)=@_; + grep $_ ne '', map join(', ', @{$_}), @{$self->{'lol'}}; +} + +=item singles + +Returns a flat list of all single item lists. + +=cut + +sub singles { #returns single-field groups as a flat list + my($self)=@_; + #map ${$_}[0], grep scalar(@{$_}) == 1, @{$self->{'lol'}}; + map { + ${$_}[0] =~ /^(\w+)$/ + #aah! + or die "Illegal column ", ${$_}[0], " in colgroup!"; + $1; + } grep scalar(@{$_}) == 1, @{$self->{'lol'}}; +} + +=back + +=head1 AUTHOR + +Ivan Kohler <ivan-dbix-dbschema@420.am> + +=head1 COPYRIGHT + +Copyright (c) 2000 Ivan Kohler +Copyright (c) 2000 Mail Abuse Prevention System LLC +All rights reserved. +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=head1 BUGS + +=head1 SEE ALSO + +L<DBIx::DBSchema::Table>, L<DBIx::DBSchema::ColGroup::Unique>, +L<DBIx::DBSchema::ColGroup::Index>, L<DBIx::DBSchema>, L<perllol>, L<perldsc>, +L<DBI> + +=cut + +1; + diff --git a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/ColGroup/Index.pm b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/ColGroup/Index.pm new file mode 100644 index 0000000..1a92baa --- /dev/null +++ b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/ColGroup/Index.pm @@ -0,0 +1,37 @@ +package DBIx::DBSchema::ColGroup::Index; + +use strict; +use vars qw(@ISA); +use DBIx::DBSchema::ColGroup; + +@ISA=qw(DBIx::DBSchema::ColGroup); + +=head1 NAME + +DBIx::DBSchema::ColGroup::Index - Index column group object + +=head1 SYNOPSIS + + use DBIx::DBSchema::ColGroup::Index; + + # see DBIx::DBSchema::ColGroup methods + +=head1 DESCRIPTION + +DBIx::DBSchema::ColGroup::Index objects represent the (non-unique) indices of a +database table (L<DBIx::DBSchema::Table>). DBIx::DBSchema::ColGroup::Index +inherits from DBIx::DBSchema::ColGroup. + +=head1 BUGS + +Is this empty subclass needed? + +=head1 SEE ALSO + +L<DBIx::DBSchema::ColGroup>, L<DBIx::DBSchema::ColGroup::Unique>, +L<DBIx::DBSchema::Table>, L<DBIx::DBSchema>, L<FS::Record> + +=cut + +1; + diff --git a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/ColGroup/Unique.pm b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/ColGroup/Unique.pm new file mode 100644 index 0000000..450043f --- /dev/null +++ b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/ColGroup/Unique.pm @@ -0,0 +1,38 @@ +package DBIx::DBSchema::ColGroup::Unique; + +use strict; +use vars qw(@ISA); +use DBIx::DBSchema::ColGroup; + +@ISA=qw(DBIx::DBSchema::ColGroup); + +=head1 NAME + +DBIx::DBSchema::ColGroup::Unique - Unique column group object + +=head1 SYNOPSIS + + use DBIx::DBSchema::ColGroup::Unique; + + # see DBIx::DBSchema::ColGroup methods + +=head1 DESCRIPTION + +DBIx::DBSchema::ColGroup::Unique objects represent the unique indices of a +database table (L<DBIx::DBSchema::Table>). DBIx::DBSchema::ColGroup:Unique +inherits from DBIx::DBSchema::ColGroup. + +=head1 BUGS + +Is this empty subclass needed? + +=head1 SEE ALSO + +L<DBIx::DBSchema::ColGroup>, L<DBIx::DBSchema::ColGroup::Index>, +L<DBIx::DBSchema::Table>, L<DBIx::DBSchema>, L<FS::Record> + +=cut + +1; + + diff --git a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/Column.pm b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/Column.pm new file mode 100644 index 0000000..4e26646 --- /dev/null +++ b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/Column.pm @@ -0,0 +1,300 @@ +package DBIx::DBSchema::Column; + +use strict; +use vars qw(@ISA $VERSION); +#use Carp; +#use Exporter; + +#@ISA = qw(Exporter); +@ISA = qw(); + +$VERSION = '0.02'; + +=head1 NAME + +DBIx::DBSchema::Column - Column objects + +=head1 SYNOPSIS + + use DBIx::DBSchema::Column; + + #named params with a hashref (preferred) + $column = new DBIx::DBSchema::Column ( { + 'name' => 'column_name', + 'type' => 'varchar' + 'null' => 'NOT NULL', + 'length' => 64, + 'default' => ' + 'local' => '', + } ); + + #list + $column = new DBIx::DBSchema::Column ( $name, $sql_type, $nullability, $length, $default, $local ); + + $name = $column->name; + $column->name( 'name' ); + + $sql_type = $column->type; + $column->type( 'sql_type' ); + + $null = $column->null; + $column->null( 'NULL' ); + $column->null( 'NOT NULL' ); + $column->null( '' ); + + $length = $column->length; + $column->length( '10' ); + $column->length( '8,2' ); + + $default = $column->default; + $column->default( 'Roo' ); + + $sql_line = $column->line; + $sql_line = $column->line($datasrc); + +=head1 DESCRIPTION + +DBIx::DBSchema::Column objects represent columns in tables (see +L<DBIx::DBSchema::Table>). + +=head1 METHODS + +=over 4 + +=item new HASHREF + +=item new [ name [ , type [ , null [ , length [ , default [ , local ] ] ] ] ] ] + +Creates a new DBIx::DBSchema::Column object. Takes a hashref of named +parameters, or a list. B<name> is the name of the column. B<type> is the SQL +data type. B<null> is the nullability of the column (intrepreted using Perl's +rules for truth, with one exception: `NOT NULL' is false). B<length> is the +SQL length of the column. B<default> is the default value of the column. +B<local> is reserved for database-specific information. + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + + my $self; + if ( ref($_[0]) ) { + $self = shift; + } else { + $self = { map { $_ => shift } qw(name type null length default local) }; + } + + #croak "Illegal name: ". $self->{'name'} + # if grep $self->{'name'} eq $_, @reserved_words; + + $self->{'null'} =~ s/^NOT NULL$//i; + $self->{'null'} = 'NULL' if $self->{'null'}; + + bless ($self, $class); + +} + +=item name [ NAME ] + +Returns or sets the column name. + +=cut + +sub name { + my($self,$value)=@_; + if ( defined($value) ) { + #croak "Illegal name: $name" if grep $name eq $_, @reserved_words; + $self->{'name'} = $value; + } else { + $self->{'name'}; + } +} + +=item type [ TYPE ] + +Returns or sets the column type. + +=cut + +sub type { + my($self,$value)=@_; + if ( defined($value) ) { + $self->{'type'} = $value; + } else { + $self->{'type'}; + } +} + +=item null [ NULL ] + +Returns or sets the column null flag (the empty string is equivalent to +`NOT NULL') + +=cut + +sub null { + my($self,$value)=@_; + if ( defined($value) ) { + $value =~ s/^NOT NULL$//i; + $value = 'NULL' if $value; + $self->{'null'} = $value; + } else { + $self->{'null'}; + } +} + +=item length [ LENGTH ] + +Returns or sets the column length. + +=cut + +sub length { + my($self,$value)=@_; + if ( defined($value) ) { + $self->{'length'} = $value; + } else { + $self->{'length'}; + } +} + +=item default [ LOCAL ] + +Returns or sets the default value. + +=cut + +sub default { + my($self,$value)=@_; + if ( defined($value) ) { + $self->{'default'} = $value; + } else { + $self->{'default'}; + } +} + + +=item local [ LOCAL ] + +Returns or sets the database-specific field. + +=cut + +sub local { + my($self,$value)=@_; + if ( defined($value) ) { + $self->{'local'} = $value; + } else { + $self->{'local'}; + } +} + +=item line [ DATABASE_HANDLE | DATA_SOURCE [ USERNAME PASSWORD [ ATTR ] ] ] + +Returns an SQL column definition. + +The data source can be specified by passing an open DBI database handle, or by +passing the DBI data source name, username and password. + +Although the username and password are optional, it is best to call this method +with a database handle or data source including a valid username and password - +a DBI connection will be opened and the quoting and type mapping will be more +reliable. + +If passed a DBI data source (or handle) such as `DBI:mysql:database' or +`DBI:Pg:dbname=database', will use syntax specific to that database engine. +Currently supported databases are MySQL and PostgreSQL. Non-standard syntax +for other engines (if applicable) may also be supported in the future. + +=cut + +sub line { + my($self,$dbh) = (shift, shift); + + my $created_dbh = 0; + unless ( ref($dbh) || ! @_ ) { + $dbh = DBI->connect( $dbh, @_ ) or die $DBI::errstr; + my $gratuitous = $DBI::errstr; #surpress superfluous `used only once' error + $created_dbh = 1; + } + + my $driver = DBIx::DBSchema::_load_driver($dbh); + my %typemap; + %typemap = eval "\%DBIx::DBSchema::DBD::${driver}::typemap" if $driver; + my $type = defined( $typemap{uc($self->type)} ) + ? $typemap{uc($self->type)} + : $self->type; + + my $null = $self->null; + + my $default; + if ( defined($self->default) && $self->default ne '' + && ref($dbh) + # false laziness: nicked from FS::Record::_quote + && ( $self->default !~ /^\-?\d+(\.\d+)?$/ + || $type =~ /(char|binary|blob|text)$/i + ) + ) { + $default = $dbh->quote($self->default); + } else { + $default = $self->default; + } + + #this should be a callback into the driver + if ( $driver eq 'mysql' ) { #yucky mysql hack + $null ||= "NOT NULL"; + $self->local('AUTO_INCREMENT') if uc($self->type) eq 'SERIAL'; + } elsif ( $driver eq 'Pg' ) { #yucky Pg hack + $null ||= "NOT NULL"; + $null =~ s/^NULL$//; + } + + my $r = join(' ', + $self->name, + $type. ( ( defined($self->length) && $self->length ) + ? '('.$self->length.')' + : '' + ), + $null, + ( ( defined($default) && $default ne '' ) + ? 'DEFAULT '. $default + : '' + ), + ( ( $driver eq 'mysql' && defined($self->local) ) + ? $self->local + : '' + ), + ); + $dbh->disconnect if $created_dbh; + $r; + +} + +=back + +=head1 AUTHOR + +Ivan Kohler <ivan-dbix-dbschema@420.am> + +=head1 COPYRIGHT + +Copyright (c) 2000 Ivan Kohler +Copyright (c) 2000 Mail Abuse Prevention System LLC +All rights reserved. +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=head1 BUGS + +line() has database-specific foo that probably ought to be abstracted into +the DBIx::DBSchema:DBD:: modules. + +=head1 SEE ALSO + +L<DBIx::DBSchema::Table>, L<DBIx::DBSchema>, L<DBIx::DBSchema::DBD>, L<DBI> + +=cut + +1; + diff --git a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/DBD.pm b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/DBD.pm new file mode 100644 index 0000000..a4c6000 --- /dev/null +++ b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/DBD.pm @@ -0,0 +1,113 @@ +package DBIx::DBSchema::DBD; + +use strict; +use vars qw($VERSION); + +$VERSION = '0.02'; + +=head1 NAME + +DBIx::DBSchema::DBD - DBIx::DBSchema Driver Writer's Guide and Base Class + +=head1 SYNOPSIS + + perldoc DBIx::DBSchema::DBD + + package DBIx::DBSchema::DBD::FooBase + use DBIx::DBSchmea::DBD; + @ISA = qw(DBIx::DBSchema::DBD); + +=head1 DESCRIPTION + +Drivers should be named DBIx::DBSchema::DBD::DatabaseName, where DatabaseName +is the same as the DBD:: driver for this database. Drivers should implement the +following class methods: + +=over 4 + +=item columns CLASS DBI_DBH TABLE + +Given an active DBI database handle, return a listref of listrefs (see +L<perllol>), each containing six elements: column name, column type, +nullability, column length, column default, and a field reserved for +driver-specific use. + +=item column CLASS DBI_DBH TABLE COLUMN + +Same as B<columns> above, except return the listref for a single column. You +can inherit from DBIx::DBSchema::DBD to provide this function. + +=cut + +sub column { + my($proto, $dbh, $table, $column) = @_; + #@a = grep { $_->[0] eq $column } @{ $proto->columns( $dbh, $table ) }; + #$a[0]; + @{ [ + grep { $_->[0] eq $column } @{ $proto->columns( $dbh, $table ) } + ] }[0]; #force list context on grep, return scalar of first element +} + +=item primary_key CLASS DBI_DBH TABLE + +Given an active DBI database handle, return the primary key for the specified +table. + +=item unique CLASS DBI_DBH TABLE + +Given an active DBI database handle, return a hashref of unique indices. The +keys of the hashref are index names, and the values are arrayrefs which point +a list of column names for each. See L<perldsc/"HASHES OF LISTS"> and +L<DBIx::DBSchema::ColGroup>. + +=item index CLASS DBI_DBH TABLE + +Given an active DBI database handle, return a hashref of (non-unique) indices. +The keys of the hashref are index names, and the values are arrayrefs which +point a list of column names for each. See L<perldsc/"HASHES OF LISTS"> and +L<DBIx::DBSchema::ColGroup>. + +=back + +=head1 TYPE MAPPING + +You can define a %typemap array for your driver to map "standard" data +types to database-specific types. For example, the MySQL TIMESTAMP field +has non-standard auto-updating semantics; the MySQL DATETIME type is +what other databases and the ODBC standard call TIMESTAMP, so one of the +entries in the MySQL %typemap is: + + 'TIMESTAMP' => 'DATETIME', + +Another example is the Pg %typemap which maps the standard types BLOB and +LONG VARBINARY to the Pg-specific BYTEA: + + 'BLOB' => 'BYTEA', + 'LONG VARBINARY' => 'BYTEA', + +Make sure you use all uppercase-keys. + +=head1 AUTHOR + +Ivan Kohler <ivan-dbix-dbschema@420.am> + +=head1 COPYRIGHT + +Copyright (c) 2000 Ivan Kohler +Copyright (c) 2000 Mail Abuse Prevention System LLC +All rights reserved. +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=head1 BUGS + +=head1 SEE ALSO + +L<DBIx::DBSchema>, L<DBIx::DBSchema::DBD::mysql>, L<DBIx::DBSchema::DBD::Pg>, +L<DBIx::DBSchema::ColGroup>, L<DBI>, L<DBI::DBD>, L<perllol>, +L<perldsc/"HASHES OF LISTS"> + +=cut + +1; + diff --git a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/DBD/Pg.pm b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/DBD/Pg.pm new file mode 100644 index 0000000..018b890 --- /dev/null +++ b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/DBD/Pg.pm @@ -0,0 +1,175 @@ +package DBIx::DBSchema::DBD::Pg; + +use strict; +use vars qw($VERSION @ISA %typemap); +use DBD::Pg 1.22; +use DBIx::DBSchema::DBD; + +$VERSION = '0.08'; +@ISA = qw(DBIx::DBSchema::DBD); + +%typemap = ( + 'BLOB' => 'BYTEA', + 'LONG VARBINARY' => 'BYTEA', +); + +=head1 NAME + +DBIx::DBSchema::DBD::Pg - PostgreSQL native driver for DBIx::DBSchema + +=head1 SYNOPSIS + +use DBI; +use DBIx::DBSchema; + +$dbh = DBI->connect('dbi:Pg:dbname=database', 'user', 'pass'); +$schema = new_native DBIx::DBSchema $dbh; + +=head1 DESCRIPTION + +This module implements a PostgreSQL-native driver for DBIx::DBSchema. + +=cut + +sub columns { + my($proto, $dbh, $table) = @_; + my $sth = $dbh->prepare(<<END) or die $dbh->errstr; + SELECT a.attname, t.typname, a.attlen, a.atttypmod, a.attnotnull, + a.atthasdef, a.attnum + FROM pg_class c, pg_attribute a, pg_type t + WHERE c.relname = '$table' + AND a.attnum > 0 AND a.attrelid = c.oid AND a.atttypid = t.oid + ORDER BY a.attnum +END + $sth->execute or die $sth->errstr; + + map { + + my $default = ''; + if ( $_->{atthasdef} ) { + my $attnum = $_->{attnum}; + my $d_sth = $dbh->prepare(<<END) or die $dbh->errstr; + SELECT substring(d.adsrc for 128) FROM pg_attrdef d, pg_class c + WHERE c.relname = '$table' AND c.oid = d.adrelid AND d.adnum = $attnum +END + $d_sth->execute or die $d_sth->errstr; + + $default = $d_sth->fetchrow_arrayref->[0]; + }; + + my $len = ''; + if ( $_->{attlen} == -1 && $_->{atttypmod} != -1 + && $_->{typname} ne 'text' ) { + $len = $_->{atttypmod} - 4; + if ( $_->{typname} eq 'numeric' ) { + $len = ($len >> 16). ','. ($len & 0xffff); + } + } + + my $type = $_->{'typname'}; + $type = 'char' if $type eq 'bpchar'; + + [ + $_->{'attname'}, + $type, + ! $_->{'attnotnull'}, + $len, + $default, + '' #local + ]; + + } @{ $sth->fetchall_arrayref({}) }; +} + +sub primary_key { + my($proto, $dbh, $table) = @_; + my $sth = $dbh->prepare(<<END) or die $dbh->errstr; + SELECT a.attname, a.attnum + FROM pg_class c, pg_attribute a, pg_type t + WHERE c.relname = '${table}_pkey' + AND a.attnum > 0 AND a.attrelid = c.oid AND a.atttypid = t.oid +END + $sth->execute or die $sth->errstr; + my $row = $sth->fetchrow_hashref or return ''; + $row->{'attname'}; +} + +sub unique { + my($proto, $dbh, $table) = @_; + my $gratuitous = { map { $_ => [ $proto->_index_fields($dbh, $_ ) ] } + grep { $proto->_is_unique($dbh, $_ ) } + $proto->_all_indices($dbh, $table) + }; +} + +sub index { + my($proto, $dbh, $table) = @_; + my $gratuitous = { map { $_ => [ $proto->_index_fields($dbh, $_ ) ] } + grep { ! $proto->_is_unique($dbh, $_ ) } + $proto->_all_indices($dbh, $table) + }; +} + +sub _all_indices { + my($proto, $dbh, $table) = @_; + my $sth = $dbh->prepare(<<END) or die $dbh->errstr; + SELECT c2.relname + FROM pg_class c, pg_class c2, pg_index i + WHERE c.relname = '$table' AND c.oid = i.indrelid AND i.indexrelid = c2.oid +END + $sth->execute or die $sth->errstr; + map { $_->{'relname'} } + grep { $_->{'relname'} !~ /_pkey$/ } + @{ $sth->fetchall_arrayref({}) }; +} + +sub _index_fields { + my($proto, $dbh, $index) = @_; + my $sth = $dbh->prepare(<<END) or die $dbh->errstr; + SELECT a.attname, a.attnum + FROM pg_class c, pg_attribute a, pg_type t + WHERE c.relname = '$index' + AND a.attnum > 0 AND a.attrelid = c.oid AND a.atttypid = t.oid +END + $sth->execute or die $sth->errstr; + map { $_->{'attname'} } @{ $sth->fetchall_arrayref({}) }; +} + +sub _is_unique { + my($proto, $dbh, $index) = @_; + my $sth = $dbh->prepare(<<END) or die $dbh->errstr; + SELECT i.indisunique + FROM pg_index i, pg_class c, pg_am a + WHERE i.indexrelid = c.oid AND c.relname = '$index' AND c.relam = a.oid +END + $sth->execute or die $sth->errstr; + my $row = $sth->fetchrow_hashref or die 'guru meditation #420'; + $row->{'indisunique'}; +} + +=head1 AUTHOR + +Ivan Kohler <ivan-dbix-dbschema@420.am> + +=head1 COPYRIGHT + +Copyright (c) 2000 Ivan Kohler +Copyright (c) 2000 Mail Abuse Prevention System LLC +All rights reserved. +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=head1 BUGS + +Yes. + +columns doesn't return column default information. + +=head1 SEE ALSO + +L<DBIx::DBSchema>, L<DBIx::DBSchema::DBD>, L<DBI>, L<DBI::DBD> + +=cut + +1; + diff --git a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/DBD/Sybase.pm b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/DBD/Sybase.pm new file mode 100755 index 0000000..4a74069 --- /dev/null +++ b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/DBD/Sybase.pm @@ -0,0 +1,141 @@ +package DBIx::DBSchema::DBD::Sybase; + +use strict; +use vars qw($VERSION @ISA %typemap); +use DBIx::DBSchema::DBD; + +$VERSION = '0.03'; +@ISA = qw(DBIx::DBSchema::DBD); + +%typemap = ( +# 'empty' => 'empty' +); + +=head1 NAME + +DBIx::DBSchema::DBD::Sybase - Sybase database driver for DBIx::DBSchema + +=head1 SYNOPSIS + +use DBI; +use DBIx::DBSchema; + +$dbh = DBI->connect('dbi:Sybase:dbname=database', 'user', 'pass'); +$schema = new_native DBIx::DBSchema $dbh; + +=head1 DESCRIPTION + +This module implements a Sybase driver for DBIx::DBSchema. + +=cut + +sub columns { + my($proto, $dbh, $table) = @_; + + my $sth = $dbh->prepare("sp_columns \@table_name=$table") + or die $dbh->errstr; + + $sth->execute or die $sth->errstr; + my @cols = map { + [ + $_->{'column_name'}, + $_->{'type_name'}, + ($_->{'nullable'} ? 1 : ''), + $_->{'length'}, + '', #default + '' #local + ] + } @{ $sth->fetchall_arrayref({}) }; + $sth->finish; + + @cols; +} + +sub primary_key { + return("StubbedPrimaryKey"); +} + + +sub unique { + my($proto, $dbh, $table) = @_; + my $gratuitous = { map { $_ => [ $proto->_index_fields($dbh, $table, $_ ) ] } + grep { $proto->_is_unique($dbh, $_ ) } + $proto->_all_indices($dbh, $table) + }; +} + +sub index { + my($proto, $dbh, $table) = @_; + my $gratuitous = { map { $_ => [ $proto->_index_fields($dbh, $table, $_ ) ] } + grep { ! $proto->_is_unique($dbh, $_ ) } + $proto->_all_indices($dbh, $table) + }; +} + +sub _all_indices { + my($proto, $dbh, $table) = @_; + + my $sth = $dbh->prepare_cached(<<END) or die $dbh->errstr; + SELECT name + FROM sysindexes + WHERE id = object_id('$table') and indid between 1 and 254 +END + $sth->execute or die $sth->errstr; + my @indices = map { $_->[0] } @{ $sth->fetchall_arrayref() }; + $sth->finish; + $sth = undef; + @indices; +} + +sub _index_fields { + my($proto, $dbh, $table, $index) = @_; + + my @keys; + + my ($indid) = $dbh->selectrow_array("select indid from sysindexes where id = object_id('$table') and name = '$index'"); + for (1..30) { + push @keys, $dbh->selectrow_array("select index_col('$table', $indid, $_)") || (); + } + + return @keys; +} + +sub _is_unique { + my($proto, $dbh, $table, $index) = @_; + + my ($isunique) = $dbh->selectrow_array("select status & 2 from sysindexes where id = object_id('$table') and name = '$index'"); + + return $isunique; +} + +=head1 AUTHOR + +Charles Shapiro <charles.shapiro@numethods.com> +(courtesy of Ivan Kohler <ivan-dbix-dbschema@420.am>) + +Mitchell Friedman <mitchell.friedman@numethods.com> + +Bernd Dulfer <bernd@widd.de> + +=head1 COPYRIGHT + +Copyright (c) 2001 Charles Shapiro, Mitchell J. Friedman +Copyright (c) 2001 nuMethods LLC. +All rights reserved. +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=head1 BUGS + +Yes. + +The B<primary_key> method does not yet work. + +=head1 SEE ALSO + +L<DBIx::DBSchema>, L<DBIx::DBSchema::DBD>, L<DBI>, L<DBI::DBD> + +=cut + +1; + diff --git a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/DBD/mysql.pm b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/DBD/mysql.pm new file mode 100644 index 0000000..f3804dd --- /dev/null +++ b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/DBD/mysql.pm @@ -0,0 +1,126 @@ +package DBIx::DBSchema::DBD::mysql; + +use strict; +use vars qw($VERSION @ISA %typemap); +use DBIx::DBSchema::DBD; + +$VERSION = '0.03'; +@ISA = qw(DBIx::DBSchema::DBD); + +%typemap = ( + 'TIMESTAMP' => 'DATETIME', + 'SERIAL' => 'INTEGER', + 'BOOL' => 'TINYINT', + 'LONG VARBINARY' => 'LONGBLOB', +); + +=head1 NAME + +DBIx::DBSchema::DBD::mysql - MySQL native driver for DBIx::DBSchema + +=head1 SYNOPSIS + +use DBI; +use DBIx::DBSchema; + +$dbh = DBI->connect('dbi:mysql:database', 'user', 'pass'); +$schema = new_native DBIx::DBSchema $dbh; + +=head1 DESCRIPTION + +This module implements a MySQL-native driver for DBIx::DBSchema. + +=cut + +sub columns { + my($proto, $dbh, $table ) = @_; + my $sth = $dbh->prepare("SHOW COLUMNS FROM $table") or die $dbh->errstr; + $sth->execute or die $sth->errstr; + map { + $_->{'Type'} =~ /^(\w+)\(?([\d\,]+)?\)?( unsigned)?$/ + or die "Illegal type: ". $_->{'Type'}. "\n"; + my($type, $length) = ($1, $2); + [ + $_->{'Field'}, + $type, + $_->{'Null'}, + $length, + $_->{'Default'}, + $_->{'Extra'} + ] + } @{ $sth->fetchall_arrayref( {} ) }; +} + +#sub primary_key { +# my($proto, $dbh, $table ) = @_; +# my $primary_key = ''; +# my $sth = $dbh->prepare("SHOW INDEX FROM $table") +# or die $dbh->errstr; +# $sth->execute or die $sth->errstr; +# my @pkey = map { $_->{'Column_name'} } grep { +# $_->{'Key_name'} eq "PRIMARY" +# } @{ $sth->fetchall_arrayref( {} ) }; +# scalar(@pkey) ? $pkey[0] : ''; +#} + +sub primary_key { + my($proto, $dbh, $table) = @_; + my($pkey, $unique_href, $index_href) = $proto->_show_index($dbh, $table); + $pkey; +} + +sub unique { + my($proto, $dbh, $table) = @_; + my($pkey, $unique_href, $index_href) = $proto->_show_index($dbh, $table); + $unique_href; +} + +sub index { + my($proto, $dbh, $table) = @_; + my($pkey, $unique_href, $index_href) = $proto->_show_index($dbh, $table); + $index_href; +} + +sub _show_index { + my($proto, $dbh, $table ) = @_; + my $sth = $dbh->prepare("SHOW INDEX FROM $table") + or die $dbh->errstr; + $sth->execute or die $sth->errstr; + + my $pkey = ''; + my(%index, %unique); + foreach my $row ( @{ $sth->fetchall_arrayref({}) } ) { + if ( $row->{'Key_name'} eq 'PRIMARY' ) { + $pkey = $row->{'Column_name'}; + } elsif ( $row->{'Non_unique'} ) { #index + push @{ $index{ $row->{'Key_name'} } }, $row->{'Column_name'}; + } else { #unique + push @{ $unique{ $row->{'Key_name'} } }, $row->{'Column_name'}; + } + } + + ( $pkey, \%unique, \%index ); +} + +=head1 AUTHOR + +Ivan Kohler <ivan-dbix-dbschema@420.am> + +=head1 COPYRIGHT + +Copyright (c) 2000 Ivan Kohler +Copyright (c) 2000 Mail Abuse Prevention System LLC +All rights reserved. +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=head1 BUGS + +=head1 SEE ALSO + +L<DBIx::DBSchema>, L<DBIx::DBSchema::DBD>, L<DBI>, L<DBI::DBD> + +=cut + +1; + diff --git a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/Table.pm b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/Table.pm new file mode 100644 index 0000000..2d6272e --- /dev/null +++ b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/Table.pm @@ -0,0 +1,471 @@ +package DBIx::DBSchema::Table; + +use strict; +use vars qw(@ISA %create_params); +#use Carp; +#use Exporter; +use DBIx::DBSchema::Column 0.02; +use DBIx::DBSchema::ColGroup::Unique; +use DBIx::DBSchema::ColGroup::Index; + +#@ISA = qw(Exporter); +@ISA = qw(); + +=head1 NAME + +DBIx::DBSchema::Table - Table objects + +=head1 SYNOPSIS + + use DBIx::DBSchema::Table; + + #old style (depriciated) + $table = new DBIx::DBSchema::Table ( + "table_name", + "primary_key", + $dbix_dbschema_colgroup_unique_object, + $dbix_dbschema_colgroup_index_object, + @dbix_dbschema_column_objects, + ); + + #new style (preferred), pass a hashref of parameters + $table = new DBIx::DBSchema::Table ( + { + name => "table_name", + primary_key => "primary_key", + unique => $dbix_dbschema_colgroup_unique_object, + 'index' => $dbix_dbschema_colgroup_index_object, + columns => \@dbix_dbschema_column_objects, + } + ); + + $table->addcolumn ( $dbix_dbschema_column_object ); + + $table_name = $table->name; + $table->name("table_name"); + + $primary_key = $table->primary_key; + $table->primary_key("primary_key"); + + $dbix_dbschema_colgroup_unique_object = $table->unique; + $table->unique( $dbix_dbschema__colgroup_unique_object ); + + $dbix_dbschema_colgroup_index_object = $table->index; + $table->index( $dbix_dbschema_colgroup_index_object ); + + @column_names = $table->columns; + + $dbix_dbschema_column_object = $table->column("column"); + + #preferred + @sql_statements = $table->sql_create_table( $dbh ); + @sql_statements = $table->sql_create_table( $datasrc, $username, $password ); + + #possible problems + @sql_statements = $table->sql_create_table( $datasrc ); + @sql_statements = $table->sql_create_table; + +=head1 DESCRIPTION + +DBIx::DBSchema::Table objects represent a single database table. + +=head1 METHODS + +=over 4 + +=item new [ TABLE_NAME [ , PRIMARY_KEY [ , UNIQUE [ , INDEX [ , COLUMN... ] ] ] ] ] + +=item new HASHREF + +Creates a new DBIx::DBSchema::Table object. The preferred usage is to pass a +hash reference of named parameters. + + { + name => TABLE_NAME, + primary_key => PRIMARY_KEY, + unique => UNIQUE, + 'index' => INDEX, + columns => COLUMNS + } + +TABLE_NAME is the name of the table. PRIMARY_KEY is the primary key (may be +empty). UNIQUE is a DBIx::DBSchema::ColGroup::Unique object (see +L<DBIx::DBSchema::ColGroup::Unique>). INDEX is a +DBIx::DBSchema::ColGroup::Index object (see +L<DBIx::DBSchema::ColGroup::Index>). COLUMNS is a reference to an array of +DBIx::DBSchema::Column objects (see L<DBIx::DBSchema::Column>). + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + + my $self; + if ( ref($_[0]) ) { + + $self = shift; + $self->{column_order} = [ map { $_->name } @{$self->{columns}} ]; + $self->{columns} = { map { $_->name, $_ } @{$self->{columns}} }; + + } else { + + my($name,$primary_key,$unique,$index,@columns) = @_; + + my %columns = map { $_->name, $_ } @columns; + my @column_order = map { $_->name } @columns; + + $self = { + 'name' => $name, + 'primary_key' => $primary_key, + 'unique' => $unique, + 'index' => $index, + 'columns' => \%columns, + 'column_order' => \@column_order, + }; + + } + + #check $primary_key, $unique and $index to make sure they are $columns ? + # (and sanity check?) + + bless ($self, $class); + +} + +=item new_odbc DATABASE_HANDLE TABLE_NAME + +Creates a new DBIx::DBSchema::Table object from the supplied DBI database +handle for the specified table. This uses the experimental DBI type_info +method to create a table with standard (ODBC) SQL column types that most +closely correspond to any non-portable column types. Use this to import a +schema that you wish to use with many different database engines. Although +primary key and (unique) index information will only be imported from databases +with DBIx::DBSchema::DBD drivers (currently MySQL and PostgreSQL), import of +column names and attributes *should* work for any database. + +Note: the _odbc refers to the column types used and nothing else - you do not +have to have ODBC installed or connect to the database via ODBC. + +=cut + +%create_params = ( +# undef => sub { '' }, + '' => sub { '' }, + 'max length' => sub { $_[0]->{PRECISION}->[$_[1]]; }, + 'precision,scale' => + sub { $_[0]->{PRECISION}->[$_[1]]. ','. $_[0]->{SCALE}->[$_[1]]; } +); + +sub new_odbc { + my( $proto, $dbh, $name) = @_; + my $driver = DBIx::DBSchema::_load_driver($dbh); + my $sth = _null_sth($dbh, $name); + my $sthpos = 0; + $proto->new ( + $name, + scalar(eval "DBIx::DBSchema::DBD::$driver->primary_key(\$dbh, \$name)"), + DBIx::DBSchema::ColGroup::Unique->new( + $driver + ? [values %{eval "DBIx::DBSchema::DBD::$driver->unique(\$dbh, \$name)"}] + : [] + ), + DBIx::DBSchema::ColGroup::Index->new( + $driver + ? [ values %{eval "DBIx::DBSchema::DBD::$driver->index(\$dbh, \$name)"} ] + : [] + ), + map { + my $type_info = scalar($dbh->type_info($sth->{TYPE}->[$sthpos])) + or die "DBI::type_info ". $dbh->{Driver}->{Name}. " driver ". + "returned no results for type ". $sth->{TYPE}->[$sthpos]; + new DBIx::DBSchema::Column + $_, + $type_info->{'TYPE_NAME'}, + #"SQL_". uc($type_info->{'TYPE_NAME'}), + $sth->{NULLABLE}->[$sthpos], + &{ $create_params{ $type_info->{CREATE_PARAMS} } }( $sth, $sthpos++ ), $driver && #default + ${ [ + eval "DBIx::DBSchema::DBD::$driver->column(\$dbh, \$name, \$_)" + ] }[4] + # DB-local + } @{$sth->{NAME}} + ); +} + +=item new_native DATABASE_HANDLE TABLE_NAME + +Creates a new DBIx::DBSchema::Table object from the supplied DBI database +handle for the specified table. This uses database-native methods to read the +schema, and will preserve any non-portable column types. The method is only +available if there is a DBIx::DBSchema::DBD for the corresponding database +engine (currently, MySQL and PostgreSQL). + +=cut + +sub new_native { + my( $proto, $dbh, $name) = @_; + my $driver = DBIx::DBSchema::_load_driver($dbh); + $proto->new ( + $name, + scalar(eval "DBIx::DBSchema::DBD::$driver->primary_key(\$dbh, \$name)"), + DBIx::DBSchema::ColGroup::Unique->new( + [ values %{eval "DBIx::DBSchema::DBD::$driver->unique(\$dbh, \$name)"} ] + ), + DBIx::DBSchema::ColGroup::Index->new( + [ values %{eval "DBIx::DBSchema::DBD::$driver->index(\$dbh, \$name)"} ] + ), + map { + DBIx::DBSchema::Column->new( @{$_} ) + } eval "DBIx::DBSchema::DBD::$driver->columns(\$dbh, \$name)" + ); +} + +=item addcolumn COLUMN + +Adds this DBIx::DBSchema::Column object. + +=cut + +sub addcolumn { + my($self,$column)=@_; + ${$self->{'columns'}}{$column->name}=$column; #sanity check? + push @{$self->{'column_order'}}, $column->name; +} + +=item delcolumn COLUMN_NAME + +Deletes this column. Returns false if no column of this name was found to +remove, true otherwise. + +=cut + +sub delcolumn { + my($self,$column) = @_; + return 0 unless exists $self->{'columns'}{$column}; + delete $self->{'columns'}{$column}; + @{$self->{'column_order'}}= grep { $_ ne $column } @{$self->{'column_order'}}; 1; +} + +=item name [ TABLE_NAME ] + +Returns or sets the table name. + +=cut + +sub name { + my($self,$value)=@_; + if ( defined($value) ) { + $self->{name} = $value; + } else { + $self->{name}; + } +} + +=item primary_key [ PRIMARY_KEY ] + +Returns or sets the primary key. + +=cut + +sub primary_key { + my($self,$value)=@_; + if ( defined($value) ) { + $self->{primary_key} = $value; + } else { + #$self->{primary_key}; + #hmm. maybe should untaint the entire structure when it comes off disk + # cause if you don't trust that, ? + $self->{primary_key} =~ /^(\w*)$/ + #aah! + or die "Illegal primary key: ", $self->{primary_key}; + $1; + } +} + +=item unique [ UNIQUE ] + +Returns or sets the DBIx::DBSchema::ColGroup::Unique object. + +=cut + +sub unique { + my($self,$value)=@_; + if ( defined($value) ) { + $self->{unique} = $value; + } else { + $self->{unique}; + } +} + +=item index [ INDEX ] + +Returns or sets the DBIx::DBSchema::ColGroup::Index object. + +=cut + +sub index { + my($self,$value)=@_; + if ( defined($value) ) { + $self->{'index'} = $value; + } else { + $self->{'index'}; + } +} + +=item columns + +Returns a list consisting of the names of all columns. + +=cut + +sub columns { + my($self)=@_; + #keys %{$self->{'columns'}}; + #must preserve order + @{ $self->{'column_order'} }; +} + +=item column COLUMN_NAME + +Returns the column object (see L<DBIx::DBSchema::Column>) for the specified +COLUMN_NAME. + +=cut + +sub column { + my($self,$column)=@_; + $self->{'columns'}->{$column}; +} + +=item sql_create_table [ DATABASE_HANDLE | DATA_SOURCE [ USERNAME PASSWORD [ ATTR ] ] ] + +Returns a list of SQL statments to create this table. + +The data source can be specified by passing an open DBI database handle, or by +passing the DBI data source name, username and password. + +Although the username and password are optional, it is best to call this method +with a database handle or data source including a valid username and password - +a DBI connection will be opened and the quoting and type mapping will be more +reliable. + +If passed a DBI data source (or handle) such as `DBI:mysql:database', will use +MySQL- or PostgreSQL-specific syntax. Non-standard syntax for other engines +(if applicable) may also be supported in the future. + +=cut + +sub sql_create_table { + my($self, $dbh) = (shift, shift); + + my $created_dbh = 0; + unless ( ref($dbh) || ! @_ ) { + $dbh = DBI->connect( $dbh, @_ ) or die $DBI::errstr; + my $gratuitous = $DBI::errstr; #surpress superfluous `used only once' error + $created_dbh = 1; + } + #false laziness: nicked from DBSchema::_load_driver + my $driver; + if ( ref($dbh) ) { + $driver = $dbh->{Driver}->{Name}; + } else { + my $discard = $dbh; + $discard =~ s/^dbi:(\w*?)(?:\((.*?)\))?://i #nicked from DBI->connect + or '' =~ /()/; # ensure $1 etc are empty if match fails + $driver = $1 or die "can't parse data source: $dbh"; + } + #eofalse + +#should be in the DBD somehwere :/ +# my $saved_pkey = ''; +# if ( $driver eq 'Pg' && $self->primary_key ) { +# my $pcolumn = $self->column( ( +# grep { $self->column($_)->name eq $self->primary_key } $self->columns +# )[0] ); +##AUTO-INCREMENT# $pcolumn->type('serial') if lc($pcolumn->type) eq 'integer'; +# $pcolumn->local( $pcolumn->local. ' PRIMARY KEY' ); +# #my $saved_pkey = $self->primary_key; +# #$self->primary_key(''); +# #change it back afterwords :/ +# } + + my @columns = map { $self->column($_)->line($dbh) } $self->columns; + + push @columns, "PRIMARY KEY (". $self->primary_key. ")" + #if $self->primary_key && $driver ne 'Pg'; + if $self->primary_key; + + my $indexnum = 1; + + my @r = ( + "CREATE TABLE ". $self->name. " (\n ". join(",\n ", @columns). "\n)\n" + ); + + push @r, map { + #my($index) = $self->name. "__". $_ . "_idx"; + #$index =~ s/,\s*/_/g; + my $index = $self->name. $indexnum++; + "CREATE UNIQUE INDEX $index ON ". $self->name. " ($_)\n" + } $self->unique->sql_list + if $self->unique; + + push @r, map { + #my($index) = $self->name. "__". $_ . "_idx"; + #$index =~ s/,\s*/_/g; + my $index = $self->name. $indexnum++; + "CREATE INDEX $index ON ". $self->name. " ($_)\n" + } $self->index->sql_list + if $self->index; + + #$self->primary_key($saved_pkey) if $saved_pkey; + $dbh->disconnect if $created_dbh; + @r; +} + +# + +sub _null_sth { + my($dbh, $table) = @_; + my $sth = $dbh->prepare("SELECT * FROM $table WHERE 1=0") + or die $dbh->errstr; + $sth->execute or die $sth->errstr; + $sth; +} + +=back + +=head1 AUTHOR + +Ivan Kohler <ivan-dbix-dbschema@420.am> + +Thanks to Mark Ethan Trostler <mark@zzo.com> for a patch to allow tables +with no indices. + +=head1 COPYRIGHT + +Copyright (c) 2000 Ivan Kohler +Copyright (c) 2000 Mail Abuse Prevention System LLC +All rights reserved. +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=head1 BUGS + +sql_create_table() has database-specific foo that probably ought to be +abstracted into the DBIx::DBSchema::DBD:: modules. + +sql_create_table may change or destroy the object's data. If you need to use +the object after sql_create_table, make a copy beforehand. + +Some of the logic in new_odbc might be better abstracted into Column.pm etc. + +=head1 SEE ALSO + +L<DBIx::DBSchema>, L<DBIx::DBSchema::ColGroup::Unique>, +L<DBIx::DBSchema::ColGroup::Index>, L<DBIx::DBSchema::Column>, L<DBI> + +=cut + +1; + diff --git a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/MANIFEST b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/MANIFEST new file mode 100644 index 0000000..b04de25 --- /dev/null +++ b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/MANIFEST @@ -0,0 +1,19 @@ +Changes +MANIFEST +MANIFEST.SKIP +README +TODO +Makefile.PL +DBSchema.pm +t/load.t +t/load-mysql.t +t/load-pg.t +DBSchema/Table.pm +DBSchema/ColGroup.pm +DBSchema/ColGroup/Index.pm +DBSchema/ColGroup/Unique.pm +DBSchema/Column.pm +DBSchema/DBD.pm +DBSchema/DBD/mysql.pm +DBSchema/DBD/Pg.pm +DBSchema/DBD/Sybase.pm diff --git a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/MANIFEST.SKIP b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/MANIFEST.SKIP new file mode 100644 index 0000000..ae335e7 --- /dev/null +++ b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/MANIFEST.SKIP @@ -0,0 +1 @@ +CVS/ diff --git a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/Makefile.PL b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/Makefile.PL new file mode 100644 index 0000000..a10e4da --- /dev/null +++ b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/Makefile.PL @@ -0,0 +1,11 @@ +use ExtUtils::MakeMaker; +# See lib/ExtUtils/MakeMaker.pm for details of how to influence +# the contents of the Makefile that is written. +WriteMakefile( + 'NAME' => 'DBIx::DBSchema', + 'VERSION_FROM' => 'DBSchema.pm', # finds $VERSION + 'PREREQ_PM' => { + 'DBI' => 0, + 'FreezeThaw' => 0, + }, +); diff --git a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/README b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/README new file mode 100644 index 0000000..8911ea4 --- /dev/null +++ b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/README @@ -0,0 +1,42 @@ +DBIx::DBSchema + +Copyright (c) 2000-2002 Ivan Kohler +Copyright (c) 2000 Mail Abuse Prevention System LLC +All rights reserved. +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +This module implements an OO-interface to database schemas. Using this module, +you can create a database schema with an OO Perl interface. You can read the +schema from an existing database. You can save the schema to disk and restore +it from different process. Most importantly, DBIx::DBSchema can write SQL +CREATE statements for different databases from a single source. + +Currently supported databases are MySQL, PostgreSQL and Sybase. +DBIx::DBSchema will attempt to use generic SQL syntax for other databases. +Assistance adding support for other databases is welcomed. See the +DBIx::DBSchema::DBD manpage, "Driver Writer's Guide and Base Class". + +To install: + perl Makefile.PL + make + make test # nothing substantial yet + make install + +Documentation will then be available via `man DBIx::DBSchema' or +`perldoc DBIx::DBSchema'. + +Anonymous CVS access is available: + $ export CVSROOT=":pserver:anonymous@cleanwhisker.420.am:/home/cvs/cvsroot" + $ cvs login + (Logging in to anonymous@cleanwhisker.420.am) + CVS password: anonymous + $ cvs checkout DBIx-DBSchema +as well as <http://www.420.am/cgi-bin/cvsweb/DBIx-DBSchema>. + +A mailing list is available. Send a blank message to +<ivan-dbix-dbschema-users-subscribe@420.am>. + +Homepage: <http://www.420.am/dbix-dbschema> + +$Id: README,v 1.1 2004-04-29 09:21:27 ivan Exp $ diff --git a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/TODO b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/TODO new file mode 100644 index 0000000..e75850b --- /dev/null +++ b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/TODO @@ -0,0 +1,6 @@ +port and test with additional databases + +sql CREATE TABLE output should convert integers +(i.e. use DBI qw(:sql_types);) to local types using DBI->type_info plus a hash +to fudge things + diff --git a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/t/load-mysql.t b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/t/load-mysql.t new file mode 100644 index 0000000..78818c1 --- /dev/null +++ b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/t/load-mysql.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n"; } +END {print "not ok 1\n" unless $loaded;} +use DBIx::DBSchema::DBD::mysql; +$loaded = 1; +print "ok 1\n"; diff --git a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/t/load-pg.t b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/t/load-pg.t new file mode 100644 index 0000000..93fcf4a --- /dev/null +++ b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/t/load-pg.t @@ -0,0 +1,12 @@ +print "1..1\n"; +eval "use DBD::Pg 1.32"; +if ( length($@) ) { + print "ok 1 # Skipped: DBD::Pg 1.32 required for Pg"; +} else { + eval "use DBIx::DBSchema::DBD::Pg;"; + if ( length($@) ) { + print "not ok 1\n"; + } else { + print "ok 1\n"; + } +} diff --git a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/t/load.t b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/t/load.t new file mode 100644 index 0000000..67ea44b --- /dev/null +++ b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/t/load.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n"; } +END {print "not ok 1\n" unless $loaded;} +use DBIx::DBSchema; +$loaded = 1; +print "ok 1\n"; diff --git a/install/debian/3.0/INSTALL b/install/debian/3.0/INSTALL new file mode 100644 index 0000000..019d515 --- /dev/null +++ b/install/debian/3.0/INSTALL @@ -0,0 +1,33 @@ +#!/bin/sh + +echo "deb http://pouncequick.420.am/~ivan/freeside-woody/ ./" >>/etc/apt/sources.list + +apt-get update +apt-get install screen zsh libapache-mod-ssl libapache-mod-perl rsync \ + postgresql cvs fsh \ + liburi-perl libhtml-tagset-perl libnet-perl liblocale-codes-perl \ + libnet-whois-perl libwww-perl libbusiness-creditcard-perl \ + libmailtools-perl libtimedate-perl libdate-manip-perl \ + libfile-counterfile-perl libfreezethaw-perl libstring-approx-perl \ + libtext-template-perl libdbi-perl libdbd-pg-perl \ + libdbix-datasource-perl libdbix-dbschema-perl libnet-ssh-perl \ + libstring-shellquote-perl libnet-scp-perl libapache-asp-perl \ + libtie-ixhash-perl libtime-duration-perl \ + libhtml-widgets-selectlayers-perl libstorable-perl \ + libapache-dbi-perl libcache-cache-perl libdbd-mysql-perl \ + libcrypt-passwdmd5-perl libnetaddr-ip-perl libfile-temp-perl \ + libnet-whois-raw-perl libchart-perl + +useradd freeside +su postgres -c "createuser -P freeside" + +su freeside -c "createdb freeside" + +#? +cd ../../.. +make install-perl-modules +make create-config +freeside-adduser -c -h /usr/local/etc/freeside/htpasswd ivan +su freeside -c 'freeside-setup ivan' +su freeside -c '/home/ivan/freeside/bin/populate-msgcat ivan' +make deploy diff --git a/install/fedora/fc1/INSTALL b/install/fedora/fc1/INSTALL new file mode 100755 index 0000000..c347609 --- /dev/null +++ b/install/fedora/fc1/INSTALL @@ -0,0 +1,66 @@ +#!/bin/sh + +wget --passive-ftp --continue http://download.fedora.us/fedora/fedora/1/i386/RPMS.stable/apt-0.5.15cnc5-0.fdr.10.1.i386.rpm +rpm -i apt*i386.rpm + +cp sources.list /etc/apt/sources.list + +apt-get update + +apt-get install perl-Devel-Symdump perl-BSD-Resource + +wget --passive-ftp --continue http://linux.reb00t.com/fedora-current/RPMS/apache-1.3.29-1.n0i.2.MPSSL.i686.rpm http://linux.reb00t.com/fedora-current/RPMS/mm-1.3.0-0.n0i.2.i686.rpm http://mirrors.kernel.org/fedora.us/fedora/fedora/1.91/i386/RPMS.os/db4-4.2.52-3.1.i386.rpm + +apt-get remove httpd mod_perl + +rpm -i mm-1.3.0-0.n0i.2.i686.rpm db4-4.2.52-3.1.i386.rpm apache-1.3.29-1.n0i.2.MPSSL.i686.rpm + +/sbin/chkconfig httpd on + +#edit /etc/httpd/conf/httpd.conf, remove mod_auth_db LoadMoudle and AddModule + +echo 'OPTIONS="-DHAVE_PERL -DHAVE_SSL"' >>/etc/sysconfig/apache + +/etc/init.d/httpd start + +echo 'RPM::Allow-Duplicated { "^db4$"; };' >>/etc/apt/apt.conf + +wget --continue http://atrpms.physik.fu-berlin.de/RPM-GPG-KEY.atrpms +rpm --import RPM-GPG-KEY.atrpms +wget --continue http://dag.wieers.com/packages/RPM-GPG-KEY.dag.txt +rpm --import RPM-GPG-KEY.dag.txt + +apt-get install perl-DBD-MySQL perl-DBI perl-DateManip perl-HTML-Parser perl-HTML-Tagset perl-TimeDate perl-URI perl-libwww-perl perl-suidperl rsync postgresql postgresql-docs postgresql-libs postgresql-server postgresql-devel screen zsh lftp cvs gcc gd perl-GD perl-MailTools perl-FreezeThaw perl-NetAddr-IP perl-Chart + +perl -MCPAN -e"install Net::Whois::Raw, Business::CreditCard, \ + File::CounterFile, String::Approx, Text::Template, \ + DBIx::DataSource, DBIx::DBSchema, Net::SSH, \ + String::ShellQuote, Net::SCP, Apache::ASP, \ + Tie::IxHash, Time::Duration, \ + HTML::Widgets::SelectLayers, Apache::DBI, \ + Cache::Cache, IPC::ShareLite, Locale::SubCountry, \ + DBD::Pg, Crypt::PasswdMD5 " + + +#remove perl & ssl LoadModule lines from /etc/httpd/conf/httpd.conf +#as they're statically linked (?) + +/usr/sbin/useradd freeside +chsh freeside -s /bin/bash + +/sbin/chkconfig postgresql on +/etc/init.d/postgresql start + +echo -e '\n\ny\nn" | su postgres -c "createuser -P freeside" + +su freeside -c "createdb freeside" + +#? +cd ../../.. +make install-perl-modules +make create-config +freeside-adduser -c -h /usr/local/etc/freeside/htpasswd ivan +su freeside -c 'freeside-setup ivan' +su freeside -c '/home/ivan/freeside/bin/populate-msgcat ivan' +make deploy + diff --git a/install/fedora/fc1/sources.list b/install/fedora/fc1/sources.list new file mode 100644 index 0000000..9b36242 --- /dev/null +++ b/install/fedora/fc1/sources.list @@ -0,0 +1,12 @@ +# Fedora Core (Kernel.org, San Francisco California, USA) +rpm http://mirrors.kernel.org/fedora.us/fedora fedora/1/i386 os updates +rpm-src http://mirrors.kernel.org/fedora.us/fedora fedora/1/i386 os updates + +# Fedora Extras (Kernel.org, San Francisco California, USA) +rpm http://mirrors.kernel.org/fedora.us/fedora fedora/1/i386 stable +rpm-src http://mirrors.kernel.org/fedora.us/fedora fedora/1/i386 stable + +### Dag Apt Repository for Red Hat Fedora Core 1 (rhfc1) +rpm http://apt.sw.be redhat/fc1/en/i386 dag + +rpm http://apt.physik.fu-berlin.de redhat/9/en/i386 at-testing diff --git a/install/fedora/fc2/INSTALL b/install/fedora/fc2/INSTALL new file mode 100755 index 0000000..d6c0a4f --- /dev/null +++ b/install/fedora/fc2/INSTALL @@ -0,0 +1,63 @@ +#!/bin/sh + +wget --passive-ftp --continue http://download.fedora.us/fedora/fedora/2/i386/RPMS.stable/apt-0.5.15cnc6-0.fdr.11.2.i386.rpm +rpm -i apt*i386.rpm + +wget --continue http://atrpms.physik.fu-berlin.de/RPM-GPG-KEY.atrpms +rpm --import RPM-GPG-KEY.atrpms +wget --continue http://dag.wieers.com/packages/RPM-GPG-KEY.dag.txt +rpm --import RPM-GPG-KEY.dag.txt + +#echo 'RPM::Allow-Duplicated { "^db4$"; };' >>/etc/apt/apt.conf + +#might need to uncomment +# GPG-Check "false"; +#in /etc/apt/apt.conf + +apt-get update +cp sources.list /etc/apt/sources.list +rm /etc/apt/sources.list.d/mirror-select.list +apt-get update + +apt-get remove httpd mod_perl + +apt-get install perl-Devel-Symdump perl-BSD-Resource perl-DBD-MySQL perl-DBI perl-DateManip perl-HTML-Parser perl-HTML-Tagset perl-TimeDate perl-URI perl-libwww-perl perl-suidperl rsync postgresql postgresql-docs postgresql-libs postgresql-server postgresql-devel screen zsh lftp cvs gcc gd perl-GD perl-MailTools perl-FreezeThaw perl-NetAddr-IP perl-Chart perl-Text-Template perl-Cache-Cache + +#for rt +#apt-get install perl-Apache-Session perl-MIME-tools perl-TermReadKey perl-MLDBM perl-MLDBM-Sync + +perl -MCPAN -e"install Net::Whois::Raw, Business::CreditCard, \ + File::CounterFile, String::Approx, Text::Template, \ + DBIx::DataSource, DBIx::DBSchema, Net::SSH, \ + String::ShellQuote, Net::SCP, HTML::Mason, \ + Tie::IxHash, Time::Duration, \ + HTML::Widgets::SelectLayers, Apache::DBI, \ + Locale::SubCountry, \ + DBD::Pg, Crypt::PasswdMD5 " + + +#apachetoolbox +#lftpget http://umn.dl.sourceforge.net/sourceforge/apachetoolbox/Apachetoolbox-install-1.5.72.tar.gz +#apache config +#apache init script + +/usr/sbin/useradd freeside +chsh freeside -s /bin/bash + +/sbin/chkconfig postgresql on +/etc/init.d/postgresql start + +echo -e '\n\ny\nn' | su postgres -c "createuser -P freeside" + +su freeside -c "createdb freeside" + +#? +cd ../../.. +make install-perl-modules +make create-config +ln -s /usr/local/apache/bin/htpasswd /usr/local/bin/ +freeside-adduser -c -h /usr/local/etc/freeside/htpasswd ivan +su freeside -c 'freeside-setup ivan' +su freeside -c '/home/ivan/freeside/bin/populate-msgcat ivan' +make deploy + diff --git a/install/fedora/fc2/sources.list b/install/fedora/fc2/sources.list new file mode 100644 index 0000000..038db1e --- /dev/null +++ b/install/fedora/fc2/sources.list @@ -0,0 +1,12 @@ +# Fedora Core (Kernel.org, San Francisco California, USA) +rpm http://mirrors.kernel.org/fedora.us/fedora fedora/2/i386 os updates +rpm-src http://mirrors.kernel.org/fedora.us/fedora fedora/2/i386 os updates + +# Fedora Extras (Kernel.org, San Francisco California, USA) +rpm http://mirrors.kernel.org/fedora.us/fedora fedora/2/i386 stable +rpm-src http://mirrors.kernel.org/fedora.us/fedora fedora/2/i386 stable + +### Dag Apt Repository for Red Hat Fedora Core 2 (rhfc2) +rpm http://apt.sw.be redhat/fc2/en/i386 dag + +rpm http://apt.physik.fu-berlin.de fedora/2/en/i386 at-testing diff --git a/install/freebsd/INSTALL b/install/freebsd/INSTALL new file mode 100755 index 0000000..53fc613 --- /dev/null +++ b/install/freebsd/INSTALL @@ -0,0 +1,40 @@ +#!/bin/sh + +( cd /usr/ports/sysutils/portupgrade + make install +) + +pkgdb -u + +portinstall -PR cvsup-without-gui + +cp /usr/share/examples/cvsup/ports-supfile /root +perl -pi -e 's/CHANGE_THIS/cvsup1/;' /root/ports-supfile +cvsup /root/ports-supfile + +for port in `grep -v '^ *#' ports`; do + #cd /usr/ports/$port + #make install || exit + portinstall -P -R $port || exit +done + +for a in Net::SSH DBIx::DBSchema HTML::Widgets::SelectLayers Time::Duration Business::CreditCard; do perl -MCPAN -e"install $a"; done + +su -l pgsql -c initdb + +/usr/local/etc/rc.d/010.pgsql.sh start + +pw user add freeside -m + +su -l pgsql -c 'createuser -P freeside' + +su -l freeside -c 'createdb freeside' + +#? +cd ../.. +make install-perl-modules +make create-config +make deploy + +#edit apache config, etc. + diff --git a/install/freebsd/ports b/install/freebsd/ports new file mode 100644 index 0000000..019c5e1 --- /dev/null +++ b/install/freebsd/ports @@ -0,0 +1,44 @@ +shells/zsh +misc/screen +ftp/lftp +www/apache13-modssl +www/mod_perl +net/rsync +databases/postgresql7 +misc/p5-Array-PrintCols +devel/p5-Term-Query +converters/p5-MIME-Base64 +security/p5-Digest-MD5 +security/p5-MD5 +net/p5-URI +www/p5-HTML-Tagset +www/p5-HTML-Parser +net/p5-Net +misc/p5-Locale-Codes +net/p5-Net-Whois +www/p5-libwww + #misc/p5-Business-CreditCard +devel/p5-Data-ShowTable +mail/p5-Mail-Tools +devel/p5-TimeDate +devel/p5-Date-Manip +misc/p5-File-CounterFile +devel/p5-FreezeThaw +devel/p5-String-Approx +textproc/p5-Text-Template +databases/p5-DBI +databases/p5-DBD-Pg +#databases/p5-DBD-mysql +databases/p5-DBIx-DataSource + #database/p5-DBIx-DBSchema + #net/p5-Net-SSH +textproc/p5-String-ShellQuote +net/p5-Net-SCP +www/p5-Apache-ASP + #www/p5-HTML-Mason +devel/p5-Tie-IxHash + #devel/p5-Time-Duration + #www/p5-HTML-Widgets-SelectLayers +devel/p5-Storable +www/p5-Apache-DBI +devel/p5-Cache-Cache diff --git a/install/openbsd/INSTALL b/install/openbsd/INSTALL new file mode 100644 index 0000000..1beef92 --- /dev/null +++ b/install/openbsd/INSTALL @@ -0,0 +1,54 @@ +#!/bin/sh + +DIR=`pwd` + +#cd /usr/ports +#cvs -q -d anoncvs@anoncvs6.usa.openbsd.org:/cvs up -r OPENBSD_`uname -r | perl -pe 's/\./_/g;'` -Pd + +for a in `grep -v '^ *#' $DIR/ports` +do cd /usr/ports/$a + make install +done + +for a in `grep -v '^ *#' $DIR/cpan` +do perl -MCPAN -e "install $a" +done + +#from /usr/local/share/doc/postgresql/README.OpenBSD +useradd -c "PostgreSQL Admin User" -g =uid -m -d /var/postgresql -s /bin/sh postgresql + +su -l postgresql -c 'mkdir /var/postgresql/data' +su -l postgresql -c 'initdb -D /var/postgresql/data' + +cat <<END >>/etc/rc.local +if [ -x /usr/local/bin/pg_ctl ]; then + su -l postgresql -c "/usr/local/bin/pg_ctl start \ + -D /var/postgresql/data -l /var/postgresql/logfile \ + -o '-D /var/postgresql/data'" + echo -n ' postgresql' +fi +END + +cat <<END >>/etc/rc.shutdown +if [ -f /var/postgresql/data/postmaster.pid ]; then + su -l postgresql -c "/usr/local/bin/pg_ctl stop -m fast \ + -D /var/postgresql/data" + rm -f /var/postgresql/data/postmaster.pid +fi + +su -l postgresql -c "/usr/local/bin/pg_ctl start \ + -D /var/postgresql/data -l /var/postgresql/logfile \ + -o '-D /var/postgresql/data'" + +useradd -c "Freeside" -g =uid -m freeside +su -l postgresql -c 'createuser -P freeside' +su -l freeside -c 'createdb freeside' + +#? +cd ../.. +make install-perl-modules +make create-config +make deploy + +#edit apache config, etc. + diff --git a/install/openbsd/cpan b/install/openbsd/cpan new file mode 100644 index 0000000..4304b72 --- /dev/null +++ b/install/openbsd/cpan @@ -0,0 +1,15 @@ +DBIx::DBSchema +Time::Duration +Business::CreditCard +String::ShellQuote +Net::SSH +HTML::Mason +HTML::Widgets::SelectLayers +DBIx::DataSource +Date::Manip +String::Approx +Tie::IxHash +Date::Parse +File::CounterFile +Net::SCP +Mail::Internet diff --git a/install/openbsd/ports b/install/openbsd/ports new file mode 100644 index 0000000..3e17d82 --- /dev/null +++ b/install/openbsd/ports @@ -0,0 +1,24 @@ +shells/zsh +misc/screen +#www/apache13-modssl +www/mod_perl +net/rsync +databases/postgresql +converters/p5-MIME-Base64 +security/p5-Digest-MD5 +security/p5-MD5 +www/p5-HTML-Tagset +www/p5-HTML-Parser +net/p5-libnet +misc/p5-Locale-Codes +net/p5-Net-Whois +www/p5-libwww +#mail/p5-Mail-Tools +devel/p5-FreezeThaw +textproc/p5-Text-Template +databases/p5-DBI +databases/p5-DBD-Pg +#databases/p5-DBD-Msql-Mysql +www/p5-Apache-ASP +devel/p5-Storable +www/p5-Apache-DBI diff --git a/install/redhat/7.3/INSTALL b/install/redhat/7.3/INSTALL new file mode 100644 index 0000000..d2f60cb --- /dev/null +++ b/install/redhat/7.3/INSTALL @@ -0,0 +1,40 @@ +#!/bin/sh + +wget --passive-ftp ftp://apt-rpm.tuxfamily.org/apt/redhat/7.3/en/i386/RPMS.extra/apt-*i386.rpm +rpm -i apt*i386.rpm +cp sources.list /etc/apt/ +apt-get update; apt-get update +apt-get install apache mod_ssl mod_perl perl-CGI perl-CPAN perl-DBD-MySQL perl-DBD-Pg perl-DBI perl-DateManip perl-Digest-MD5 perl-HTML-Parser perl-HTML-Tagset perl-MIME-Base64 perl-Storable perl-TimeDate perl-URI perl-libnet perl-libwww-perl perl-suidperl rsync postgresql postgresql-docs postgresql-libs postgresql-server screen zsh lftp cvs #openssh + +wget --passive-ftp --continue http://download.atrpms.net/production/packages/redhat-7.3-i386/atrpms/atrpms-51-1.rh7.3.at.noarch.rpm http://download.atrpms.net/production/packages/redhat-7.3-i386/atrpms/atrpms-package-config-51-1.rh7.3.at.noarch.rpm http://download.atrpms.net/production/packages/redhat-7.3-i386/atrpms/gd-2.0.15-1_6.rh7.3.at.i386.rpm http://download.atrpms.net/production/packages/redhat-7.3-i386/atrpms/gd-devel-2.0.15-1_6.rh7.3.at.i386.rpm http://download.atrpms.net/production/packages/redhat-7.3-i386/atrpms/perl-GD-2.11-7.rh7.3.at.i386.rpm + +#rpm -i atrpms-package-config-51-1.rh7.3.at.noarch.rpm +rpm -i atrpms-51-1.rh7.3.at.noarch.rpm +rpm -i gd-2.0.15-1_6.rh7.3.at.i386.rpm +rpm -i perl-GD-2.11-7.rh7.3.at.i386.rpm + +perl -MCPAN -e"install Locale::Country, Net::Whois, Business::CreditCard, \ + Mail::Internet, File::CounterFile, FreezeThaw, \ + String::Approx, Text::Template, DBIx::DataSource, \ + DBIx::DBSchema, Net::SSH, String::ShellQuote, \ + Net::SCP, Apache::ASP, Tie::IxHash, Time::Duration, \ + HTML::Widgets::SelectLayers, Apache::DBI, Cache::Cache" + +useradd freeside + +chkconfig postgresql on +/etc/init.d/postgresql start + +su postgres -c "createuser -P freeside" + +su freeside -c "createdb freeside" + +#? +cd ../.. +make install-perl-modules +make create-config +freeside-adduser -c -h /usr/local/etc/freeside/htpasswd ivan +su freeside -c 'freeside-setup ivan' +su freeside -c '/home/ivan/freeside/bin/populate-msgcat ivan' +make deploy + diff --git a/install/redhat/7.3/sources.list b/install/redhat/7.3/sources.list new file mode 100644 index 0000000..9a9ad5c --- /dev/null +++ b/install/redhat/7.3/sources.list @@ -0,0 +1,2 @@ +rpm ftp://apt-rpm.tuxfamily.org/apt redhat/7.3/en/i386 os updates extra +rpm-src ftp://apt-rpm.tuxfamily.org/apt redhat/7.3/en/i386 os updates extra diff --git a/install/redhat/8/INSTALL b/install/redhat/8/INSTALL new file mode 100755 index 0000000..e6107d9 --- /dev/null +++ b/install/redhat/8/INSTALL @@ -0,0 +1,47 @@ +#!/bin/sh + +rpm -Fvh http://redhat.usu.edu/mirrors/apt4rpm/apt-0.5.4cnc8-fr1.i386.rpm + +cp sources.list /etc/apt/ +apt-get update; apt-get update +#apt-get install apache mod_ssl mod_perl perl-CGI perl-CPAN perl-DBD-MySQL perl-DBD-Pg perl-DBI perl-DateManip perl-Digest-MD5 perl-HTML-Parser perl-HTML-Tagset perl-MIME-Base64 perl-Storable perl-TimeDate perl-URI perl-libnet perl-libwww-perl perl-suidperl rsync postgresql postgresql-docs postgresql-libs postgresql-server screen zsh lftp cvs #openssh + +#ftp://ftp.pbone.net/mirror/www.aucs.org/rpmcenter/packages/apache13-php43-mods-rh8 + +apt-get install perl-CGI perl-CPAN perl-DBD-MySQL perl-DateManip perl-HTML-Parser perl-HTML-Tagset perl-TimeDate perl-URI perl-libwww-perl perl-suidperl rsync krb5-libs postgresql-server postgresql postgresql-docs postgresql-libs postgresql-devel screen zsh lftp cvs gcc tetex-fonts tetex-latex tetex tetex-dvips ghostscript ghostscript-fonts libpng-devel freetype-devel libjpeg-devel #gd openssh + +#lftpget http://download.atrpms.net/testing/packages/redhat-8.0-i386/atrpms/gd-2.0.28-0_9.rh8.0.at.i386.rpm +lftpget http://download.atrpms.net/testing/packages/redhat-8.0-i386/atrpms/libgd2-2.0.28-0_9.rh8.0.at.i386.rpm http://download.atrpms.net/testing/packages/redhat-8.0-i386/atrpms/gd-devel-2.0.28-0_9.rh8.0.at.i386.rpm + +rpm -i libgd2-2.0.28-0_9.rh8.0.at.i386.rpm gd-devel-2.0.28-0_9.rh8.0.at.i386.rpm + +perl -MCPAN -e"install Locale::Country, Net::Whois, Business::CreditCard, + Mail::Internet, File::CounterFile, FreezeThaw, + String::Approx, Text::Template, DBIx::DataSource, + DBIx::DBSchema, Net::SSH, String::ShellQuote, + Net::SCP, Apache::ASP, Tie::IxHash, Time::Duration, + HTML::Widgets::SelectLayers, Apache::DBI, Cache::Cache, + Test::Pod, NetAddr::IP, IPC::ShareLite, + Chart::LinesPoints, DBI, DBD::Pg, HTML::Mason, + Net::Whois::Raw, Crypt::PasswdMD5, File::Temp, Storable" + +#apachetoolbox i guess + +/usr/sbin/useradd freeside + +/sbin/chkconfig postgresql on +/etc/init.d/postgresql start + +su postgres -c "createuser -P freeside" + +su freeside -c "createdb freeside" + +#? +cd ../../.. +make install-perl-modules +make create-config +freeside-adduser -c -h /usr/local/etc/freeside/htpasswd ivan +su freeside -c 'freeside-setup ivan' +su freeside -c '/home/ivan/freeside/bin/populate-msgcat ivan' +make deploy + diff --git a/install/redhat/8/README.insecure b/install/redhat/8/README.insecure new file mode 100644 index 0000000..14f1bd0 --- /dev/null +++ b/install/redhat/8/README.insecure @@ -0,0 +1,6 @@ +Red Hat has ceased support for all pre-enterprise releases. + +Fedora Legacy (http://www.fedoralegacy.org) is only supporting 7.3 and 9. + +Red Hat 8.0 is NOT RECOMMENDED. Please consider using a supported +distribution, such as 7.3, 9, or Fedora core. diff --git a/install/redhat/8/sources.list b/install/redhat/8/sources.list new file mode 100644 index 0000000..40a05ca --- /dev/null +++ b/install/redhat/8/sources.list @@ -0,0 +1 @@ +rpm http://download.fedoralegacy.org/apt redhat/8.0/i386 os updates legacy-utils diff --git a/install/redhat/9/INSTALL b/install/redhat/9/INSTALL new file mode 100644 index 0000000..c32a235 --- /dev/null +++ b/install/redhat/9/INSTALL @@ -0,0 +1,48 @@ +#!/bin/sh + +wget --passive-ftp --continue http://redhat.usu.edu/mirrors/apt4rpm/apt-0.5.5cnc4.1-fr1.20030325a.2.i386.rpm +rpm -i apt*i386.rpm +cp sources.list /etc/apt/ +apt-get update + +apt-get install httpd mod_perl mod_ssl perl-CGI perl-CPAN perl-DBD-MySQL perl-DateManip perl-HTML-Parser perl-HTML-Tagset perl-TimeDate perl-URI perl-libwww-perl perl-suidperl rsync postgresql postgresql-docs postgresql-libs postgresql-server screen zsh lftp cvs gcc # gd openssh + +wget --passive-ftp --continue http://atrpms.physik.fu-berlin.de/dist/rh9/perl-GD/perl-GD-2.11-7.rh9.at.i386.rpm http://atrpms.physik.fu-berlin.de/dist/rh9/atrpms/atrpms-54-1.rh9.at.noarch.rpm http://atrpms.physik.fu-berlin.de/dist/rh9/gd/gd-2.0.15-1_6.rh9.at.i386.rpm + +cp /etc/apt/apt.conf /etc/apt/apt.conf.real + +rpm -i gd-2.0.15-1_6.rh9.at.i386.rpm atrpms-54-1.rh9.at.noarch.rpm perl-GD-2.11-7.rh9.at.i386.rpm + +mv /etc/apt/apt.conf.real /etc/apt/apt.conf + +perl -MCPAN -e"install Locale::Country, Net::Whois, Business::CreditCard, \ + Mail::Internet, File::CounterFile, FreezeThaw, \ + String::Approx, Text::Template, DBIx::DataSource, \ + DBIx::DBSchema, Net::SSH, String::ShellQuote, \ + Net::SCP, Apache::ASP, Tie::IxHash, Time::Duration, \ + HTML::Widgets::SelectLayers, Apache::DBI, \ + Cache::Cache, Test::Pod, NetAddr::IP, IPC::ShareLite, \ + Chart::LinesPoints, Net::Whois::Raw, \ + Locale::SubCountry, Crypt::PasswdMD5, DBI, DBD::Pg" + + +#apachetoolbox i guess + +/usr/sbin/useradd freeside + +/sbin/chkconfig postgresql on +/etc/init.d/postgresql start + +su postgres -c "createuser -P freeside" + +su freeside -c "createdb freeside" + +#? +cd ../../.. +make install-perl-modules +make create-config +freeside-adduser -c -h /usr/local/etc/freeside/htpasswd ivan +su freeside -c 'freeside-setup ivan' +su freeside -c '/home/ivan/freeside/bin/populate-msgcat ivan' +make deploy + diff --git a/install/redhat/9/sources.list b/install/redhat/9/sources.list new file mode 100644 index 0000000..6dcb3b4 --- /dev/null +++ b/install/redhat/9/sources.list @@ -0,0 +1,2 @@ +#rpm http://download.fedoralegacy.org/apt redhat/9/i386 os updates legacy-util +rpm http://download.fedoralegacy.org/apt redhat/9/i386 os updates diff --git a/install/redhat/es3/INSTALL b/install/redhat/es3/INSTALL new file mode 100644 index 0000000..e28ca45 --- /dev/null +++ b/install/redhat/es3/INSTALL @@ -0,0 +1,49 @@ +#!/bin/sh + +up2date cvs perl-DBD-MySQL perl-DBI perl-DateManip perl-HTML-Parser \ + perl-HTML-Tagset perl-URI perl-libwww-perl perl-CPAN \ + rsync screen zsh lftp cvs autoconf \ + gcc gd rh-postgresql rh-postgresql-docs rh-postgresql-libs \ + rh-postgresql-server rh-postgresql-devel + +perl -MCPAN -e"install Net::Whois::Raw, Business::CreditCard, \ + File::CounterFile, String::Approx, Text::Template, \ + DBIx::DataSource, FreezeThaw, DBIx::DBSchema, \ + Net::SSH, String::ShellQuote, Net::SCP, Apache::ASP, \ + HTML::Mason, Tie::IxHash, Time::Duration, \ + HTML::Widgets::SelectLayers, Apache::DBI, \ + Cache::Cache, IPC::ShareLite, Locale::SubCountry, \ + Crypt::PasswdMD5, \ + Locale::SubCountry, DBI, DBD::Pg, \ + File::Temp" + +lftpget http://dag.wieers.com/packages/apt/apt-0.5.15cnc6-3.1.el3.dag.i386.rpm +rpm -i apt-0.5.15cnc6-3.1.el3.dag.i386.rpm +apt-get update +apt-get install perl-GD perl-MailTools perl-TimeDate perl-NetAddr-IP + +perl -MCPAN -e"install Chart::Base" + +#apachetoolbox +#lftpget http://umn.dl.sourceforge.net/sourceforge/apachetoolbox/Apachetoolbox-install-1.5.70.tar.gz +cp httpd-init /etc/init.d/httpd-freeside +/sbin/chkconfig httpd-freeside on + +/usr/sbin/useradd freeside + +/sbin/chkconfig rhdb on +/etc/init.d/rhdb start + +su postgres -c "createuser -P freeside" + +su freeside -c "createdb freeside" + +#? +cd ../../.. +make install-perl-modules +make create-config +freeside-adduser -c -h /usr/local/etc/freeside/htpasswd ivan +su freeside -c 'freeside-setup ivan' +su freeside -c '/home/ivan/freeside/bin/populate-msgcat ivan' +make deploy + diff --git a/install/redhat/es3/httpd-init b/install/redhat/es3/httpd-init new file mode 100644 index 0000000..dca95cf --- /dev/null +++ b/install/redhat/es3/httpd-init @@ -0,0 +1,50 @@ +#!/bin/bash +# +# Startup script for the Apache Web Server +# +# chkconfig: - 85 15 +# description: Apache is a World Wide Web server. It is used to serve \ +# HTML files and CGI. +# processname: httpd +# Source function library. + +# Path to the apachectl script, server binary, and short-form for messages. +apachectl=/usr/local/apache/bin/apachectl +prog=httpd +RETVAL=0 + +start() { + echo -n $"Starting $prog: " + $apachectl startssl + RETVAL=$? +} +stop() { + echo -n $"Stopping $prog: " + $apachectl stop + RETVAL=$? +} + +# See how we were called. +case "$1" in + start) + start + ;; + stop) + stop + ;; + restart) + stop + sleep 3 + start + ;; + graceful|help|configtest) + $apachectl $@ + RETVAL=$? + ;; + *) + echo $"Usage: $prog {start|stop|restart|graceful|help|configtest}" + exit 1 +esac + +exit $RETVAL + diff --git a/install/suse/9.0/INSTALL b/install/suse/9.0/INSTALL new file mode 100644 index 0000000..4e44147 --- /dev/null +++ b/install/suse/9.0/INSTALL @@ -0,0 +1,52 @@ +#!/bin/sh + +# based on install/redhat/9/INSTALL + +# apt for SuSE howto: http://linux01.gwdg.de/apt4rpm/ + +for file in ftp://ftp.gwdg.de/pub/linux/suse/apt/SuSE/9.0-i386/RPMS.suser-rbos/apt-0.5.5cnc6-rb6.i586.rpm ftp://ftp.gwdg.de/pub/linux/suse/apt/SuSE/9.0-i386/RPMS.suser-rbos/apt-libs-0.5.5cnc6-rb6.i586.rpm ftp://ftp.gwdg.de/pub/linux/suse/apt/SuSE/9.0-i386/RPMS.suser-rbos/lua-5.0-rb3.i586.rpm; do + curl -C - -o `basename $file` $file +done + +rpm -i lua-5.0-rb3.i586.rpm +rpm -i apt-libs-0.5.5cnc6-rb6.i586.rpm +rpm -i apt-0.5.5cnc6-rb6.i586.rpm + +perl -pi.bak -e 's/386 update/386 base update/' /etc/apt/sources.list + +apt-get update; apt-get update + +apt-get install apache mod_ssl mod_perl perl-DBI perl-Msql-Mysql-modules perl-DBD-Pg perl-DateManip perl-HTML-Parser perl-HTML-Tagset perl-TimeDate perl-URI perl-libwww-perl perl-Apache-DBI perl-Apache-ASP perl-GD perl-MailTools perl-Tie-IxHash rsync postgresql postgresql-docs postgresql-libs postgresql-server postgresql-devel screen zsh lftp wget cvs make gcc + +perl -MCPAN -e"install DBD::Pg, Net::Whois, Business::CreditCard, \ + File::CounterFile, FreezeThaw, String::Approx, \ + Text::Template, DBIx::DataSource, DBIx::DBSchema, \ + Net::SSH, String::ShellQuote, Net::SCP, \ + Time::Duration, HTML::Widgets::SelectLayers, \ + Cache::Cache, Test::Pod, NetAddr::IP, IPC::ShareLite, \ + Chart::LinesPoints" + +/usr/sbin/useradd freeside + +/sbin/chkconfig postgresql on +/etc/init.d/postgresql start + +/sbin/chkconfig apache on +#/etc/init.d/apache start + +su postgres -c "createuser -P freeside" + +su freeside -c "createdb freeside" + +#? +cd ../../.. +make install-perl-modules +make create-config +freeside-adduser -c -h /usr/local/etc/freeside/htpasswd ivan +su freeside -c 'freeside-setup ivan' +su freeside -c '/home/ivan/freeside/bin/populate-msgcat ivan' +make deploy + + + + |