From 284f6c70799dd8bde026c1a8994bc373a35d9c4a Mon Sep 17 00:00:00 2001 From: ivan Date: Thu, 1 Mar 2007 17:49:21 +0000 Subject: prune_applications moved to FS::Misc::prune --- FS/bin/freeside-prune-applications | 2 +- FS/bin/freeside-upgrade | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/FS/bin/freeside-prune-applications b/FS/bin/freeside-prune-applications index b459da55e..d2b6efe0b 100755 --- a/FS/bin/freeside-prune-applications +++ b/FS/bin/freeside-prune-applications @@ -5,7 +5,7 @@ use vars qw($opt_d $opt_q $opt_v); # $opt_n instead of $opt_d? use vars qw($DEBUG $DRY_RUN); use Getopt::Std; use FS::UID qw(adminsuidsetup checkeuid); -use FS::Misc qw(prune_applications); +use FS::Misc::prune qw(prune_applications); die "Not running uid freeside!" unless checkeuid(); diff --git a/FS/bin/freeside-upgrade b/FS/bin/freeside-upgrade index db58c117c..b3ac2d151 100755 --- a/FS/bin/freeside-upgrade +++ b/FS/bin/freeside-upgrade @@ -8,7 +8,7 @@ use DBIx::DBSchema 0.31; use FS::UID qw(adminsuidsetup checkeuid datasrc ); #getsecrets); use FS::CurrentUser; use FS::Schema qw( dbdef dbdef_dist reload_dbdef ); -use FS::Misc qw(prune_applications); +use FS::Misc::prune qw(prune_applications); die "Not running uid freeside!" unless checkeuid(); -- cgit v1.2.1 From d19ad78158a96e33b3e113561d1263fa6b2fc13d Mon Sep 17 00:00:00 2001 From: ivan Date: Thu, 1 Mar 2007 20:12:16 +0000 Subject: yeah, a typo --- FS/FS/Misc/prune.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/FS/FS/Misc/prune.pm b/FS/FS/Misc/prune.pm index 634cd8a6c..371f31cbb 100644 --- a/FS/FS/Misc/prune.pm +++ b/FS/FS/Misc/prune.pm @@ -10,7 +10,7 @@ use FS::cust_credit_refund; #use FS::cust_pay_refund; @ISA = qw( Exporter ); -@EXPORT_OK = qw( prune applications ); +@EXPORT_OK = qw( prune_applications ); =head1 NAME -- cgit v1.2.1 From 92fc1fd3db74e352e09b2f362dba605f8c6f16e8 Mon Sep 17 00:00:00 2001 From: ivan Date: Thu, 1 Mar 2007 20:56:26 +0000 Subject: better match for toll-free prefixes --- FS/FS/part_pkg/voip_cdr.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/FS/FS/part_pkg/voip_cdr.pm b/FS/FS/part_pkg/voip_cdr.pm index 500a1b0a4..2341fd020 100644 --- a/FS/FS/part_pkg/voip_cdr.pm +++ b/FS/FS/part_pkg/voip_cdr.pm @@ -130,7 +130,7 @@ sub calc_recur { ### my( $to_or_from, $number ); - if ( $cdr->dst =~ /^(\+?1)?8[02-8]{2}/ ) { #tollfree call + if ( $cdr->dst =~ /^(\+?1)?8([02-8])\1/ ) { #tollfree call $to_or_from = 'from'; $number = $cdr->src; } else { #regular call -- cgit v1.2.1 From a0290148dced03b17bd75d93e640e5ef5e8a28e3 Mon Sep 17 00:00:00 2001 From: ivan Date: Fri, 2 Mar 2007 06:24:22 +0000 Subject: fix custom priority fields, whew --- FS/FS/TicketSystem/RT_External.pm | 21 +++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) diff --git a/FS/FS/TicketSystem/RT_External.pm b/FS/FS/TicketSystem/RT_External.pm index 3a0d6f0a5..dda835cc1 100644 --- a/FS/FS/TicketSystem/RT_External.pm +++ b/FS/FS/TicketSystem/RT_External.pm @@ -1,14 +1,17 @@ package FS::TicketSystem::RT_External; use strict; -use vars qw( $conf $default_queueid +use vars qw( $DEBUG $me $conf $dbh $default_queueid $external_url $priority_field $priority_field_queue $field - $dbh $external_url ); + ); use URI::Escape; use FS::UID qw(dbh); use FS::Record qw(qsearchs); use FS::cust_main; +$me = '[FS::TicketSystem::RT_External]'; +$DEBUG = 0; + FS::UID->install_callback( sub { $conf = new FS::Conf; $default_queueid = $conf->config('ticket_system-default_queueid'); @@ -17,6 +20,7 @@ FS::UID->install_callback( sub { if ( $priority_field ) { $priority_field_queue = $conf->config('ticket_system-custom_priority_field_queue'); + $field = $priority_field_queue ? $priority_field_queue. '.%7B'. $priority_field. '%7D' : $priority_field; @@ -35,6 +39,17 @@ FS::UID->install_callback( sub { $external_url = $conf->config('ticket_system-rt_external_url'); } + #kludge... should *use* the id... but good enough for now + if ( $priority_field_queue =~ /^(\d+)$/ ) { + my $id = $1; + my $sql = 'SELECT Name FROM Queues WHERE Id = ?'; + my $sth = $dbh->prepare($sql) or die $dbh->errstr. " preparing $sql"; + $sth->execute($id) or die $sth->errstr. " executing $sql"; + + $priority_field_queue = $sth->fetchrow_arrayref->[0]; + + } + } ); sub num_customer_tickets { @@ -43,6 +58,7 @@ sub num_customer_tickets { my( $from_sql, @param) = $self->_from_customer( $custnum, $priority ); my $sql = "SELECT COUNT(*) $from_sql"; + warn "$me $sql (@param)" if $DEBUG; my $sth = $dbh->prepare($sql) or die $dbh->errstr. " preparing $sql"; $sth->execute(@param) or die $sth->errstr. " executing $sql"; @@ -60,6 +76,7 @@ sub customer_tickets { " AS svalue " . ( length($priority) ? ", objectcustomfieldvalues.content" : '' ). " $from_sql ORDER BY svalue, priority DESC, id DESC LIMIT $limit"; + warn "$me $sql (@param)" if $DEBUG; my $sth = $dbh->prepare($sql) or die $dbh->errstr. "preparing $sql"; $sth->execute(@param) or die $sth->errstr. "executing $sql"; -- cgit v1.2.1 From 2c1569aebafcf123ad71785f67d8ec005ffa04b3 Mon Sep 17 00:00:00 2001 From: ivan Date: Fri, 2 Mar 2007 23:48:18 +0000 Subject: eProcessingNetwork returning an authorization like "AUTH/TKT 123456"... will this make refunds work? --- FS/FS/cust_main.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/FS/FS/cust_main.pm b/FS/FS/cust_main.pm index fe6aa50a7..c6212756a 100644 --- a/FS/FS/cust_main.pm +++ b/FS/FS/cust_main.pm @@ -2898,7 +2898,7 @@ sub realtime_refund_bop { or return "Unknown paynum $options{'paynum'}"; $amount ||= $cust_pay->paid; - $cust_pay->paybatch =~ /^((\d+)\-)?(\w+):\s*([\w\-]*)(:([\w\-]+))?$/ + $cust_pay->paybatch =~ /^((\d+)\-)?(\w+):\s*([\w\-\/ ]*)(:([\w\-]+))?$/ or return "Can't parse paybatch for paynum $options{'paynum'}: ". $cust_pay->paybatch; my $gatewaynum = ''; -- cgit v1.2.1 From a9df3b5d93e0f952ba3234778bd3f3b07413b70d Mon Sep 17 00:00:00 2001 From: ivan Date: Sat, 3 Mar 2007 01:29:46 +0000 Subject: pass the remote IP address along with signup requests, for some gateways --- fs_selfservice/FS-SelfService/cgi/signup.cgi | 34 +++++++++++++++------------- 1 file changed, 18 insertions(+), 16 deletions(-) diff --git a/fs_selfservice/FS-SelfService/cgi/signup.cgi b/fs_selfservice/FS-SelfService/cgi/signup.cgi index 1514db52a..227f05f7b 100755 --- a/fs_selfservice/FS-SelfService/cgi/signup.cgi +++ b/fs_selfservice/FS-SelfService/cgi/signup.cgi @@ -182,22 +182,24 @@ if ( ( defined($cgi->param('magic')) && $cgi->param('magic') eq 'process' ) unless ( $error ) { my $rv = new_customer( { - map { $_ => scalar($cgi->param($_)) } - qw( last first ss company - address1 address2 city county state zip country - daytime night fax - - ship_last ship_first ship_company - ship_address1 ship_address2 ship_city ship_county ship_state - ship_zip ship_country - ship_daytime ship_night ship_fax - - payby payinfo paycvv paydate payname invoicing_list - referral_custnum promo_code reg_code - pkgpart username sec_phrase _password popnum refnum - agentnum - ), - grep { /^snarf_/ } $cgi->param + ( map { $_ => scalar($cgi->param($_)) } + qw( last first ss company + address1 address2 city county state zip country + daytime night fax + + ship_last ship_first ship_company + ship_address1 ship_address2 ship_city ship_county ship_state + ship_zip ship_country + ship_daytime ship_night ship_fax + + payby payinfo paycvv paydate payname invoicing_list + referral_custnum promo_code reg_code + pkgpart username sec_phrase _password popnum refnum + agentnum + ), + grep { /^snarf_/ } $cgi->param + ), + 'payip' => $cgi->remote_host(), } ); $error = $rv->{'error'}; } -- cgit v1.2.1 From a29e87197c593e4e6b9eb8e66bf03ea61006a5af Mon Sep 17 00:00:00 2001 From: khoff Date: Mon, 5 Mar 2007 19:48:16 +0000 Subject: Fixed a problem with the %opts hash getting skewed (specifically $opt{'value'} == 'label') when $cgi->param('agentnum') was unset. --- httemplate/search/report_cust_bill.html | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/httemplate/search/report_cust_bill.html b/httemplate/search/report_cust_bill.html index 4fa09f96c..74b96cc90 100644 --- a/httemplate/search/report_cust_bill.html +++ b/httemplate/search/report_cust_bill.html @@ -5,7 +5,7 @@ <% include( '/elements/tr-select-agent.html', - $cgi->param('agentnum'), + $cgi->param('agentnum') ? $cgi->param('agentnum') : '', 'label' => 'Invoices for agent: ', ) %> -- cgit v1.2.1 From 02055f915e167a12cf3f39ea63bf4432216aed47 Mon Sep 17 00:00:00 2001 From: jayce Date: Mon, 5 Mar 2007 23:01:53 +0000 Subject: Typo in the package name caused a warning. Fixed. --- FS/FS/part_pkg/base_delayed.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/FS/FS/part_pkg/base_delayed.pm b/FS/FS/part_pkg/base_delayed.pm index 1406a5635..ddd4caf73 100644 --- a/FS/FS/part_pkg/base_delayed.pm +++ b/FS/FS/part_pkg/base_delayed.pm @@ -1,4 +1,4 @@ -package FS::part_pkg::flat_delayed; +package FS::part_pkg::base_delayed; use strict; use vars qw(@ISA %info); -- cgit v1.2.1 From d11f7c132bb3f235980ecc9a98617fcb853f08f3 Mon Sep 17 00:00:00 2001 From: ivan Date: Tue, 6 Mar 2007 01:59:30 +0000 Subject: fix status colors in mozilla --- httemplate/search/cust_main.cgi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/httemplate/search/cust_main.cgi b/httemplate/search/cust_main.cgi index e87fe36d7..d66d16172 100755 --- a/httemplate/search/cust_main.cgi +++ b/httemplate/search/cust_main.cgi @@ -380,7 +380,7 @@ - + % -- cgit v1.2.1 From 6e6188dd4c3956652f2da27fe3cd0ebf30bd31aa Mon Sep 17 00:00:00 2001 From: ivan Date: Tue, 6 Mar 2007 19:56:41 +0000 Subject: slight update for slony setup script --- bin/slony-setup | 76 +++++++++++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 66 insertions(+), 10 deletions(-) diff --git a/bin/slony-setup b/bin/slony-setup index b384bb9f7..0798c1a03 100755 --- a/bin/slony-setup +++ b/bin/slony-setup @@ -1,35 +1,56 @@ #!/usr/bin/perl # -# hack to update/add read-only permissions for a user on the db -# -# usage: pg-readonly freesideuser readonlyuser +# slony replication setup +# +# usage: slony-setup freesideuser use strict; use DBI; use FS::UID qw(adminsuidsetup); use FS::Record qw(dbdef); -my $user = shift or die &usage; +my $user = shift or die "usage: slony-setup username\n"; adminsuidsetup($user); #--- -#su postgres -c 'createlang plpgsql freeside' - -#--- - -my $MASTERHOST = '172.21.0.204'; -my $SLAVEHOST = '172.21.0.205'; +my $MASTERHOST = '192.168.20.10'; +my $SLAVEHOST = '192.168.20.50'; #my $REPLICATIONUSER='pgsql'; my $REPLICATIONUSER='postgres'; +#-------- + +print <tables ) { } print </etc/slony1/freeside/slon.conf <<_EOF_ +# Set the cluster name that this instance of slon is running against +# default is to read it off the command line +cluster_name='freeside' + +# Set slon's connection info, default is to read it off the command line +conn_info='host=localhost port=5432 dbname=freeside user=postgres' +_EOF_ + +/etc/init.d/slony1 start + +END + + +print < Date: Wed, 7 Mar 2007 19:48:32 +0000 Subject: Option to disable the charging of the setup fee while a package is suspended. --- FS/FS/Conf.pm | 7 +++++++ FS/FS/cust_main.pm | 9 ++++++++- 2 files changed, 15 insertions(+), 1 deletion(-) diff --git a/FS/FS/Conf.pm b/FS/FS/Conf.pm index f2b1bea56..d9f7d1972 100644 --- a/FS/FS/Conf.pm +++ b/FS/FS/Conf.pm @@ -2076,6 +2076,13 @@ httemplate/docs/config.html 'type' => 'checkbox', }, + { + 'key' => 'disable_setup_suspended_pkgs', + 'section' => 'billing', + 'description' => 'Disables charging of setup fees for suspended packages.', + 'type' => 'checkbox', + }, + ); 1; diff --git a/FS/FS/cust_main.pm b/FS/FS/cust_main.pm index c6212756a..9c4b8bed7 100644 --- a/FS/FS/cust_main.pm +++ b/FS/FS/cust_main.pm @@ -1902,7 +1902,14 @@ sub bill { ### my $setup = 0; - if ( !$cust_pkg->setup || $options{'resetup'} ) { + if ( ! $cust_pkg->setup && + ( + ( $conf->exists('disable_setup_suspended_pkgs') && + ! $cust_pkg->getfield('susp') + ) || ! $conf->exists('disable_setup_suspended_pkgs') + ) + || $options{'resetup'} + ) { warn " bill setup\n" if $DEBUG > 1; -- cgit v1.2.1 From 3a9c534d55e1736545ef8037e1391101c7a11f2b Mon Sep 17 00:00:00 2001 From: ivan Date: Fri, 9 Mar 2007 08:58:56 +0000 Subject: removing old 5.005 install stuff --- install/5.005/DBD-Pg-1.22-fixvercmp/Changes | 352 ---- install/5.005/DBD-Pg-1.22-fixvercmp/MANIFEST | 38 - install/5.005/DBD-Pg-1.22-fixvercmp/Makefile.PL | 83 - install/5.005/DBD-Pg-1.22-fixvercmp/Pg.h | 46 - install/5.005/DBD-Pg-1.22-fixvercmp/Pg.pm | 1913 ------------------ install/5.005/DBD-Pg-1.22-fixvercmp/Pg.xs | 644 ------- install/5.005/DBD-Pg-1.22-fixvercmp/README | 166 -- install/5.005/DBD-Pg-1.22-fixvercmp/README.win32 | 63 - install/5.005/DBD-Pg-1.22-fixvercmp/dbd-pg.pod | 411 ---- install/5.005/DBD-Pg-1.22-fixvercmp/dbdimp.c | 2024 -------------------- install/5.005/DBD-Pg-1.22-fixvercmp/dbdimp.h | 81 - .../5.005/DBD-Pg-1.22-fixvercmp/eg/ApacheDBI.pl | 70 - install/5.005/DBD-Pg-1.22-fixvercmp/eg/lotest.pl | 74 - .../DBD-Pg-1.22-fixvercmp/eg/notify_test.patch | 82 - install/5.005/DBD-Pg-1.22-fixvercmp/t/00basic.t | 10 - install/5.005/DBD-Pg-1.22-fixvercmp/t/01connect.t | 26 - .../5.005/DBD-Pg-1.22-fixvercmp/t/01constants.t | 25 - install/5.005/DBD-Pg-1.22-fixvercmp/t/01setup.t | 38 - install/5.005/DBD-Pg-1.22-fixvercmp/t/02prepare.t | 84 - install/5.005/DBD-Pg-1.22-fixvercmp/t/03bind.t | 85 - install/5.005/DBD-Pg-1.22-fixvercmp/t/04execute.t | 113 -- install/5.005/DBD-Pg-1.22-fixvercmp/t/05fetch.t | 131 -- .../5.005/DBD-Pg-1.22-fixvercmp/t/06disconnect.t | 31 - install/5.005/DBD-Pg-1.22-fixvercmp/t/07reuse.t | 28 - install/5.005/DBD-Pg-1.22-fixvercmp/t/08txn.t | 102 - .../5.005/DBD-Pg-1.22-fixvercmp/t/09autocommit.t | 68 - install/5.005/DBD-Pg-1.22-fixvercmp/t/11quoting.t | 50 - .../5.005/DBD-Pg-1.22-fixvercmp/t/12placeholders.t | 125 -- install/5.005/DBD-Pg-1.22-fixvercmp/t/13pgtype.t | 43 - install/5.005/DBD-Pg-1.22-fixvercmp/t/15funct.t | 353 ---- install/5.005/DBD-Pg-1.22-fixvercmp/t/99cleanup.t | 24 - .../5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info.pm | 1167 ----------- .../t/lib/App/Info/Handler.pm | 305 --- .../t/lib/App/Info/Handler/Prompt.pm | 170 -- .../DBD-Pg-1.22-fixvercmp/t/lib/App/Info/RDBMS.pm | 55 - .../t/lib/App/Info/RDBMS/PostgreSQL.pm | 730 ------- .../t/lib/App/Info/Request.pm | 287 --- .../DBD-Pg-1.22-fixvercmp/t/lib/App/Info/Util.pm | 456 ----- .../5.005/DBIx-DBSchema-0.23-5.005kludge/Changes | 62 - .../DBIx-DBSchema-0.23-5.005kludge/DBSchema.pm | 367 ---- .../DBSchema/ColGroup.pm | 141 -- .../DBSchema/ColGroup/Index.pm | 37 - .../DBSchema/ColGroup/Unique.pm | 38 - .../DBSchema/Column.pm | 300 --- .../DBIx-DBSchema-0.23-5.005kludge/DBSchema/DBD.pm | 113 -- .../DBSchema/DBD/Pg.pm | 175 -- .../DBSchema/DBD/Sybase.pm | 141 -- .../DBSchema/DBD/mysql.pm | 126 -- .../DBSchema/Table.pm | 471 ----- .../5.005/DBIx-DBSchema-0.23-5.005kludge/MANIFEST | 19 - .../DBIx-DBSchema-0.23-5.005kludge/MANIFEST.SKIP | 1 - .../DBIx-DBSchema-0.23-5.005kludge/Makefile.PL | 11 - .../5.005/DBIx-DBSchema-0.23-5.005kludge/README | 42 - install/5.005/DBIx-DBSchema-0.23-5.005kludge/TODO | 6 - .../DBIx-DBSchema-0.23-5.005kludge/t/load-mysql.t | 5 - .../DBIx-DBSchema-0.23-5.005kludge/t/load-pg.t | 12 - .../5.005/DBIx-DBSchema-0.23-5.005kludge/t/load.t | 5 - 57 files changed, 12625 deletions(-) delete mode 100644 install/5.005/DBD-Pg-1.22-fixvercmp/Changes delete mode 100644 install/5.005/DBD-Pg-1.22-fixvercmp/MANIFEST delete mode 100644 install/5.005/DBD-Pg-1.22-fixvercmp/Makefile.PL delete mode 100644 install/5.005/DBD-Pg-1.22-fixvercmp/Pg.h delete mode 100644 install/5.005/DBD-Pg-1.22-fixvercmp/Pg.pm delete mode 100644 install/5.005/DBD-Pg-1.22-fixvercmp/Pg.xs delete mode 100644 install/5.005/DBD-Pg-1.22-fixvercmp/README delete mode 100644 install/5.005/DBD-Pg-1.22-fixvercmp/README.win32 delete mode 100644 install/5.005/DBD-Pg-1.22-fixvercmp/dbd-pg.pod delete mode 100644 install/5.005/DBD-Pg-1.22-fixvercmp/dbdimp.c delete mode 100644 install/5.005/DBD-Pg-1.22-fixvercmp/dbdimp.h delete mode 100755 install/5.005/DBD-Pg-1.22-fixvercmp/eg/ApacheDBI.pl delete mode 100644 install/5.005/DBD-Pg-1.22-fixvercmp/eg/lotest.pl delete mode 100644 install/5.005/DBD-Pg-1.22-fixvercmp/eg/notify_test.patch delete mode 100644 install/5.005/DBD-Pg-1.22-fixvercmp/t/00basic.t delete mode 100644 install/5.005/DBD-Pg-1.22-fixvercmp/t/01connect.t delete mode 100644 install/5.005/DBD-Pg-1.22-fixvercmp/t/01constants.t delete mode 100644 install/5.005/DBD-Pg-1.22-fixvercmp/t/01setup.t delete mode 100644 install/5.005/DBD-Pg-1.22-fixvercmp/t/02prepare.t delete mode 100644 install/5.005/DBD-Pg-1.22-fixvercmp/t/03bind.t delete mode 100644 install/5.005/DBD-Pg-1.22-fixvercmp/t/04execute.t delete mode 100644 install/5.005/DBD-Pg-1.22-fixvercmp/t/05fetch.t delete mode 100644 install/5.005/DBD-Pg-1.22-fixvercmp/t/06disconnect.t delete mode 100644 install/5.005/DBD-Pg-1.22-fixvercmp/t/07reuse.t delete mode 100644 install/5.005/DBD-Pg-1.22-fixvercmp/t/08txn.t delete mode 100644 install/5.005/DBD-Pg-1.22-fixvercmp/t/09autocommit.t delete mode 100644 install/5.005/DBD-Pg-1.22-fixvercmp/t/11quoting.t delete mode 100644 install/5.005/DBD-Pg-1.22-fixvercmp/t/12placeholders.t delete mode 100644 install/5.005/DBD-Pg-1.22-fixvercmp/t/13pgtype.t delete mode 100644 install/5.005/DBD-Pg-1.22-fixvercmp/t/15funct.t delete mode 100644 install/5.005/DBD-Pg-1.22-fixvercmp/t/99cleanup.t delete mode 100644 install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info.pm delete mode 100644 install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/Handler.pm delete mode 100644 install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/Handler/Prompt.pm delete mode 100644 install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/RDBMS.pm delete mode 100644 install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/RDBMS/PostgreSQL.pm delete mode 100644 install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/Request.pm delete mode 100644 install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/Util.pm delete mode 100644 install/5.005/DBIx-DBSchema-0.23-5.005kludge/Changes delete mode 100644 install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema.pm delete mode 100644 install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/ColGroup.pm delete mode 100644 install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/ColGroup/Index.pm delete mode 100644 install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/ColGroup/Unique.pm delete mode 100644 install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/Column.pm delete mode 100644 install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/DBD.pm delete mode 100644 install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/DBD/Pg.pm delete mode 100755 install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/DBD/Sybase.pm delete mode 100644 install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/DBD/mysql.pm delete mode 100644 install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/Table.pm delete mode 100644 install/5.005/DBIx-DBSchema-0.23-5.005kludge/MANIFEST delete mode 100644 install/5.005/DBIx-DBSchema-0.23-5.005kludge/MANIFEST.SKIP delete mode 100644 install/5.005/DBIx-DBSchema-0.23-5.005kludge/Makefile.PL delete mode 100644 install/5.005/DBIx-DBSchema-0.23-5.005kludge/README delete mode 100644 install/5.005/DBIx-DBSchema-0.23-5.005kludge/TODO delete mode 100644 install/5.005/DBIx-DBSchema-0.23-5.005kludge/t/load-mysql.t delete mode 100644 install/5.005/DBIx-DBSchema-0.23-5.005kludge/t/load-pg.t delete mode 100644 install/5.005/DBIx-DBSchema-0.23-5.005kludge/t/load.t 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 c3456283e..000000000 --- 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 ] - - 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 ] -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 - - Properly reset transaction status after failed transaction when - autocommit is off. Properly report transaction failure message. - Kai - - 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 - - - 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 - - - Pg.pm, dbdimp.c: Applied patch from - Thomas A. Lowery concerning metadata - in table_info and so forth. - -2002-03-06 Jeffrey W. Baker - - Pg.pm (quote): Applied patch from David Wheeler - 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 - -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 - 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 , - 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 - - correct the recognition of primary keys in - table_attributes(). Patch from Brian Powell - . - - applied patch from David D. Kilzer - 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 . - -0.94 Jul 07, 2000 - - applied patch from Rudy Lippan - which fixes a memory-leak with failed connections. - - applied patch from Hein Roehrig - which fixes a bug with escaping a backslash except for - octal presentation - - applied patch from Francis J. Lacoste - 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 . - - 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 . - - fix type definitions for type_info_all(). - bug spotted by "carlos" . - - now the Pg-specific quote() method also evaluates the - data-type paramater. - -0.92 Jun 16, 1999 - - proposal from Philip Warner : - 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 - - bug-fix for escaped 's spotted by Hankin - - 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 : - 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 - - 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 : - 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 : - using traces together with undef in place-holders dumped - core. - -0.82 June 20, 1998 - - bug-fix from Matthew Lenz : - corrected include path in Makefile.PL . - - added 'use strict;' to test.pl - -0.81 June 13, 1998 - - bug-fix from Rolf Grossmann : - 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 - quote method also doubles backslash. - -0.72 April 20, 1998 - - applied patch from Michael J Schout - which fixed the bug with queries containing the cast - operator. - - applied patch from "Irving Reid" - which fixed a memory leak. - -0.71 April 04, 1998 - - applied patch from "Irving Reid" - 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 7d1b7000f..000000000 --- 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 0633280c7..000000000 --- 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 b77a9f8b2..000000000 --- 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 -#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 /* installed by the DBI module */ - -#include "dbdimp.h" /* read in our implementation details */ - -#include /* 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 284e56346..000000000 --- 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 - -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. - -For authentication with username and password appropriate entries have to be -made in pg_hba.conf. Please refer to the L and the L -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 - - @driver_names = DBI->available_drivers; - -Implemented by DBI, no driver-specific impact. - -=item B - - @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 - - 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 - - $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 - - $str = $h->errstr; - -Supported by the driver as proposed by DBI. It returns the PQerrorMessage -related to the current handle. - -=item B - - $str = $h->state; - -This driver does not (yet) support the state method. - -=item B - - $h->trace($trace_level, $trace_filename); - -Implemented by DBI, no driver-specific impact. - -=item B - - $h->trace_msg($message_text); - -Implemented by DBI, no driver-specific impact. - -=item B - -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 (boolean, inherited) - -Implemented by DBI, no driver-specific impact. - -=item B (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 (integer, read-only) - -Implemented by DBI, no driver-specific impact. - -=item B (integer, read-only) - -Implemented by DBI, no driver-specific impact. - -=item B (hash ref) - -Implemented by DBI, no driver-specific impact. - -=item B (boolean, inherited) - -Not used by this driver. - -=item B (boolean) - -Implemented by DBI, no driver-specific impact. - -=item B (boolean, inherited) - -Implemented by DBI, no driver-specific impact. - -=item B (boolean, inherited) - -Implemented by DBI, no driver-specific impact. - -=item B (boolean, inherited) - -Implemented by DBI, no driver-specific impact. - -=item B (boolean, inherited) - -Supported by the driver as proposed by DBI. This method is similar to the -SQL-function RTRIM. - -=item B (integer, inherited) - -Implemented by DBI, not used by the driver. - -=item B (boolean, inherited) - -Implemented by DBI, not used by the driver. - -=item B (boolean, inherited) - -Implemented by DBI, no driver-specific impact. - -=item B - -Implemented by DBI, no driver-specific impact. - -=back - -=head1 DBI DATABASE HANDLE OBJECTS - -=head2 Database Handle Methods - -=over 4 - -=item B - - @row_ary = $dbh->selectrow_array($statement, \%attr, @bind_values); - -Implemented by DBI, no driver-specific impact. - -=item B - - $ary_ref = $dbh->selectrow_arrayref($statement, \%attr, @bind_values); - -Implemented by DBI, no driver-specific impact. - -=item B - - $hash_ref = $dbh->selectrow_hashref($statement, \%attr, @bind_values); - -Implemented by DBI, no driver-specific impact. - -=item B - - $ary_ref = $dbh->selectall_arrayref($statement, \%attr, @bind_values); - -Implemented by DBI, no driver-specific impact. - -=item B - - $hash_ref = $dbh->selectall_hashref($statement, $key_field); - -Implemented by DBI, no driver-specific impact. - -=item B - - $ary_ref = $dbh->selectcol_arrayref($statement, \%attr, @bind_values); - -Implemented by DBI, no driver-specific impact. - -=item B - - $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 - - $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 - - $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 - - $rc = $dbh->commit; - -Supported by the driver as proposed by DBI. See also the notes about -B elsewhere in this document. - -=item B - - $rc = $dbh->rollback; - -Supported by the driver as proposed by DBI. See also the notes about -B elsewhere in this document. - -=item B - - $rc = $dbh->disconnect; - -Supported by the driver as proposed by DBI. - -=item B - - $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 - - $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 - - $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 - - @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 = $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. - -=item B - - @type_info = $dbh->type_info($data_type); - -Implemented by DBI, no driver-specific impact. - -=item B - - $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 The undocumented (and invalid) support for the C data -type is officially deprecated. Use C with C instead: - - $rv = $sth->bind_param($param_num, $bind_value, - { pg_type => DBD::Pg::PG_BYTEA }); - -=back - -=head2 Database Handle Attributes - -=over 4 - -=item B (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 -elsewhere in this document. - -=item B (handle) - -Implemented by DBI, no driver-specific impact. - -=item B (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 (integer) - -Implemented by DBI, not used by the driver. - -=item B (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 (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. This is only relevant under -perl 5.8 and higher. - -B: This attribute is experimental and may be subject to change. - -=item B (integer, read-only) - -Constant to be used for the mode in lo_creat and lo_open. - -=item B (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 - - $rv = $sth->bind_param($param_num, $bind_value, \%attr); - -Supported by the driver as proposed by DBI. - -B The undocumented (and invalid) support for the C -SQL type is officially deprecated. Use C instead: - - $rv = $sth->bind_param($param_num, $bind_value, - { pg_type => DBD::Pg::PG_BYTEA }); - -=item B - -Not supported by this driver. - -=item B - - $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 - - $ary_ref = $sth->fetchrow_arrayref; - -Supported by the driver as proposed by DBI. - -=item B - - @ary = $sth->fetchrow_array; - -Supported by the driver as proposed by DBI. - -=item B - - $hash_ref = $sth->fetchrow_hashref; - -Supported by the driver as proposed by DBI. - -=item B - - $tbl_ary_ref = $sth->fetchall_arrayref; - -Implemented by DBI, no driver-specific impact. - -=item B - - $rc = $sth->finish; - -Supported by the driver as proposed by DBI. - -=item B - - $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 - - $rc = $sth->bind_col($column_number, \$var_to_bind, \%attr); - -Supported by the driver as proposed by DBI. - -=item B - - $rc = $sth->bind_columns(\%attr, @list_of_refs_to_vars_to_bind); - -Supported by the driver as proposed by DBI. - -=item B - - $rows = $sth->dump_results($maxlen, $lsep, $fsep, $fh); - -Implemented by DBI, no driver-specific impact. - -=item B - - $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 (integer, read-only) - -Implemented by DBI, no driver-specific impact. - -=item B (integer, read-only) - -Implemented by DBI, no driver-specific impact. - -=item B (array-ref, read-only) - -Supported by the driver as proposed by DBI. - -=item B (array-ref, read-only) - -Implemented by DBI, no driver-specific impact. - -=item B (array-ref, read-only) - -Implemented by DBI, no driver-specific impact. - -=item B (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 (array-ref, read-only) - -Not supported by the driver. - -=item B (array-ref, read-only) - -Not supported by the driver. - -=item B (array-ref, read-only) - -Not supported by the driver. - -=item B (string, read-only) - -Not supported by the driver. See the note about B elsewhere in this -document. - -=item B (string, read-only) - -Supported by the driver as proposed by DBI. - -=item B (integer, read-only) - -Not supported by the driver. - -=item B (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 (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 (integer, read-only) - -PostgreSQL specific attribute. It returns the OID of the last INSERT command. - -=item B (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 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 - -=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 , Jason -Stewart and Bruce Momjian - 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. - -=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 e5e4362ef..000000000 --- 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 7edebde9a..000000000 --- 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 - -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= - DBI_USER= - DBI_PASS= - -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" - -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 - - -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 3cbe6734a..000000000 --- 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 . - - -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 ccbbc6394..000000000 --- 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 - - - -=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 mailing list. - - -=head2 Supported Database Versions and Options - -The DBD-Pg-0.92 module supports Postgresql 6.5. - - -=head2 Connect Syntax - -The Cconnect()> Data Source Name, or I, 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 Cconnect()> 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 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 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 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 and I 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. - - -=head2 Other Data Handling issues - -The C driver supports the C 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 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 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, 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 and C. Typical usage: - - INSERT INTO table (k, v) VALUES (nextval('seq_name'), ?); - -To get the value just inserted, you can use the corresponding C -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 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 does not support stored procedures. - - -=head2 Table Metadata - -C supports the C method. - -The I table contains detailed information about all columns -of all the tables in the database, one row per table. - -The I table contains detailed information about all indexes in -the database, one row per index. - -Primary keys are implemented as unique indexes. See I above. - - -=head2 Driver-specific Attributes and Methods - -There are no significant C driver-specific database handle attributes. - -C has the following driver-specific statement handle attributes: - -=over 8 - -=item I - -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 - -Returns a reference to an array of strings for each column. The string -shows the name of the data type. - -=item I - -Returns the OID of the last INSERT command. - -=item I - -Returns the name of the last command type. Possible types are: INSERT, -DELETE, UPDATE, SELECT. - -=back - - -C has no private methods. - - -=head2 Positioned updates and deletes - -Postgresql does not support positioned updates or deletes. - - -=head2 Differences from the DBI Specification - -C has no significant differences in behavior from the -current DBI specification. - -Note that C does not fully parse the statement until -it's executed. Thus attributes like I<$sth-E{NUM_OF_FIELDS}> are not -available until after C<$sth-Eexecute> 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 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 55f4ee726..000000000 --- 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 58c105bfc..000000000 --- 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 b084f70f5..000000000 --- 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, - "

