diff options
Diffstat (limited to 'install')
82 files changed, 0 insertions, 13654 deletions
diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/Changes b/install/5.005/DBD-Pg-1.22-fixvercmp/Changes deleted file mode 100644 index c345628..0000000 --- a/install/5.005/DBD-Pg-1.22-fixvercmp/Changes +++ /dev/null @@ -1,352 +0,0 @@ -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 deleted file mode 100644 index 7d1b700..0000000 --- a/install/5.005/DBD-Pg-1.22-fixvercmp/MANIFEST +++ /dev/null @@ -1,38 +0,0 @@ -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 deleted file mode 100644 index 0633280..0000000 --- a/install/5.005/DBD-Pg-1.22-fixvercmp/Makefile.PL +++ /dev/null @@ -1,83 +0,0 @@ - -# $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 deleted file mode 100644 index b77a9f8..0000000 --- a/install/5.005/DBD-Pg-1.22-fixvercmp/Pg.h +++ /dev/null @@ -1,46 +0,0 @@ -/* - $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 deleted file mode 100644 index 284e563..0000000 --- a/install/5.005/DBD-Pg-1.22-fixvercmp/Pg.pm +++ /dev/null @@ -1,1913 +0,0 @@ - -# $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 deleted file mode 100644 index e5e4362..0000000 --- a/install/5.005/DBD-Pg-1.22-fixvercmp/Pg.xs +++ /dev/null @@ -1,644 +0,0 @@ -/* - $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 deleted file mode 100644 index 7edebde..0000000 --- a/install/5.005/DBD-Pg-1.22-fixvercmp/README +++ /dev/null @@ -1,166 +0,0 @@ - -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 deleted file mode 100644 index 3cbe673..0000000 --- a/install/5.005/DBD-Pg-1.22-fixvercmp/README.win32 +++ /dev/null @@ -1,63 +0,0 @@ - -$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 deleted file mode 100644 index ccbbc63..0000000 --- a/install/5.005/DBD-Pg-1.22-fixvercmp/dbd-pg.pod +++ /dev/null @@ -1,411 +0,0 @@ - -# $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 deleted file mode 100644 index 55f4ee7..0000000 --- a/install/5.005/DBD-Pg-1.22-fixvercmp/dbdimp.c +++ /dev/null @@ -1,2024 +0,0 @@ -/* - $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 deleted file mode 100644 index 58c105b..0000000 --- a/install/5.005/DBD-Pg-1.22-fixvercmp/dbdimp.h +++ /dev/null @@ -1,81 +0,0 @@ -/* - $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 deleted file mode 100755 index b084f70..0000000 --- a/install/5.005/DBD-Pg-1.22-fixvercmp/eg/ApacheDBI.pl +++ /dev/null @@ -1,70 +0,0 @@ -#!/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 deleted file mode 100644 index 6192c49..0000000 --- a/install/5.005/DBD-Pg-1.22-fixvercmp/eg/lotest.pl +++ /dev/null @@ -1,74 +0,0 @@ -#!/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 deleted file mode 100644 index 6f8acf8..0000000 --- a/install/5.005/DBD-Pg-1.22-fixvercmp/eg/notify_test.patch +++ /dev/null @@ -1,82 +0,0 @@ -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 deleted file mode 100644 index 1c0cb28..0000000 --- a/install/5.005/DBD-Pg-1.22-fixvercmp/t/00basic.t +++ /dev/null @@ -1,10 +0,0 @@ -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 deleted file mode 100644 index be17b50..0000000 --- a/install/5.005/DBD-Pg-1.22-fixvercmp/t/01connect.t +++ /dev/null @@ -1,26 +0,0 @@ -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 deleted file mode 100644 index 09907e9..0000000 --- a/install/5.005/DBD-Pg-1.22-fixvercmp/t/01constants.t +++ /dev/null @@ -1,25 +0,0 @@ -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 deleted file mode 100644 index d0b57a3..0000000 --- a/install/5.005/DBD-Pg-1.22-fixvercmp/t/01setup.t +++ /dev/null @@ -1,38 +0,0 @@ -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 deleted file mode 100644 index 373aca2..0000000 --- a/install/5.005/DBD-Pg-1.22-fixvercmp/t/02prepare.t +++ /dev/null @@ -1,84 +0,0 @@ -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 deleted file mode 100644 index df7c884..0000000 --- a/install/5.005/DBD-Pg-1.22-fixvercmp/t/03bind.t +++ /dev/null @@ -1,85 +0,0 @@ -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 deleted file mode 100644 index 9643878..0000000 --- a/install/5.005/DBD-Pg-1.22-fixvercmp/t/04execute.t +++ /dev/null @@ -1,113 +0,0 @@ -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 deleted file mode 100644 index b6f8f66..0000000 --- a/install/5.005/DBD-Pg-1.22-fixvercmp/t/05fetch.t +++ /dev/null @@ -1,131 +0,0 @@ -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 deleted file mode 100644 index 5d76bc0..0000000 --- a/install/5.005/DBD-Pg-1.22-fixvercmp/t/06disconnect.t +++ /dev/null @@ -1,31 +0,0 @@ -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 deleted file mode 100644 index d09dfc0..0000000 --- a/install/5.005/DBD-Pg-1.22-fixvercmp/t/07reuse.t +++ /dev/null @@ -1,28 +0,0 @@ -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 deleted file mode 100644 index 467aa31..0000000 --- a/install/5.005/DBD-Pg-1.22-fixvercmp/t/08txn.t +++ /dev/null @@ -1,102 +0,0 @@ -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 deleted file mode 100644 index 9b1b69f..0000000 --- a/install/5.005/DBD-Pg-1.22-fixvercmp/t/09autocommit.t +++ /dev/null @@ -1,68 +0,0 @@ -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 deleted file mode 100644 index afec963..0000000 --- a/install/5.005/DBD-Pg-1.22-fixvercmp/t/11quoting.t +++ /dev/null @@ -1,50 +0,0 @@ -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 deleted file mode 100644 index bd79ea7..0000000 --- a/install/5.005/DBD-Pg-1.22-fixvercmp/t/12placeholders.t +++ /dev/null @@ -1,125 +0,0 @@ -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 deleted file mode 100644 index 8db819e..0000000 --- a/install/5.005/DBD-Pg-1.22-fixvercmp/t/13pgtype.t +++ /dev/null @@ -1,43 +0,0 @@ -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 deleted file mode 100644 index 1bc2cf9..0000000 --- a/install/5.005/DBD-Pg-1.22-fixvercmp/t/15funct.t +++ /dev/null @@ -1,353 +0,0 @@ -#!/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 deleted file mode 100644 index e7563ab..0000000 --- a/install/5.005/DBD-Pg-1.22-fixvercmp/t/99cleanup.t +++ /dev/null @@ -1,24 +0,0 @@ -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 deleted file mode 100644 index 417247f..0000000 --- a/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info.pm +++ /dev/null @@ -1,1167 +0,0 @@ -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 deleted file mode 100644 index 65416a8..0000000 --- a/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/Handler.pm +++ /dev/null @@ -1,305 +0,0 @@ -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 deleted file mode 100644 index 47edd78..0000000 --- a/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/Handler/Prompt.pm +++ /dev/null @@ -1,170 +0,0 @@ -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 deleted file mode 100644 index 504d570..0000000 --- a/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/RDBMS.pm +++ /dev/null @@ -1,55 +0,0 @@ -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 deleted file mode 100644 index aef326c..0000000 --- a/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/RDBMS/PostgreSQL.pm +++ /dev/null @@ -1,730 +0,0 @@ -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 deleted file mode 100644 index c02c97b..0000000 --- a/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/Request.pm +++ /dev/null @@ -1,287 +0,0 @@ -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 deleted file mode 100644 index 55bb333..0000000 --- a/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/Util.pm +++ /dev/null @@ -1,456 +0,0 @@ -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 deleted file mode 100644 index f413bd9..0000000 --- a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/Changes +++ /dev/null @@ -1,62 +0,0 @@ -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 deleted file mode 100644 index fc4916d..0000000 --- a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema.pm +++ /dev/null @@ -1,367 +0,0 @@ -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 deleted file mode 100644 index ceeb223..0000000 --- a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/ColGroup.pm +++ /dev/null @@ -1,141 +0,0 @@ -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 deleted file mode 100644 index 1a92baa..0000000 --- a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/ColGroup/Index.pm +++ /dev/null @@ -1,37 +0,0 @@ -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 deleted file mode 100644 index 450043f..0000000 --- a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/ColGroup/Unique.pm +++ /dev/null @@ -1,38 +0,0 @@ -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 deleted file mode 100644 index 4e26646..0000000 --- a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/Column.pm +++ /dev/null @@ -1,300 +0,0 @@ -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 deleted file mode 100644 index a4c6000..0000000 --- a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/DBD.pm +++ /dev/null @@ -1,113 +0,0 @@ -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 deleted file mode 100644 index 018b890..0000000 --- a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/DBD/Pg.pm +++ /dev/null @@ -1,175 +0,0 @@ -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 deleted file mode 100755 index 4a74069..0000000 --- a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/DBD/Sybase.pm +++ /dev/null @@ -1,141 +0,0 @@ -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 deleted file mode 100644 index f3804dd..0000000 --- a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/DBD/mysql.pm +++ /dev/null @@ -1,126 +0,0 @@ -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 deleted file mode 100644 index 2d6272e..0000000 --- a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/Table.pm +++ /dev/null @@ -1,471 +0,0 @@ -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 deleted file mode 100644 index b04de25..0000000 --- a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/MANIFEST +++ /dev/null @@ -1,19 +0,0 @@ -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 deleted file mode 100644 index ae335e7..0000000 --- a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/MANIFEST.SKIP +++ /dev/null @@ -1 +0,0 @@ -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 deleted file mode 100644 index a10e4da..0000000 --- a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/Makefile.PL +++ /dev/null @@ -1,11 +0,0 @@ -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 deleted file mode 100644 index 8911ea4..0000000 --- a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/README +++ /dev/null @@ -1,42 +0,0 @@ -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 deleted file mode 100644 index e75850b..0000000 --- a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/TODO +++ /dev/null @@ -1,6 +0,0 @@ -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 deleted file mode 100644 index 78818c1..0000000 --- a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/t/load-mysql.t +++ /dev/null @@ -1,5 +0,0 @@ -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 deleted file mode 100644 index 93fcf4a..0000000 --- a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/t/load-pg.t +++ /dev/null @@ -1,12 +0,0 @@ -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 deleted file mode 100644 index 67ea44b..0000000 --- a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/t/load.t +++ /dev/null @@ -1,5 +0,0 @@ -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/centos/3/INSTALL b/install/centos/3/INSTALL deleted file mode 100644 index 9228f57..0000000 --- a/install/centos/3/INSTALL +++ /dev/null @@ -1,66 +0,0 @@ -#!/bin/sh - -yum install cvs perl 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, \ - FreezeThaw, DBIx::DBSchema, \ - Net::SSH, String::ShellQuote, Net::SCP, \ - 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, Storable, JavaScript::RPC::Server::CGI" - -#RT -#perl -MCPAN -e "install Digest::MD5, Test::Inline, Class::ReturnValue, DBIx::SearchBuilder, HTML::Scrubber, Log::Dispatch, Locale::Maketext::Fuzzy, MIME::Entity, Text::Wrapper, Time::ParseDate, Term::ReadKey, Text::Autoformat, Text::Quoted, Tree::Simple, Module::Versions::Report" - -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 -apt-get remove httpd -yum install krb5-devel openssl-devel -lftpget http://umn.dl.sourceforge.net/sourceforge/apachetoolbox/Apachetoolbox-install-1.5.72.tar.gz -tar xzvf Apachetoolbox-install-1.5.72.tar.gz -cd Apachetoolbox-1.5.72 -./install.sh -# export INCLUDES="-I/usr/kerberos/include" -cd apache_1.3.31;make -make certificate TYPE=dummy -make install -ln -s /usr/local/apache/bin/htpasswd /usr/local/bin -cp httpd-init /etc/init.d/httpd-freeside -chmod a+rx /etc/init.d/httpd-freeside -/sbin/chkconfig httpd-freeside on -#end apachetoolbox - -/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 -LANG=C su freeside -c 'freeside-setup ivan' -su freeside -c '/home/ivan/freeside/bin/populate-msgcat ivan' -make deploy - diff --git a/install/centos/3/httpd-init b/install/centos/3/httpd-init deleted file mode 100644 index dca95cf..0000000 --- a/install/centos/3/httpd-init +++ /dev/null @@ -1,50 +0,0 @@ -#!/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/debian/3.0/INSTALL b/install/debian/3.0/INSTALL deleted file mode 100644 index 019d515..0000000 --- a/install/debian/3.0/INSTALL +++ /dev/null @@ -1,33 +0,0 @@ -#!/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/debian/3.1/INSTALL b/install/debian/3.1/INSTALL deleted file mode 100644 index c047660..0000000 --- a/install/debian/3.1/INSTALL +++ /dev/null @@ -1,59 +0,0 @@ -#!/bin/sh - -echo "deb http://420.am/~ivan/freeside-sarge/ ./" >>/etc/apt/sources.list - -apt-get update -apt-get install make screen zsh cvs fsh rsync \ - apache libapache-mod-ssl libapache-mod-ssl-doc libapache-mod-perl \ - postgresql postgresql-contrib \ - tetex-base tetex-bin tetex-extra \ - gs lpr libpaper-utils psutils dialog psfontmgr \ - liburi-perl libhtml-tagset-perl libnet-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-dbschema-perl libnet-ssh-perl \ - libstring-shellquote-perl libnet-scp-perl libhtml-mason-perl \ - libtie-ixhash-perl libtime-duration-perl \ - libhtml-widgets-selectlayers-perl \ - libapache-dbi-perl libcache-cache-perl libdbd-mysql-perl \ - libcrypt-passwdmd5-perl libnetaddr-ip-perl \ - libnet-whois-raw-perl libchart-perl \ - libmime-perl libapache-session-perl libhtml-tree-perl \ - libhtml-format-perl libtest-inline-perl libclass-returnvalue-perl \ - libdbix-searchbuilder-perl liblog-dispatch-perl \ - liblocale-maketext-lexicon-perl liblocale-maketext-fuzzy-perl \ - libtext-wrapper-perl libtime-modules-perl libterm-readkey-perl \ - libtext-autoformat-perl libtext-quoted-perl libregexp-common-perl \ - libhtml-scrubber-perl libtree-simple-perl liblocale-subcountry-perl \ - libtext-csv-perl libspreadsheet-writeexcel-perl libfrontier-rpc-perl \ - libjavascript-rpc-perl libipc-run3-perl libjson-perl - -useradd freeside -groupadd freeside -su postgres -c "createuser -P freeside" - -su freeside -c "createdb freeside" - -perl -p -i.fsbackup -e 's/^(User|Group) .*/$1 freeside/' /etc/apache/httpd.conf -( cd /usr/share/doc/libapache-mod-ssl/examples/; - cp mod-ssl.conf vhost.conf.gz /etc/apache/conf.d -) -gunzip /etc/apache/conf.d/vhost.conf.gz - -#? -cd ../../.. -make install-perl-modules -make create-config -freeside-adduser -c -h /usr/local/etc/freeside/htpasswd ivan -freeside-adduser fs_queue -su freeside -c 'freeside-setup ivan' -su freeside -c '/home/ivan/freeside/bin/populate-msgcat ivan' -make configure-rt - -#muck with pg perms -make create-rt -#unmuck pg perms - -make deploy diff --git a/install/fedora/fc1/INSTALL b/install/fedora/fc1/INSTALL deleted file mode 100755 index c347609..0000000 --- a/install/fedora/fc1/INSTALL +++ /dev/null @@ -1,66 +0,0 @@ -#!/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 deleted file mode 100644 index 9b36242..0000000 --- a/install/fedora/fc1/sources.list +++ /dev/null @@ -1,12 +0,0 @@ -# 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 deleted file mode 100755 index d6c0a4f..0000000 --- a/install/fedora/fc2/INSTALL +++ /dev/null @@ -1,63 +0,0 @@ -#!/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 deleted file mode 100644 index 038db1e..0000000 --- a/install/fedora/fc2/sources.list +++ /dev/null @@ -1,12 +0,0 @@ -# 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/fedora/fc3/INSTALL b/install/fedora/fc3/INSTALL deleted file mode 100755 index 93f746b..0000000 --- a/install/fedora/fc3/INSTALL +++ /dev/null @@ -1,74 +0,0 @@ -#!/bin/sh - -wget --passive-ftp --continue http://download.fedora.us/fedora/fedora/3/i386/RPMS.extras/apt-0.5.15cnc6-16.r362.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 -f install -#apt-get remove httpd mod_perl -pt-get remove httpd mod_perl httpd-manual httpd-suexec mod_auth_kerb mod_auth_mysql mod_auth_pgsql mod_authz_ldap mod_python mod_ssl php system-config-httpd MyODBC MySQL-python php php-pgsql php-mysql php-pear php-odbc php-ldap 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 perl-MIME-tools perl-Text-Template openssl openssl-devel perl-Text-CSV_XS perl-Frontier-RPC - -#for rt -#apt-get install perl-Apache-Session perl-TermReadKey perl-MLDBM perl-MLDBM-Sync perl-Log-Dispatch perl-Term-ReadKey - -perl -MCPAN -e"install Net::Whois::Raw, Business::CreditCard, \ - File::CounterFile, String::Approx, \ - 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, Spreadsheet::WriteExcel, \ - Fax::Hylafax::Client, JavaScript::RPC::Server::CGI" - -#for rt -#perl -MCPAN -e"install HTML::TreeBuilder, HTML::FormatText, Test::Inline, \ -# Class::ReturnValue, DBIx::SearchBuilder, \ -# Log::Dispatch, Locale::Maketext::Lexicon, \ -# Locale::Maketext::Fuzzy, Text::Wrapper, \ -# Time::ParseDate, Text::AutoFormat, Text::Quoted, \ -# Regexp::Common, HTML::Scrubber, Tree::Simple" - - -#apachetoolbox -#lftpget http://easynews.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/fc3/sources.list b/install/fedora/fc3/sources.list deleted file mode 100644 index d299e9d..0000000 --- a/install/fedora/fc3/sources.list +++ /dev/null @@ -1,12 +0,0 @@ -# Fedora Core (Kernel.org, San Francisco California, USA) -rpm http://mirrors.kernel.org/fedora.us/fedora fedora/3/i386 os updates -rpm-src http://mirrors.kernel.org/fedora.us/fedora fedora/3/i386 os updates - -# Fedora Extras (Kernel.org, San Francisco California, USA) -rpm http://mirrors.kernel.org/fedora.us/fedora fedora/3/i386 extras -rpm-src http://mirrors.kernel.org/fedora.us/fedora fedora/3/i386 extras - -### Dag Apt Repository for Red Hat Fedora Core 3 (rhfc3) -rpm http://apt.sw.be fedora/3/en/i386 dag - -rpm http://apt.physik.fu-berlin.de fedora/3/en/i386 at-testing diff --git a/install/freebsd/INSTALL b/install/freebsd/INSTALL deleted file mode 100755 index e8c92b0..0000000 --- a/install/freebsd/INSTALL +++ /dev/null @@ -1,76 +0,0 @@ -#!/bin/sh - -# if /usr/local/sbin/portupgrade does not exist -# then install portupgrade -( cd /usr/ports/sysutils/portupgrade - #??? setenv WITH_OPENSSL_PORT "yes" - make install clean -) - -# ??? -##rehash -#pkgdb -u - -# if cvsup is not installed, then -portinstall -PR cvsup-without-gui - -#cp /usr/share/examples/cvsup/ports-supfile /root -#perl -pi -e 's/CHANGE_THIS/cvsup13/;' /root/ports-supfile -#cvsup /root/ports-supfile - -# choose the fastest cvsup server, then cvsup update -/usr/local/bin/cvsup -g -L 2 -h cvsup2.freebsd.org /usr/share/examples/cvsup/ports-supfile - -# Update the ports database -#/usr/local/sbin/portsdb -Uu -portsdb -Uu - -portinstall -PR portupgrade - -portinstall -PR lang/perl5.8 -# if FreeBSD 4.x, then -/usr/local/bin/use.perl port - -#portupgrade -f `(pkg_info -R perl-5\* |tail +4; \ -# find /usr/local/lib/perl5/site_perl/5.[68].[1245] -type f -print0 \ -# | xargs -0 pkg_which -fv | sed -e '/: ?/d' -e 's/.*: //')|sort -u` - - -for port in `grep -v '^ *#' ports`; do - portinstall -PR $port -done - -for a in JavaScript::RPC::Server::CGI Chart::LinesPoints Frontier::RPC2; do perl -MCPAN -e"install $a"; done - -su -l pgsql -c initdb -echo ' -postgresql_enable="YES" -postgresql_data="/usr/local/pgsql/data" -postgresql_flags="-w -s -m fast" -' >>/etc/rc.conf - -/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 -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' - -#edit apache config, etc. - -echo ' -apache_enable="YES" -apache_flags="-DSSL" -' >>/etc/rc.conf - -make deploy - diff --git a/install/freebsd/ports b/install/freebsd/ports deleted file mode 100644 index 90b49e6..0000000 --- a/install/freebsd/ports +++ /dev/null @@ -1,56 +0,0 @@ -shells/zsh -misc/screen -security/sudo -ftp/lftp -lang/perl5.8 -www/apache13-modssl -www/mod_perl -net/rsync -databases/postgresql74-server -#databases/postgresql74-client -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-Raw -www/p5-libwww -finance/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 -security/p5-Crypt-PasswdMD5 -net-mgmt/p5-NetAddr-IP -graphics/p5-GD -textproc/p5-Spreadsheet-WriteExcel -textproc/p5-Text-CSV_XS -misc/p5-Locale-SubCountry -devel/p5-IO-stringy -textproc/p5-XML-Parser -mail/p5-MIME-Tools diff --git a/install/openbsd/INSTALL b/install/openbsd/INSTALL deleted file mode 100644 index 1beef92..0000000 --- a/install/openbsd/INSTALL +++ /dev/null @@ -1,54 +0,0 @@ -#!/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 deleted file mode 100644 index 4304b72..0000000 --- a/install/openbsd/cpan +++ /dev/null @@ -1,15 +0,0 @@ -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 deleted file mode 100644 index 3e17d82..0000000 --- a/install/openbsd/ports +++ /dev/null @@ -1,24 +0,0 @@ -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 deleted file mode 100644 index d2f60cb..0000000 --- a/install/redhat/7.3/INSTALL +++ /dev/null @@ -1,40 +0,0 @@ -#!/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 deleted file mode 100644 index 9a9ad5c..0000000 --- a/install/redhat/7.3/sources.list +++ /dev/null @@ -1,2 +0,0 @@ -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 deleted file mode 100755 index e6107d9..0000000 --- a/install/redhat/8/INSTALL +++ /dev/null @@ -1,47 +0,0 @@ -#!/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 deleted file mode 100644 index 14f1bd0..0000000 --- a/install/redhat/8/README.insecure +++ /dev/null @@ -1,6 +0,0 @@ -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 deleted file mode 100644 index 40a05ca..0000000 --- a/install/redhat/8/sources.list +++ /dev/null @@ -1 +0,0 @@ -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 deleted file mode 100644 index ad69d9b..0000000 --- a/install/redhat/9/INSTALL +++ /dev/null @@ -1,67 +0,0 @@ -#!/bin/sh - -wget --passive-ftp --continue http://download.fedora.us/fedora/redhat/9/i386/RPMS.stable/apt-0.5.5cnc6-0.fdr.8.rh90.i386.rpm -rpm -i apt*i386.rpm -#cp sources.list /etc/apt/ -apt-get update - -apt-get install krb5-devel perl-CGI perl-CPAN 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 # perl-DBD-MySQL # perl-suidperl gd openssh - -wget --passive-ftp --continue http://dl.atrpms.net/production/packages/redhat-9-i386/atrpms/perl-GD-2.16-10.rh9.at.i386.rpm http://dl.atrpms.net/production/packages/common/atrpms/atrpms-61-1.at.noarch.rpm http://dl.atrpms.net/testing/packages/redhat-9-i386/atrpms/gd-2.0.28-1_10.rh9.at.i386.rpm http://dl.atrpms.net/testing/packages/redhat-9-i386/atrpms/libgd2-2.0.28-1_10.rh9.at.i386.rpm - -#cp /etc/apt/apt.conf /etc/apt/apt.conf.real - -rpm -i atrpms*.rpm libgd2*i386.rpm gd-2*i386.rpm perl-GD*i386.rpm - -#mv /etc/apt/apt.conf.real /etc/apt/apt.conf - -apt-get install perl-MIME-tools - -perl -MCPAN -e"install Locale::Country, Business::CreditCard, \ - Mail::Internet, File::CounterFile, FreezeThaw, \ - 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, \ - Cache::Cache, Test::Pod, NetAddr::IP, IPC::ShareLite, \ - Chart::LinesPoints, Net::Whois::Raw, \ - Locale::SubCountry, Crypt::PasswdMD5, DBI, DBD::Pg, \ - JavaScript::RPC::Server::CGI, Text::CSV_XS, \ - Spreadsheet::WriteExcel, Frontier::RPC2, \ - File::Temp, Storable" - -apt-get remove httpd mod_perl mod_ssl -#apachetoolbox -lftpget http://easynews.dl.sourceforge.net/sourceforge/apachetoolbox/Apachetoolbox-install-1.5.72.tar.gz -tar xzvf Apachetoolbox-install-1.5.72.tar.gz -(cd Apachetoolbox-1.5.72; sh install.sh) -# 4 -# 16 -# go -# export INCLUDES="-I/usr/kerberos/include" -cd apache_1.3.31;make -#make certificate TYPE=dummy -make install - - -#apache config -#apache init script - -/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 deleted file mode 100644 index 6dcb3b4..0000000 --- a/install/redhat/9/sources.list +++ /dev/null @@ -1,2 +0,0 @@ -#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 deleted file mode 100644 index 67e47ec..0000000 --- a/install/redhat/es3/INSTALL +++ /dev/null @@ -1,90 +0,0 @@ -#!/bin/sh - -#up2date cvs perl perl-DBD-MySQL perl-DBI perl-DateManip perl-HTML-Parser \ -up2date cvs perl perl-DateManip perl-HTML-Parser \ - perl-HTML-Tagset perl-URI perl-libwww-perl perl-CPAN \ - rsync screen zsh lftp cvs autoconf \ - gcc gd tetex tetex-afm tetex-dvips tetex-font tetex-latex - -up2date --src rh-postgresql rh-postgresql-docs rh-postgresql-libs \ - rh-postgresql-server rh-postgresql-devel - -##slony bits... -#up2date rpm-build bison flex python-devel tcl-devel readline-devel zlib-devel openssl-devel krb5-devel pam-devel -#mkdir /usr/src/redhat -#rpm -i /var/spool/up2date/rh-postgresql-*.src.rpm -#rpmbuild -bb /usr/src/redhat/SPECS/rh-postgresql.spec -#apt-get remove rh-postgresql rh-postgresql-docs rh-postgresql-libs rh-postgresql-server rh-postgresql-devel -#rpm -i /usr/src/redhat/RPMS/i386/rh-postgresql-7.3.8-2.i386.rpm /usr/src/redhat/RPMS/i386/rh-postgresql-devel-7.3.8-2.i386.rpm /usr/src/redhat/RPMS/i386/rh-postgresql-docs-7.3.8-2.i386.rpm /usr/src/redhat/RPMS/i386/rh-postgresql-libs-7.3.8-2.i386.rpm /usr/src/redhat/RPMS/i386/rh-postgresql-server-7.3.8-2.i386.rpm -# -#lftpget http://developer.postgresql.org/~wieck/slony1/download/slony1-1.0.5.tar.gz -#tar xzvf slony1-1.0.5.tar.gz -#cd slony1-1.0.5 -#./configure --with-pgsourcetree=/usr/src/redhat/BUILD/postgresql-7.3.8/ -#make -#make install -##edit /var/lib/pgsql/data/postgresql.conf: tcpip_socket = true -##edit /var/lib/pgsql/data/pg_hba.conf (entries for both hosts on both): -#host freeside freeside IP.ADDRESS 255.255.255.255 trust -##end of slony bits - -perl -MCPAN -e"install Net::Whois::Raw, Business::CreditCard, \ - File::CounterFile, String::Approx, Text::Template, \ - FreezeThaw, DBIx::DBSchema, \ - Net::SSH, String::ShellQuote, Net::SCP, \ - 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, Storable, JavaScript::RPC::Server::CGI" - -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 -apt-get remove httpd -up2date krb5-devel openssl-devel -lftpget http://umn.dl.sourceforge.net/sourceforge/apachetoolbox/Apachetoolbox-install-1.5.72.tar.gz -tar xzvf Apachetoolbox-install-1.5.72.tar.gz -cd Apachetoolbox-1.5.72 -./install.sh -# export INCLUDES="-I/usr/kerberos/include" -cd apache_1.3.31;make -make certificate TYPE=dummy -make install -ln -s /usr/local/apache/bin/htpasswd /usr/local/bin -cp httpd-init /etc/init.d/httpd-freeside -chmod a+rx /etc/init.d/httpd-freeside -/sbin/chkconfig httpd-freeside on -#end apachetoolbox - -/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 -LANG=C su freeside -c 'freeside-setup ivan' -## do slony foo in here -##master -#su freeside -c 'pg_dump freeside' >dumps/setup.sql -#scp dumps/setup.sql othermachine:. -##slave -#su freeside -c 'psql freeside <setup.sql' -##end slony foo -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 deleted file mode 100644 index dca95cf..0000000 --- a/install/redhat/es3/httpd-init +++ /dev/null @@ -1,50 +0,0 @@ -#!/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 deleted file mode 100644 index 4e44147..0000000 --- a/install/suse/9.0/INSTALL +++ /dev/null @@ -1,52 +0,0 @@ -#!/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 - - - - |