Testing Module DBI

", - "

><% $custnum %>>><% ucfirst($status) %>><% ucfirst($status) %> ><% "$last, $first" %> ><% $pcompany %>
", - "", - "", - "", - "", - "", - "", - "", - "", - "", - "", - "", - "", - "
Enter the data source: ", $query->textfield(-name=>'data_source', -size=>40, -default=>'dbi:Pg:dbname=template1'), "
Enter the user name: ", $query->textfield(-name=>'username'), "
Enter the password: ", $query->textfield(-name=>'auth'), "
Enter the select command: ", $query->textfield(-name=>'cmd', -size=>40), "

", - "

", $query->submit(-value=>'Submit'), "
", - $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 "

\n"; - while ($ary_ref = $sth->fetchrow_arrayref) { - print "\n"; - } - print "
", join("", @$ary_ref), "

\n"; - $sth->finish; - } else { - print "

", $DBI::errstr, "

\n"; - } - $dbh->disconnect; - } else { - print "

", $DBI::errstr, "

\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 6192c4926..000000000 --- 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 6f8acf800..000000000 --- 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 1c0cb2862..000000000 --- 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 be17b5087..000000000 --- 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 09907e9d4..000000000 --- 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 d0b57a345..000000000 --- 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 = <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 373aca27d..000000000 --- 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 = <prepare($sql), - "prepare: $sql" - ); - -$sql = <prepare($sql), - "prepare: $sql" - ); - -$sql = <prepare($sql), - "prepare: $sql" - ); - -$sql = <prepare($sql), - "prepare: $sql" - ); - -$sql = <prepare($sql), - "prepare: $sql" - ); - -$sql = <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 df7c8843e..000000000 --- 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 = <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 = <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 = <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 964387802..000000000 --- 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 = <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 = <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 b6f8f66d0..000000000 --- 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 = <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 = <prepare($sql); -$sth->execute(); - -$rows = 0; -while (my ($id, $name) = $sth->fetchrow_array()) { - $rows++; -} -$sth->finish(); - -ok($rows == 0, - 'fetch zero rows' - ); - -$sql = <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 = <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 5d76bc0a8..000000000 --- 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 d09dfc010..000000000 --- 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 467aa3153..000000000 --- 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 9b1b69fc6..000000000 --- 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 afec9632a..000000000 --- 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 bd79ea72b..000000000 --- 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 = <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 = <prepare($sql); - -$sth->execute("\\'?:"); - -($retr) = $sth->fetchrow_array(); -ok((defined($retr) && $retr eq "\\'?:"), - 'execute with ? placeholder' - ); - -$sql = <prepare($sql); - -$sth->execute("\\'?:"); - -($retr) = $sth->fetchrow_array(); -ok((defined($retr) && $retr eq "\\'?:"), - 'execute with :1 placeholder' - ); - -$sql = <prepare($sql); - -eval { - local $dbh->{PrintError} = 0; - $sth->execute('foo'); -}; -ok($@, - 'execute with quoted ?' - ); - -$sql = <prepare($sql); - -eval { - local $dbh->{PrintError} = 0; - $sth->execute('foo'); -}; -ok($@, - 'execute with quoted :1' - ); - -$sql = <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 8db819ee9..000000000 --- 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 1bc2cf961..000000000 --- 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 e7563abaa..000000000 --- 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 417247fe7..000000000 --- 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 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 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 and L). -See L 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 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, 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 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 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 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 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 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 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 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 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 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 in order to offer easy access to -commonly-used methods from that class, e.g., C. 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 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 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 -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. The parameters are -as follows: - -=over 4 - -=item key - -The C 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 as was returned by the first call, and no -handlers will be activated. Typical values are "version" and "lib_dir". - -=item prompt - -The C 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 method -and the C parameter. The result would be something like "Enter a valid -FooApp version". The C parameter value will be stored in the -C 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 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. The C parameter code reference will be stored in the -C 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 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 identified as invalid, a message to display might -be something like "Invalid directory path". Note that if the C -parameter is not provided, App::Info will supply the generic error message -"Invalid value". This value will be stored in the C 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, 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, its use is quite similar -to that of C. Its parameters are as follows: - -=over - -=item key - -Same as for C, 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 as was -returned by the first call for a given key. - -=item prompt - -Same as for C. Although C is called to confirm a value, -typically the prompt should request the relevant value, just as for -C. The difference is that the handler I use the C -parameter as the default should the user not provide a value. The C -parameter will be stored in the C 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 attribute of the -App::Info::Request object passed to event handlers. - -=item callback - -Same as for C. Because the user can enter data to replace the -default value provided via the C parameter, you might want to validate -it. Use this code reference to do so. The callback will be stored in the -C attribute of the App::Info::Request object passed to event -handlers. - -=item error - -Same as for C: an error message to display in the event that a -value entered by the user isn't validated by the C code reference. -This value will be stored in the C 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 and, if -necessary, C 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 method to display a status message to let the -user know what we're doing. Then we used the C 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 -method call. But rather than call the C 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 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 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 -and when to use C. 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 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 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. And of course, C 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 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 method. The C 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 will return the same value that was returned -the first time it was called. Of course, thanks to the C parameter in the -call to C, we could have have tried to enumerate the version number -every time, as C will return the same value every time it is called -(as, indeed, should C<_find_version()>. But by checking for the C 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 method. Thus, the C 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 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 method is quite similar to that of C. 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, but the user may really be interested in F. -Thus the C 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 or C 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 $arg> syntax as is used by -App::Info's C 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 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 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 constructor, always call C. This -ensures that the event handling methods methods defined by the App::Info base -classes (e.g., C) 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 for complete -documentation of its interface. - -=item * - -Use the C event triggering method to send messages to users of your -subclass. - -=item * - -Use the C event triggering method to alert users of unexpected -conditions. Fatal errors should still be fatal; use C to throw -exceptions for fatal errors. - -=item * - -Use the C 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 event triggering method when a core piece of data is -known (such as the location of an executable in the C constructor) and -you need to make sure that you have the I information. - -=item * - -Be sure to implement B 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. - -=head1 AUTHOR - -David Wheeler > - -=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 - -=item L - -=item L - -=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 - -=item L - -=item L - -=item L - -=back - -L provides utility methods for App::Info -subclasses. - -L 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 - -=item L - -=item L - -=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 65416a84a..000000000 --- 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 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 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 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 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 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. 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 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 constructor and the -C method. The C 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 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 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 usage. - -The final step in creating a new App::Info event handler is to implement the -C 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 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-Evalue>) as a default. - -=item * - -For unknown and confirm events, you are expected to call C<$req-Ecallback> -and pass in the new value. If C<$req-Ecallback> returns a false value, you -are expected to display the error message in C<$req-Eerror> and prompt the -user again. Note that C<$req-Evalue> calls C<$req-Ecallback> -internally, and thus assigns the value and returns true if -C<$req-Ecallback> returns true, and does not assign the value and returns -false if C<$req-Ecallback> returns false. - -=item * - -For unknown and confirm events, if you've collected a new value and -C<$req-Ecallback> returns true for that value, you are expected to assign -the value by passing it to C<$req-Evalue>. 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 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. - -=head1 AUTHOR - -David Wheeler > - -=head1 SEE ALSO - -L thoroughly documents the client interface for setting -event handlers, as well as the event triggering interface for App::Info -concrete subclasses. - -L documents the interface for the -request objects passed to App::Info::Handler C 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 - -=item L - -=item L - -=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 47edd7802..000000000 --- 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 and then accepting a new value from C. 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 and print error event messages -to C. For more interesting info and error event handling, see -L and -L. - -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 = ; - 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. - -=head1 AUTHOR - -David Wheeler > - -=head1 SEE ALSO - -L documents the event handling interface. - -L handles events by -passing their messages Carp module functions. - -L handles events by -printing their messages to a file handle. - -L 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 504d5700d..000000000 --- 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 for a complete description -and L 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. - -=head1 AUTHOR - -David Wheeler > - -=head1 SEE ALSO - -L, -L - -=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 aef326cca..000000000 --- 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 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, C, C, -C, and C, 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 for -a complete description of argument parameters. - -When it called, C searches the file system for the F -application. If found, F will be called by the object methods below -to gather the data necessary for each. If F cannot be found, then -PostgreSQL is assumed not to be installed, and each of the object methods will -return C. - -App::Info::RDBMS::PostgreSQL searches for F along your path, as -defined by Cpath>. 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 - -=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 application on the file system -as found when C 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 - -=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 - -=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 returns "7.1.2", then this method returns "7". - -B - -=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 returns "7.1.2", then this method returns "2". - -B - -=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 returns "7.1.2", then this method returns "1". - -B - -=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 - -=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 - -=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 - -=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 - -=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. - -=head1 AUTHOR - -David Wheeler > based on code by Sam -Tregar >. - -=head1 SEE ALSO - -L documents the event handling interface. - -L is the App::Info::RDBMS::PostgreSQL -parent class. - -L is the L driver for connecting to PostgreSQL -databases. - -L 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 c02c97ba2..000000000 --- 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 method of App::Info event -handlers. Generally, this class will be of most interest to App::Info::Handler -subclass implementers. - -The L 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 -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 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 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 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 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 -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 method. - -Note that the C method itself calls C 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 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 attempts to store the the argument as a -new value. However, C calls C on the new value, and if -C returns false, then C returns false and does not store -the new value. If C returns true, on the other hand, then -C 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. - -=head1 AUTHOR - -David Wheeler > - -=head1 SEE ALSO - -L documents the event triggering methods and how they -construct App::Info::Request objects to pass to event handlers. - -L documents how to create custom event -handlers, which must make use of the App::Info::Request object passed to their -C 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 - -=item L - -=item L - -=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 55bb333cd..000000000 --- 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 and adds its own methods in -order to offer utility methods to L 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, 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 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 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 -or F, and it could be in any of the following paths: -F, F, F. 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 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, 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, while C would return that value, -C would return F 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, 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 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 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 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, 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 () { - # 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, 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 for each -of them would be wasteful, as each call to C opens the file and -parses it. With C, 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 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, C 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 = ) { - 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. - -=head1 AUTHOR - -David Wheeler > - -=head1 SEE ALSO - -L, L, -L -L - -=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 f413bd959..000000000 --- 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 - and Mitchell J. Friedman - . - - 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 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 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 fc4916df1..000000000 --- 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, "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('',); #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 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 - -Charles Shapiro and Mitchell Friedman - 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, L, -L, L, -L, L, -L, L, L, -L - -=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 ceeb223ca..000000000 --- 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.) - -=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 - -=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, L, -L, L, L, L, -L - -=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 1a92baae1..000000000 --- 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::ColGroup::Index -inherits from DBIx::DBSchema::ColGroup. - -=head1 BUGS - -Is this empty subclass needed? - -=head1 SEE ALSO - -L, L, -L, L, L - -=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 450043fdf..000000000 --- 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::ColGroup:Unique -inherits from DBIx::DBSchema::ColGroup. - -=head1 BUGS - -Is this empty subclass needed? - -=head1 SEE ALSO - -L, L, -L, L, L - -=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 4e26646e7..000000000 --- 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). - -=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 is the name of the column. B is the SQL -data type. B is the nullability of the column (intrepreted using Perl's -rules for truth, with one exception: `NOT NULL' is false). B is the -SQL length of the column. B is the default value of the column. -B 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 - -=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, L, L, L - -=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 a4c60003e..000000000 --- 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), 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 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 and -L. - -=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 and -L. - -=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 - -=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, L, L, -L, L, L, L, -L - -=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 018b89028..000000000 --- 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(<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(<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(<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(<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(<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(<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 - -=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, L, L, L - -=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 4a740693a..000000000 --- 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(<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 -(courtesy of Ivan Kohler ) - -Mitchell Friedman - -Bernd Dulfer - -=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 method does not yet work. - -=head1 SEE ALSO - -L, L, L, L - -=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 f3804dd28..000000000 --- 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 - -=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, L, L, L - -=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 2d6272ecb..000000000 --- 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). INDEX is a -DBIx::DBSchema::ColGroup::Index object (see -L). COLUMNS is a reference to an array of -DBIx::DBSchema::Column objects (see L). - -=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) 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 - -Thanks to Mark Ethan Trostler 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, L, -L, L, L - -=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 b04de251f..000000000 --- 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 ae335e78a..000000000 --- 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 a10e4daf8..000000000 --- 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 8911ea4ca..000000000 --- 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 . - -A mailing list is available. Send a blank message to -. - -Homepage: - -$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 e75850bdb..000000000 --- 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 78818c10d..000000000 --- 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 93fcf4abb..000000000 --- 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 67ea44b24..000000000 --- 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"; -- cgit v1.2.1 From 1ca1ac31d87eef58e786c0edb9e85d18b9febed7 Mon Sep 17 00:00:00 2001 From: jeff Date: Fri, 9 Mar 2007 17:11:35 +0000 Subject: pop import tool --- bin/svc_acct_pop.import | 59 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 59 insertions(+) create mode 100755 bin/svc_acct_pop.import diff --git a/bin/svc_acct_pop.import b/bin/svc_acct_pop.import new file mode 100755 index 000000000..9e3d38bfe --- /dev/null +++ b/bin/svc_acct_pop.import @@ -0,0 +1,59 @@ +#!/usr/bin/perl + +use strict; +use Text::CSV_XS; +use FS::UID qw(adminsuidsetup); +use FS::svc_acct_pop; + +my @fields = qw( ac loc state city exch ); +my $fixup = sub { + my $hash = shift; + $hash->{ac} =~ /^\s*(\d{3})\s*$/; + $hash->{ac} = $1; + $hash->{loc} =~ /^\s*(\d{3})(\d{4})\s*$/; + $hash->{exch} = $1; + $hash->{loc} = $2; + $hash->{state} =~ /^\s*(\S{0,2})\s*$/; + $hash->{state} = $1; + $hash->{city} =~ /^\s*(.*?)\s*$/; + $hash->{city} = $1; + + }; + +my $user = shift or usage(); +adminsuidsetup $user; + +my $file = shift or usage(); +my $csv = new Text::CSV_XS; + +open(FH, $file) or die "cannot open $file: $!"; + +sub usage { + die "Usage:\n\n svc_acct_pop.import user popfile.csv\n\n"; +} + +### + +my $line; +while ( defined($line=) ) { + chomp $line; + + $line &= "\177" x length($line); # i hope this isn't really necessary + $csv->parse($line) + or die "cannot parse: " . $csv->error_input(); + + my @values = $csv->fields(); + my %hash; + foreach my $field (@fields) { + $hash{$field} = shift @values; + } + + &{$fixup}(\%hash); + + my $svc_acct_pop = new FS::svc_acct_pop { %hash }; + + #my $error = $svc_acct_pop->check; + my $error = $svc_acct_pop->insert; + die $error if $error; + +} -- cgit v1.2.1 From fe5f1d41372b0871120e6d2b4ebc9e2c1fd62726 Mon Sep 17 00:00:00 2001 From: khoff Date: Sat, 10 Mar 2007 00:11:50 +0000 Subject: Added ut_coord and ut_coordn for FS::svc_broadband. --- FS/FS/Record.pm | 86 ++++++++++++++++++++++++++++++++++++++++++++++++++ FS/FS/svc_broadband.pm | 11 ++----- 2 files changed, 88 insertions(+), 9 deletions(-) diff --git a/FS/FS/Record.pm b/FS/FS/Record.pm index 94cc356e5..e43829417 100644 --- a/FS/FS/Record.pm +++ b/FS/FS/Record.pm @@ -1612,6 +1612,92 @@ sub ut_ipn { } } +=item ut_coord COLUMN [ LOWER [ UPPER ] ] + +Check/untaint coordinates. +Accepts the following forms: +DDD.DDDDD +-DDD.DDDDD +DDD MM.MMM +-DDD MM.MMM +DDD MM SS +-DDD MM SS +DDD MM MMM +-DDD MM MMM + +The "DDD MM SS" and "DDD MM MMM" are potentially ambiguous. +The latter form (that is, the MMM are thousands of minutes) is +assumed if the "MMM" is exactly three digits or two digits > 59. + +To be safe, just use the DDD.DDDDD form. + +If LOWER or UPPER are specified, then the coordinate is checked +for lower and upper bounds, respectively. + +=cut + +sub ut_coord { + + my ($self, $field) = (shift, shift); + + my $lower = shift if scalar(@_); + my $upper = shift if scalar(@_); + my $coord = $self->getfield($field); + my $neg = $coord =~ s/^(-)//; + + my ($d, $m, $s) = (0, 0, 0); + + if ( + (($d) = ($coord =~ /^(\s*\d{1,3}(?:\.\d+)?)\s*$/)) || + (($d, $m) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2}(?:\.\d+))\s*$/)) || + (($d, $m, $s) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2})\s+(\d{1,3})\s*$/)) + ) { + $s = (((($s =~ /^\d{3}$/) or $s > 59) ? ($s / 1000) : ($s / 60)) / 60); + $m = $m / 60; + if ($m > 59) { + return "Invalid (coordinate with minutes > 59) $field: " + . $self->getfield($field); + } + + $coord = ($neg ? -1 : 1) * sprintf('%.8f', $d + $m + $s); + + if (defined($lower) and ($coord < $lower)) { + return "Invalid (coordinate < $lower) $field: " + . $self->getfield($field);; + } + + if (defined($upper) and ($coord > $upper)) { + return "Invalid (coordinate > $upper) $field: " + . $self->getfield($field);; + } + + $self->setfield($field, $coord); + return ''; + } + + return "Invalid (coordinate) $field: " . $self->getfield($field); + +} + +=item ut_coordn COLUMN [ LOWER [ UPPER ] ] + +Same as ut_coord, except optionally null. + +=cut + +sub ut_coordn { + + my ($self, $field) = (shift, shift); + + if ($self->getfield($field) =~ /^$/) { + return ''; + } else { + return $self->ut_coord($field, @_); + } + +} + + =item ut_domain COLUMN Check/untaint host and domain names. diff --git a/FS/FS/svc_broadband.pm b/FS/FS/svc_broadband.pm index 07821f9f5..473cd5705 100755 --- a/FS/FS/svc_broadband.pm +++ b/FS/FS/svc_broadband.pm @@ -200,8 +200,8 @@ sub check { || $self->ut_ipn('ip_addr') || $self->ut_hexn('mac_addr') || $self->ut_hexn('auth_key') - || $self->ut_sfloatn('latitude') - || $self->ut_sfloatn('longitude') + || $self->ut_coordn('latitude', -90, 90) + || $self->ut_coordn('longitude', -180, 180) || $self->ut_sfloatn('altitude') || $self->ut_textn('vlan_profile') ; @@ -210,13 +210,6 @@ sub check { if($self->speed_up < 0) { return 'speed_up must be positive'; } if($self->speed_down < 0) { return 'speed_down must be positive'; } - if($self->latitude < -90 || $self->latitude > 90) { - return 'latitude must be between -90 and 90'; - } - if($self->longitude < -180 || $self->longitude > 180) { - return 'longitude must be between -180 and 180'; - } - if (not($self->ip_addr) or $self->ip_addr eq '0.0.0.0') { my $next_addr = $self->addr_block->next_free_addr; if ($next_addr) { -- cgit v1.2.1 From 99816612a0f864a105aaa8663ce618e604128ed6 Mon Sep 17 00:00:00 2001 From: khoff Date: Sat, 10 Mar 2007 00:16:51 +0000 Subject: Added $FS::Record::no_update_diff flag to update "identical" records anyway. --- FS/FS/Record.pm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/FS/FS/Record.pm b/FS/FS/Record.pm index e43829417..0afe3ecd1 100644 --- a/FS/FS/Record.pm +++ b/FS/FS/Record.pm @@ -3,7 +3,7 @@ package FS::Record; use strict; use vars qw( $AUTOLOAD @ISA @EXPORT_OK $DEBUG $conf $me - %virtual_fields_cache $nowarn_identical ); + %virtual_fields_cache $nowarn_identical $no_update_diff ); use Exporter; use Carp qw(carp cluck croak confess); use File::CounterFile; @@ -30,6 +30,7 @@ $DEBUG = 0; $me = '[FS::Record]'; $nowarn_identical = 0; +$no_update_diff = 0; my $rsa_module; my $rsa_loaded; @@ -1041,7 +1042,7 @@ sub replace { my %diff = map { ($new->getfield($_) ne $old->getfield($_)) ? ($_, $new->getfield($_)) : () } $old->fields; - unless ( keys(%diff) ) { + unless (keys(%diff) || $no_update_diff ) { carp "[warning]$me $new -> replace $old: records identical" unless $nowarn_identical; return ''; -- cgit v1.2.1 From a79f6e69559ec438a178f73b8b4d51d6f12c0d36 Mon Sep 17 00:00:00 2001 From: ivan Date: Sun, 11 Mar 2007 04:13:27 +0000 Subject: move POP to browse template; whew, its paged --- httemplate/browse/svc_acct_pop.cgi | 129 +++++++++++++++++++------------------ 1 file changed, 65 insertions(+), 64 deletions(-) diff --git a/httemplate/browse/svc_acct_pop.cgi b/httemplate/browse/svc_acct_pop.cgi index 306d02afb..44bc651cf 100755 --- a/httemplate/browse/svc_acct_pop.cgi +++ b/httemplate/browse/svc_acct_pop.cgi @@ -1,73 +1,74 @@ -<% include("/elements/header.html",'Access Number Listing', menubar( 'Main Menu' => $p )) %> -Points of Presence

-Add new Access Number

-<% table() %> - - - City - State - Area code - Exchange - Local - Accounts - -% -%foreach my $svc_acct_pop ( sort { -% #$a->getfield('popnum') <=> $b->getfield('popnum') -% $a->state cmp $b->state || $a->city cmp $b->city -% || $a->ac <=> $b->ac || $a->exch <=> $b->exch || $a->loc <=> $b->loc -%} qsearch('svc_acct_pop',{}) ) { -% -% my $svc_acct_pop_link = $p . 'edit/svc_acct_pop.cgi?'. $svc_acct_pop->popnum; -% -% $accounts_sth->execute($svc_acct_pop->popnum) or die $accounts_sth->errstr; -% my $num_accounts = $accounts_sth->fetchrow_arrayref->[0]; -% -% my $svc_acct_link = $p. 'search/svc_acct.cgi?popnum='. $svc_acct_pop->popnum; -% -% +<% include( 'elements/browse.html', + 'title' => 'Access Numbers', + 'html_init' => $html_init, + 'name_singular' => 'access number', + 'query' => $query, + 'count_query' => $count_query, + 'header' => [ + '#', + 'City', + 'State', + 'Area code', + 'Exchange', + 'Local', + 'Accounts', + ], + 'fields' => [ + 'popnum', + 'city', + 'state', + 'ac', + 'exch', + 'loc', + $num_accounts_sub, + ], + 'align' => 'rllrrrr', + ) +%> +<%init> - - - <% $svc_acct_pop->popnum %> - - <% $svc_acct_pop->city %> - - <% $svc_acct_pop->state %> - - <% $svc_acct_pop->ac %> - - <% $svc_acct_pop->exch %> - - <% $svc_acct_pop->loc %> - - <% $num_accounts %> -% if ( $num_accounts ) { - -% } +die "access denied" + unless $FS::CurrentUser::CurrentUser->access_right('Configuration'); - active -% if ( $num_accounts ) { - -% } +my $html_init = qq! + Add new Access Number +

+!; - - -% } +my $query = { 'select' => '*, + ( SELECT COUNT(*) FROM svc_acct + WHERE svc_acct.popnum = svc_acct_pop.popnum + ) AS num_accounts + ', + 'table' => 'svc_acct_pop', + #'hashref' => { 'disabled' => '' }, + 'extra_sql' => 'ORDER BY state, city, ac, exch, loc', + }; +my $count_query = "SELECT COUNT(*) FROM svc_acct_pop"; # WHERE DISABLED IS NULL OR DISABLED = ''"; - - - - - -<%init> +my $svc_acct_pop_link = [ $p.'edit/svc_acct_pop.cgi?', 'popnum' ]; -die "access denied" - unless $FS::CurrentUser::CurrentUser->access_right('Configuration'); +my $svc_acct_link = $p. 'search/svc_acct.cgi?popnum='; -my $accounts_sth = dbh->prepare("SELECT COUNT(*) FROM svc_acct - WHERE popnum = ? ") - or die dbh->errstr; +my $num_accounts_sub = sub { + my $svc_acct_pop = shift; + [ + [ + { 'data' => ''. + $svc_acct_pop->get('num_accounts'). + '', + 'align' => 'right', + }, + { 'data' => 'active', + 'align' => 'left', + 'link' => ( $svc_acct_pop->get('num_accounts') + ? $svc_acct_link. $svc_acct_pop->popnum + : '' + ), + }, + ], + ]; +}; -- cgit v1.2.1 From 80d9bab5b9e16abfd7af996c79511bbf0c4a833b Mon Sep 17 00:00:00 2001 From: ivan Date: Tue, 13 Mar 2007 09:21:35 +0000 Subject: okay, so this should link to usernum now. but until then, it should be ->username, not ->name, eek. causing "Error: Error inserting cust_pkg_reason: ERROR: value to long for type character varying(32)" errors and will be harder to normalize back to usernum when we fix that --- FS/FS/cust_pkg.pm | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/FS/FS/cust_pkg.pm b/FS/FS/cust_pkg.pm index b2ef2a259..3e36ae242 100644 --- a/FS/FS/cust_pkg.pm +++ b/FS/FS/cust_pkg.pm @@ -1529,9 +1529,7 @@ sub order { sub insert_reason { my ($self, %options) = @_; - my $otaker = $FS::CurrentUser::CurrentUser->name; - $otaker = $FS::CurrentUser::CurrentUser->username - if (($otaker) eq "User, Legacy"); + my $otaker = $FS::CurrentUser::CurrentUser->username; my $cust_pkg_reason = new FS::cust_pkg_reason({ 'pkgnum' => $self->pkgnum, -- cgit v1.2.1 From 3f0a5f441a8b3c9b503e0f0e1f2a6d565baa8965 Mon Sep 17 00:00:00 2001 From: jeff Date: Wed, 14 Mar 2007 23:27:47 +0000 Subject: correcting ->replace on bill --- FS/FS/svc_acct.pm | 26 +++++++++++++++++++++++--- 1 file changed, 23 insertions(+), 3 deletions(-) diff --git a/FS/FS/svc_acct.pm b/FS/FS/svc_acct.pm index a06f4d797..0d612612b 100644 --- a/FS/FS/svc_acct.pm +++ b/FS/FS/svc_acct.pm @@ -41,7 +41,7 @@ use FS::cdr; @ISA = qw( FS::svc_Common ); -$DEBUG = 0; +$DEBUG = 1; $me = '[FS::svc_acct]'; #ask FS::UID to run this stuff for us later @@ -1671,6 +1671,7 @@ sub set_usage { my $dbh = dbh; my $reset = 0; + my %handyhash = (); foreach my $field (keys %$valueref){ $reset = 1 if $valueref->{$field}; $self->setfield($field, $valueref->{$field}); @@ -1682,9 +1683,28 @@ sub set_usage { ) ) ); + $handyhash{$field} = $self->getfield($field); + $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold'); + } + #my $error = $self->replace; #NO! we avoid the call to ->check for + #die $error if $error; #services not explicity changed via the UI + + my $sql = "UPDATE svc_acct SET " . + join (',', map { "$_ = ?" } (keys %handyhash) ). + " WHERE svcnum = ?"; + + warn "$me $sql\n" + if $DEBUG; + + if (scalar(keys %handyhash)) { + my $sth = $dbh->prepare( $sql ) + or die "Error preparing $sql: ". $dbh->errstr; + my $rv = $sth->execute((grep{$_} values %handyhash), $self->svcnum); + die "Error executing $sql: ". $sth->errstr + unless defined($rv); + die "Can't update usage for svcnum ". $self->svcnum + if $rv == 0; } - my $error = $self->replace; - die $error if $error; if ( $conf->exists("svc_acct-usage_unsuspend") && $reset ) { my $error = $self->cust_svc->cust_pkg->unsuspend; -- cgit v1.2.1 From f15bdd67797a4d32b6739ce371caa598bf96af32 Mon Sep 17 00:00:00 2001 From: jeff Date: Wed, 14 Mar 2007 23:30:59 +0000 Subject: turn debugging off --- FS/FS/svc_acct.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/FS/FS/svc_acct.pm b/FS/FS/svc_acct.pm index 0d612612b..3a625f791 100644 --- a/FS/FS/svc_acct.pm +++ b/FS/FS/svc_acct.pm @@ -41,7 +41,7 @@ use FS::cdr; @ISA = qw( FS::svc_Common ); -$DEBUG = 1; +$DEBUG = 0; $me = '[FS::svc_acct]'; #ask FS::UID to run this stuff for us later -- cgit v1.2.1 From 1d1259a3804c446e54dbf673781f873e9ce8da24 Mon Sep 17 00:00:00 2001 From: khoff Date: Thu, 15 Mar 2007 20:07:31 +0000 Subject: part_virtual_field.vfieldpart should be a serial. --- FS/FS/Schema.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/FS/FS/Schema.pm b/FS/FS/Schema.pm index d9d5f5a03..84078fad8 100644 --- a/FS/FS/Schema.pm +++ b/FS/FS/Schema.pm @@ -1195,7 +1195,7 @@ sub tables_hashref { 'part_virtual_field' => { 'columns' => [ - 'vfieldpart', 'int', '', '', '', '', + 'vfieldpart', 'serial', '', '', '', '', 'dbtable', 'varchar', '', 32, '', '', 'name', 'varchar', '', 32, '', '', 'check_block', 'text', 'NULL', '', '', '', -- cgit v1.2.1 From 9f5c327e1f126704ed5359fd61718945448785ed Mon Sep 17 00:00:00 2001 From: khoff Date: Thu, 15 Mar 2007 20:07:44 +0000 Subject: Escape the values in virtual field html form inputs. --- FS/FS/part_virtual_field.pm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/FS/FS/part_virtual_field.pm b/FS/FS/part_virtual_field.pm index 992d4496e..ea973bafc 100755 --- a/FS/FS/part_virtual_field.pm +++ b/FS/FS/part_virtual_field.pm @@ -4,6 +4,7 @@ use strict; use vars qw( @ISA ); use FS::Record qw( qsearchs qsearch ); use FS::Schema qw( dbdef ); +use CGI qw(escapeHTML); @ISA = qw( FS::Record ); @@ -244,7 +245,7 @@ sub widget { } } else { $text .= q!length) { $text .= q! SIZE="! . $self->length . q!"!; } -- cgit v1.2.1 From 16ff27b518da300ee5f8a907da8e1c67c2b9f1aa Mon Sep 17 00:00:00 2001 From: khoff Date: Thu, 15 Mar 2007 20:08:01 +0000 Subject: Added configurable error checks instead of stupid /^ERROR/ check. Commands can now be processed with Text::Template using [@-- --@] delimeters, in addition to evaling a double-quoted string. Cleaned up spurious debug output. --- FS/FS/part_export/router.pm | 147 ++++++++++++++++++++++++++++++++++++-------- 1 file changed, 123 insertions(+), 24 deletions(-) diff --git a/FS/FS/part_export/router.pm b/FS/FS/part_export/router.pm index e14b57932..42aa51cf6 100644 --- a/FS/FS/part_export/router.pm +++ b/FS/FS/part_export/router.pm @@ -21,17 +21,41 @@ It requires the following custom router fields: =item admin_prompt - A regular expression matching the router's prompt. See Net::Telnet for details. Only applies to the 'telnet' protocol. -=item admin_cmd_insert - Insert export command. See below. +=item admin_cmd_insert - Insert export command. -=item admin_cmd_delete - Delete export command. See below. +=item admin_cmd_insert_error - Insert export command error pattern. -=item admin_cmd_replace - Replace export command. See below. +=item admin_cmd_delete - Delete export command. -=item admin_cmd_suspend - Suspend export command. See below. +=item admin_cmd_delete_error - Delete export command error pattern. -=item admin_cmd_unsuspend - Unsuspend export command. See below. +=item admin_cmd_replace - Replace export command. -The admin_cmd_* virtual fields, if set, will be double quoted, eval'd, and executed on the router specified. +=item admin_cmd_replace_error - Replace export command error pattern. + +=item admin_cmd_suspend - Suspend export command. + +=item admin_cmd_suspend_error - Support export command error pattern. + +=item admin_cmd_unsuspend - Unsuspend export command. + +=item admin_cmd_unsuspend_error - Unsuspend export command error pattern. + +The admin_cmd_* virtual fields, if set, will be processed in one of two ways. After being expanded, they will be run on the router specified by admin_address using the protocol specified by admin_protocol. + +=over 4 + +=item Text::Template + +If the export command contains the string [@--, then it will be processed with Text::Template using [@-- and --@] as delimeters. + +=item eval + +If the export command does not contain [@--, it will be double quoted and eval'd. + +=back + +The admin_cmd_*_error virtual fields, if set, define a regular expression that will be matched against the output of the command being run. If the pattern matches, an error will be raised using the output as the error. If any of the required router virtual fields are not defined, then the export silently declines. @@ -44,7 +68,8 @@ The export itself takes no options. use strict; use vars qw(@ISA %info $me $DEBUG); use Tie::IxHash; -use String::ShellQuote; +use Text::Template; + use FS::Record qw(qsearchs); use FS::part_export; @@ -62,7 +87,7 @@ tie my %options, 'Tie::IxHash', 'svc' => 'svc_broadband', 'desc' => 'Send a command to a router.', 'options' => \%options, - 'notes' => 'Installation of Net::Telnet from CPAN is required for telnet connections. This export will execute if the following virtual fields are set on the router: admin_user, admin_password, admin_address, admin_timeout, admin_prompt. Option virtual fields are: admin_cmd_insert, admin_cmd_replace, admin_cmd_delete, admin_cmd_suspend, admin_cmd_unsuspend.', + 'notes' => 'Installation of Net::Telnet from CPAN is required for telnet connections. This export will execute if the following virtual fields are set on the router: admin_user, admin_password, admin_address, admin_timeout, admin_prompt. Option virtual fields are: admin_cmd_insert, admin_cmd_replace, admin_cmd_delete, admin_cmd_suspend, admin_cmd_unsuspend. See the module documentation for a full list of required/supported router virtual fields.', ); $me = '[' . __PACKAGE__ . ']'; @@ -123,7 +148,8 @@ sub _export_command { unless ($self->_check_router_fields($router)) { # Virtual fields aren't defined. Exit silently. - warn "[debug]$me Required router virtual fields not defined. Returning..."; + warn "[debug]$me Required router virtual fields not defined. Returning..." + if $DEBUG; return ''; } @@ -141,7 +167,7 @@ sub _export_command { return $error; } elsif (not defined $args) { # Silently decline. - warn "[debug]$me Declining '$action' export"; + warn "[debug]$me Declining '$action' export" if $DEBUG; return ''; } # else ... queue the export. @@ -161,6 +187,7 @@ sub _prepare_args { my ($self, $action, $router, $svc_broadband) = (shift, shift, shift, shift); my $old = shift if ($action eq 'replace'); + my $error = ''; my $field_prefix = $self->_field_prefix; my $command = $router->getfield("${field_prefix}_cmd_${action}"); @@ -170,7 +197,43 @@ sub _prepare_args { return ''; } - { + if ($command =~ /\[\@--/) { # Use Text::Template + + my $template_data = {}; + + if ($action eq 'replace') { + $template_data->{"old_$_"} = $old->getfield($_) foreach $old->fields; + $template_data->{"new_$_"} = $svc_broadband->getfield($_) + foreach $svc_broadband->fields; + } else { + $template_data->{$_} = $svc_broadband->getfield($_) + foreach $svc_broadband->fields; + } + + my $template = new Text::Template ( + TYPE => 'STRING', + SOURCE => $command, + DELIMITERS => [ '[@--', '--@]' ], + ) or return "Unable to construct template for router command: " + . $Text::Template::ERROR; + + $command = $template->fill_in( + HASH => $template_data, + BROKEN_ARG => \$error, + BROKEN => sub { + my %bargs = @_; + my $err = $bargs{'arg'}; + $$err = $bargs{'error'}; + return undef; + }, + ); + + if (not defined $command or $error) { + $error ||= $Text::Template::ERROR; + return "Unable to fill-in template for router command: $error"; + } + + } else { # Use eval no strict 'vars'; no strict 'refs'; @@ -194,6 +257,9 @@ sub _prepare_args { 'command' => $command, ]; + my $error_check = $router->getfield("${field_prefix}_cmd_${action}_error"); + push(@$args, ('error_check' => $error_check)) if ($error_check); + return('', $args); } @@ -217,7 +283,7 @@ sub _check_router_fields { foreach (@check_fields) { if ($router->getfield($_) eq '') { - warn "[debug]$me Required field '$_' is unset"; + warn "[debug]$me Required field '$_' is unset" if $DEBUG; return 0; } else { return 1; @@ -227,7 +293,6 @@ sub _check_router_fields { } sub _queue { - #warn join ':', @_; my( $self, $svcnum, $cmd_sub ) = (shift, shift, shift); my $queue = new FS::queue { 'svcnum' => $svcnum, @@ -253,24 +318,58 @@ sub _get_router { # Subroutines sub ssh_cmd { - use Net::SSH '0.08'; - &Net::SSH::ssh_cmd( { @_ } ); + my %arg = @_; + + eval 'use Net::SSH \'0.08\''; + die $@ if $@; + + my @out = &Net::SSH::ssh_cmd( { @_ } ); + my $error = &_cmd_error_check(\%arg, \@out); + + die ("Error while processing ssh command: $error") if $error; + + return ''; + } sub telnet_cmd { - eval 'use Net::Telnet;'; + my %arg = @_; + + eval 'use Net::Telnet'; die $@ if $@; - warn join(', ', @_); + my $t = new Net::Telnet (Timeout => $arg{'Timeout'}, + Prompt => $arg{'Prompt'}); + $t->open($arg{'host'}); + $t->login($arg{'user'}, $arg{'password'}); + my @out = $t->cmd($arg{'command'}); + my $error = &_cmd_error_check(\%arg, \@out); - my %arg = @_; + die ("Error while processing telnet command: $error") if $error; + + return ''; + +} + +sub _cmd_error_check { + my ($arg, $out) = (shift, shift); + + die "_cmd_error_check called without proper arguments" + unless (ref($arg) eq 'HASH' and ref($out) eq 'ARRAY'); + + unless (exists($arg->{'error_check'}) and $arg->{'error_check'} ne '') { + #Preserve default behaviour and return output if a check isn't defined. + warn "Output from router command: " . join('', @$out) if $DEBUG; + return ''; + } + + my $error_check = $arg->{'error_check'}; + foreach (@$out) { + return $_ if /$error_check/; + } + + return ''; - my $t = new Net::Telnet (Timeout => $arg{Timeout}, - Prompt => $arg{Prompt}); - $t->open($arg{host}); - $t->login($arg{user}, $arg{password}); - my @error = $t->cmd($arg{command}); - die @error if (grep /^ERROR/, @error); } 1; -- cgit v1.2.1 From 062cc0711149b9872d761560aaf4bac08f7801eb Mon Sep 17 00:00:00 2001 From: khoff Date: Thu, 15 Mar 2007 20:08:12 +0000 Subject: Set input form MAXLENGTH attributes to match actual field sizes. --- httemplate/edit/part_virtual_field.cgi | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/httemplate/edit/part_virtual_field.cgi b/httemplate/edit/part_virtual_field.cgi index 9dda4ebf9..6fc908b2c 100644 --- a/httemplate/edit/part_virtual_field.cgi +++ b/httemplate/edit/part_virtual_field.cgi @@ -42,7 +42,7 @@ Field #<%$vfieldpart or "(NEW)"%>

<%ntable("#cccccc",2)%> Name - @@ -54,7 +54,7 @@ Field #<%$vfieldpart or "(NEW)"%>

% % my $dbdef = dbdef; # ick % #foreach my $dbtable (sort { $a cmp $b } $dbdef->tables) { -% foreach my $dbtable (qw( svc_broadband )) { +% foreach my $dbtable (qw( svc_broadband router )) { % if ($dbtable !~ /^h_/ % and $dbdef->table($dbtable)->primary_key) { @@ -74,7 +74,7 @@ Field #<%$vfieldpart or "(NEW)"%>

Label - -- cgit v1.2.1 From 0219157aab31141211f9342993e65a262da3cf29 Mon Sep 17 00:00:00 2001 From: ivan Date: Thu, 15 Mar 2007 20:54:36 +0000 Subject: 13 months! --- FS/FS/part_pkg.pm | 1 + 1 file changed, 1 insertion(+) diff --git a/FS/FS/part_pkg.pm b/FS/FS/part_pkg.pm index e4c13aade..03222fa49 100644 --- a/FS/FS/part_pkg.pm +++ b/FS/FS/part_pkg.pm @@ -600,6 +600,7 @@ sub freqs_href { '3' => 'quarterly (every 3 months)', '6' => 'semiannually (every 6 months)', '12' => 'annually', + '13' => 'every 13 months (annually +1 month)', '24' => 'biannually (every 2 years)', '36' => 'triannually (every 3 years)', '48' => '(every 4 years)', -- cgit v1.2.1 From 7b3d074cbb694330334469510548d98eebe196ed Mon Sep 17 00:00:00 2001 From: ivan Date: Fri, 16 Mar 2007 01:35:55 +0000 Subject: vonage click2call integration should not be sitewide, especially now that we have user prefs --- FS/FS/Conf.pm | 20 ----------- httemplate/elements/phonenumber.html | 27 ++++++++++----- httemplate/pref/pref.html | 64 +++++++++++++++++++++++++----------- 3 files changed, 62 insertions(+), 49 deletions(-) diff --git a/FS/FS/Conf.pm b/FS/FS/Conf.pm index d9f7d1972..5f7cb8fec 100644 --- a/FS/FS/Conf.pm +++ b/FS/FS/Conf.pm @@ -1852,26 +1852,6 @@ httemplate/docs/config.html 'type' => 'checkbox', }, - #these should become per-user... - { - 'key' => 'vonage-username', - 'section' => '', - 'description' => 'Vonage Click2Call username (see https://secure.click2callu.com/)', - 'type' => 'text', - }, - { - 'key' => 'vonage-password', - 'section' => '', - 'description' => 'Vonage Click2Call username (see https://secure.click2callu.com/)', - 'type' => 'text', - }, - { - 'key' => 'vonage-fromnumber', - 'section' => '', - 'description' => 'Vonage Click2Call number (see https://secure.click2callu.com/)', - 'type' => 'text', - }, - { 'key' => 'echeck-nonus', 'section' => 'billing', diff --git a/httemplate/elements/phonenumber.html b/httemplate/elements/phonenumber.html index ffbd8c100..b1ae2aa2a 100644 --- a/httemplate/elements/phonenumber.html +++ b/httemplate/elements/phonenumber.html @@ -1,22 +1,31 @@ -% -% my( $number, %opt ) = @_; -% my $conf = new FS::Conf; -% ( my $snumber = $number ) =~ s/\D//g; -% - + % if ( length($number) ) { <% $number %> -% if ( $opt{'callable'} && $conf->config('vonage-username') ) { - Call this number -% } +% if ( $opt{'callable'} && $curuser->option('vonage-username') ) { + + Call this number + +% } +% % } else {   + % } +<%init> + +my( $number, %opt ) = @_; +( my $snumber = $number ) =~ s/\D//g; + +my $curuser = $FS::CurrentUser::CurrentUser; + +( my $vonage_number = $curuser->option('vonage-fromnumber') ) =~ s/\D//g; +$vonage_number =~ /^1/ or $vonage_number = "1$vonage_number"; + diff --git a/httemplate/pref/pref.html b/httemplate/pref/pref.html index 507a897d7..229ac0e62 100644 --- a/httemplate/pref/pref.html +++ b/httemplate/pref/pref.html @@ -8,39 +8,63 @@ Change password (leave blank for no change) <% ntable("#cccccc",2) %> - - Current password: - - + + Current password: + + - - New password: - - + + New password: + + - - Re-enter new password: - - + + Re-enter new password: + +
+ Interface <% ntable("#cccccc",2) %> - - Menu location: - - > Left
- > Top
- - - + + Menu location: + + > Left
+ > Top
+ + +
+ +Vonage integration (see Click2Call) +<% ntable("#cccccc",2) %> + + + Vonage phone number + + + + + Vonage username + + + + + Vonage password + + + + +
+ + % foreach my $prop (qw( height width availHeight availWidth colorDepth )) { + +<% include('/elements/xmlhttp.html', + 'url' => $p. 'misc/xmlhttp-cust_main-search.cgi', + 'subs' => [qw( custnum_search )], + ) +%> + +% my $fh = $cgi->upload('csvfile'); +% my $csv = new Text::CSV_XS; +% my $skip_fuzzies = $cgi->param('fuzzies') ? 0 : 1; +% +% if ( defined($fh) ) { + + + + + + + + +% my $agentnum => scalar($cgi->param('agentnum')), +% my $line; +% my $row = 0; +% while ( defined($line=<$fh>) ) { +% chomp $line; +% $line =~ s/^(.*)(#!).*/$1/; +% +% $csv->parse($line) or die "can't parse line: " . $csv->error_input(); +% my $custnum = 0; +% my @values = $csv->fields(); +% my $last = shift @values; +% if ($last =~ /^\s*(\d+)\s*$/ ) { +% $custnum = $1; +% $last = shift @values; +% } +% my $first = shift @values; +% my $note = join ' ', @values; +% next unless ( $last || $first || $note ); +% my @cust_main = (); +% warn "searching for: $last, $first" if ($first || $last); +% if ($custnum) { +% @cust_main = qsearch('cust_main', { 'custnum' => $custnum }); +% } else { +% @cust_main = FS::cust_main::smart_search( +% 'search' => "$last, $first", +% 'no_fuzzy_on_exact' => $skip_fuzzies, +% ) +% if ($first || $last); +% } +% + + + + + + + +% $row++; +% } +
Cust #CustomerLastFirstNote to be added
+ + + + + + + + <% $first %> + + + <% $last %> + + + <% $note %> + +
+ + + Preview mode +% } else { + No file supplied +% } + + + + diff --git a/httemplate/misc/cust_main_note-import.html b/httemplate/misc/cust_main_note-import.html new file mode 100644 index 000000000..67f49f326 --- /dev/null +++ b/httemplate/misc/cust_main_note-import.html @@ -0,0 +1,32 @@ +<% include("/elements/header.html",'Batch Customer Note Import') %> + +
+ +Import a CSV file containing customer notes records. +

+ +File format is CSV, with the following field order: [custnum], last, first, notefield1, notefield2, notefield3... +
+The optional custnum field is identified by being numeric. +Anything after the character sequence #! is ignored. +

+ +<% &ntable("#cccccc") %> + + + CSV filename + + + + Include additional possibilites when exact match is found + + + + +

+ + +
+ +<% include('/elements/footer.html') %> + diff --git a/httemplate/misc/process/cust_main_note-import.cgi b/httemplate/misc/process/cust_main_note-import.cgi new file mode 100644 index 000000000..af06ae95e --- /dev/null +++ b/httemplate/misc/process/cust_main_note-import.cgi @@ -0,0 +1,66 @@ +<% include("/elements/header.html", "Batch Customer Note Import $op") %> + +The following items <% $op eq 'Preview' ? 'would not be' : 'were not' %> imported. (See below for imported items) +
+%  foreach my $row (@uninserted) {
+%    $csv->combine( (map{ $row->{$_} } qw(last first note) ),
+%                   $row->{error} ? ('#!', $row->{error}) : (),
+%                 );
+<% $csv->string %>
+%  }
+
+ +The following items <% $op eq 'Preview' ? 'would be' : 'were' %> imported. (See above for unimported items) + +
+%  foreach my $row (@inserted) {
+%    $csv->combine( (map{ $row->{$_} } qw(custnum last first note) ),
+%                   ('#!', $row->{name}),
+%                 );
+<% $csv->string %>
+%  }
+
+ +<%init> +my $date = time; +my $otaker = $FS::CurrentUser::CurrentUser->username; +my $csv = new Text::CSV_XS; + +my $param = $cgi->Vars; + +my $op = $param->{preview} ? "Preview" : "Results"; + +my @inserted = (); +my @uninserted = (); +for ( my $row = 0; exists($param->{"custnum$row"}); $row++ ) { + if ( $param->{"custnum$row"} ) { + my $cust_main_note = new FS::cust_main_note { + 'custnum' => $param->{"custnum$row"}, + '_date' => $date, + 'otaker' => $otaker, + 'comments' => $param->{"note$row"}, + }; + my $error = ''; + $error = $cust_main_note->insert unless ($op eq "Preview"); + my $result = { 'custnum' => $param->{"custnum$row"}, + 'last' => $param->{"last$row"}, + 'first' => $param->{"first$row"}, + 'note' => $param->{"note$row"}, + 'name' => $param->{"name$row"}, + 'error' => $error, + }; + if ($error) { + push @uninserted, $result; + }else{ + push @inserted, $result; + } + }else{ + push @uninserted, { 'custnum' => '', + 'last' => $param->{"last$row"}, + 'first' => $param->{"first$row"}, + 'note' => $param->{"note$row"}, + 'error' => '', + }; + } +} + -- cgit v1.2.1 From ac0ffef1dd511febd1ffa851dfd8b3772b968b09 Mon Sep 17 00:00:00 2001 From: jeff Date: Tue, 20 Mar 2007 20:01:03 +0000 Subject: tie note import into menu --- httemplate/elements/menu.html | 1 + 1 file changed, 1 insertion(+) diff --git a/httemplate/elements/menu.html b/httemplate/elements/menu.html index 9565ff2d0..a58f25add 100644 --- a/httemplate/elements/menu.html +++ b/httemplate/elements/menu.html @@ -187,6 +187,7 @@ $report_menu{'Financial'} = [ \%report_financial, 'Financial reports' ] tie my %tools_importing, 'Tie::IxHash', 'Import customers from CSV file' => [ $fsurl.'misc/cust_main-import.cgi', '' ], + 'Import customer notes from CSV file' => [ $fsurl.'misc/cust_main_note-import.html', '' ], 'Import one-time charges from CSV file' => [ $fsurl.'misc/cust_main-import_charges.cgi', '' ], 'Import Call Detail Records (CDRs) from CSV file' => [ $fsurl.'misc/cdr-import.html', '' ], ; -- cgit v1.2.1 From 9f4b217a918ce2fd00138fb91f50ee21a2a77bae Mon Sep 17 00:00:00 2001 From: jeff Date: Tue, 20 Mar 2007 20:11:07 +0000 Subject: acls on new import --- httemplate/misc/cust_main_note-import.cgi | 7 +++++++ httemplate/misc/cust_main_note-import.html | 9 ++++++++- httemplate/misc/process/cust_main_note-import.cgi | 4 ++++ 3 files changed, 19 insertions(+), 1 deletion(-) diff --git a/httemplate/misc/cust_main_note-import.cgi b/httemplate/misc/cust_main_note-import.cgi index 07b922f6c..690ca783d 100644 --- a/httemplate/misc/cust_main_note-import.cgi +++ b/httemplate/misc/cust_main_note-import.cgi @@ -198,3 +198,10 @@ + +<%init> + +die "access denied" + unless $FS::CurrentUser::CurrentUser->access_right('Import'); + + diff --git a/httemplate/misc/cust_main_note-import.html b/httemplate/misc/cust_main_note-import.html index 67f49f326..d8fefa732 100644 --- a/httemplate/misc/cust_main_note-import.html +++ b/httemplate/misc/cust_main_note-import.html @@ -5,7 +5,7 @@ Import a CSV file containing customer notes records.

-File format is CSV, with the following field order: [custnum], last, first, notefield1, notefield2, notefield3... +File format is CSV, with the following field order: [custnum,] last, first, notefield1, notefield2, notefield3...
The optional custnum field is identified by being numeric. Anything after the character sequence #! is ignored. @@ -30,3 +30,10 @@ Anything after the character sequence #! is ignored. <% include('/elements/footer.html') %> +<%init> + +die "access denied" + unless $FS::CurrentUser::CurrentUser->access_right('Import'); + + + diff --git a/httemplate/misc/process/cust_main_note-import.cgi b/httemplate/misc/process/cust_main_note-import.cgi index af06ae95e..efc6224d0 100644 --- a/httemplate/misc/process/cust_main_note-import.cgi +++ b/httemplate/misc/process/cust_main_note-import.cgi @@ -22,6 +22,10 @@ The following items <% $op eq 'Preview' ? 'would be' : 'were' %> imported. (See <%init> + +die "access denied" + unless $FS::CurrentUser::CurrentUser->access_right('Import'); + my $date = time; my $otaker = $FS::CurrentUser::CurrentUser->username; my $csv = new Text::CSV_XS; -- cgit v1.2.1