diff options
Diffstat (limited to 'install/5.005/DBD-Pg-1.22-fixvercmp/t')
24 files changed, 4506 insertions, 0 deletions
diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/00basic.t b/install/5.005/DBD-Pg-1.22-fixvercmp/t/00basic.t new file mode 100644 index 0000000..1c0cb28 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/00basic.t @@ -0,0 +1,10 @@ +print "1..1\n"; + +use DBI; +use DBD::Pg; + +if ($DBD::Pg::VERSION) { + print "ok 1\n"; +} else { + print "not ok 1\n"; +} diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/01connect.t b/install/5.005/DBD-Pg-1.22-fixvercmp/t/01connect.t new file mode 100644 index 0000000..be17b50 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/01connect.t @@ -0,0 +1,26 @@ +use strict; +use DBI; +use Test::More; + +if (defined $ENV{DBI_DSN}) { + plan tests => 2; +} else { + plan skip_all => 'cannot test without DB info'; +} + +my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS}, + {RaiseError => 1, AutoCommit => 0} + ); + +ok((defined $dbh and $dbh->disconnect()), + 'connect with transaction' + ); + +undef $dbh; +$dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS}, + {RaiseError => 1, AutoCommit => 1}); + +ok((defined $dbh and $dbh->disconnect()), + 'connect without transaction' + ); + diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/01constants.t b/install/5.005/DBD-Pg-1.22-fixvercmp/t/01constants.t new file mode 100644 index 0000000..09907e9 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/01constants.t @@ -0,0 +1,25 @@ +use strict; +use Test::More tests => 20; + +use DBD::Pg qw(:pg_types); + +ok(PG_BOOL == 16, 'PG_BOOL'); +ok(PG_BYTEA == 17, 'PG_BYTEA'); +ok(PG_CHAR == 18, 'PG_CHAR'); +ok(PG_INT8 == 20, 'PG_INT8'); +ok(PG_INT2 == 21, 'PG_INT2'); +ok(PG_INT4 == 23, 'PG_INT4'); +ok(PG_TEXT == 25, 'PG_TEXT'); +ok(PG_OID == 26, 'PG_OID'); +ok(PG_FLOAT4 == 700, 'PG_FLOAT4'); +ok(PG_FLOAT8 == 701, 'PG_FLOAT8'); +ok(PG_ABSTIME == 702, 'PG_ABSTIME'); +ok(PG_RELTIME == 703, 'PG_RELTIME'); +ok(PG_TINTERVAL == 704, 'PG_TINTERVAL'); +ok(PG_BPCHAR == 1042, 'PG_BPCHAR'); +ok(PG_VARCHAR == 1043, 'PG_VARCHAR'); +ok(PG_DATE == 1082, 'PG_DATE'); +ok(PG_TIME == 1083, 'PG_TIME'); +ok(PG_DATETIME == 1184, 'PG_DATETIME'); +ok(PG_TIMESPAN == 1186, 'PG_TIMESPAN'); +ok(PG_TIMESTAMP == 1296, 'PG_TIMESTAMP'); diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/01setup.t b/install/5.005/DBD-Pg-1.22-fixvercmp/t/01setup.t new file mode 100644 index 0000000..d0b57a3 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/01setup.t @@ -0,0 +1,38 @@ +use strict; +use DBI; +use Test::More; + +if (defined $ENV{DBI_DSN}) { + plan tests => 3; +} else { + plan skip_all => 'cannot test without DB info'; +} + +my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS}, + {RaiseError => 1, AutoCommit => 1}); +ok(defined $dbh,'connect without transaction'); +{ + local $dbh->{PrintError} = 0; + local $dbh->{RaiseError} = 0; + $dbh->do(q{DROP TABLE test}); +} + +my $sql = <<SQL; +CREATE TABLE test ( + id int, + name text, + val text, + score float, + date timestamp default 'now()', + array text[][] +) +SQL + +ok($dbh->do($sql), + 'create table' + ); + +ok($dbh->disconnect(), + 'disconnect' + ); + diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/02prepare.t b/install/5.005/DBD-Pg-1.22-fixvercmp/t/02prepare.t new file mode 100644 index 0000000..373aca2 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/02prepare.t @@ -0,0 +1,84 @@ +use strict; +use DBI; +use Test::More; + +if (defined $ENV{DBI_DSN}) { + plan tests => 8; +} else { + plan skip_all => 'cannot test without DB info'; +} + +my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS}, + {RaiseError => 1, AutoCommit => 0} + ); +ok(defined $dbh, + 'connect with transaction' + ); + +my $sql = <<SQL; + SELECT * + FROM test +SQL + +ok($dbh->prepare($sql), + "prepare: $sql" + ); + +$sql = <<SQL; + SELECT id + FROM test +SQL + +ok($dbh->prepare($sql), + "prepare: $sql" + ); + +$sql = <<SQL; + SELECT id + , name + FROM test +SQL + +ok($dbh->prepare($sql), + "prepare: $sql" + ); + +$sql = <<SQL; + SELECT id + , name + FROM test + WHERE id = 1 +SQL + +ok($dbh->prepare($sql), + "prepare: $sql" + ); + +$sql = <<SQL; + SELECT id + , name + FROM test + WHERE id = ? +SQL + +ok($dbh->prepare($sql), + "prepare: $sql" + ); + +$sql = <<SQL; + SELECT * + FROM test + WHERE id = ? + AND name = ? + AND value = ? + AND score = ? + and data = ? +SQL + +ok($dbh->prepare($sql), + "prepare: $sql" + ); + +ok($dbh->disconnect(), + 'disconnect' + ); diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/03bind.t b/install/5.005/DBD-Pg-1.22-fixvercmp/t/03bind.t new file mode 100644 index 0000000..df7c884 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/03bind.t @@ -0,0 +1,85 @@ +use strict; +use DBI; +use Test::More; + +if (defined $ENV{DBI_DSN}) { + plan tests => 11; +} else { + plan skip_all => 'cannot test without DB info'; +} + +my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS}, + {RaiseError => 1, AutoCommit => 0} + ); +ok(defined $dbh, + 'connect with transaction' + ); + +my $sql = <<SQL; + SELECT id + , name + FROM test + WHERE id = ? +SQL +my $sth = $dbh->prepare($sql); +ok(defined $sth, + "prepare: $sql" + ); + +ok($sth->bind_param(1, 'foo'), + 'bind int column with string' + ); + +ok($sth->bind_param(1, 1), + 'rebind int column with int' + ); + +$sql = <<SQL; + SELECT id + , name + FROM test + WHERE id = ? + AND name = ? +SQL +$sth = $dbh->prepare($sql); +ok(defined $sth, + "prepare: $sql" + ); + +ok($sth->bind_param(1, 'foo'), + 'bind int column with string', + ); +ok($sth->bind_param(2, 'bar'), + 'bind string column with text' + ); +ok($sth->bind_param(2, 'baz'), + 'rebind string column with text' + ); + +ok($sth->finish(), + 'finish' + ); + +# Make sure that we get warnings when we try to use SQL_BINARY. +{ + local $SIG{__WARN__} = + sub { ok($_[0] =~ /^Use of SQL type SQL_BINARY/, + 'warning with SQL_BINARY' + ); + }; + + $sql = <<SQL; + SELECT id + , name + FROM test + WHERE id = ? + AND name = ? +SQL + $sth = $dbh->prepare($sql); + + $sth->bind_param(1, 'foo', DBI::SQL_BINARY); +} + +ok($dbh->disconnect(), + 'disconnect' + ); diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/04execute.t b/install/5.005/DBD-Pg-1.22-fixvercmp/t/04execute.t new file mode 100644 index 0000000..9643878 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/04execute.t @@ -0,0 +1,113 @@ +use strict; +use DBI; +use Test::More; + +if (defined $ENV{DBI_DSN}) { + plan tests => 13; +} else { + plan skip_all => 'cannot test without DB info'; +} + +my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS}, + {RaiseError => 1, AutoCommit => 0} + ); +ok(defined $dbh, + 'connect with transaction' + ); + +my $sql = <<SQL; + SELECT id + , name + FROM test + WHERE id = ? +SQL +my $sth = $dbh->prepare($sql); +ok(defined $sth, + "prepare: $sql" + ); + +$sth->bind_param(1, 1); +ok($sth->execute(), + 'exectute with one bind param' + ); + +$sth->bind_param(1, 2); +ok($sth->execute(), + 'exectute with rebinding one param' + ); + +$sql = <<SQL; + SELECT id + , name + FROM test + WHERE id = ? + AND name = ? +SQL +$sth = $dbh->prepare($sql); +ok(defined $sth, + "prepare: $sql" + ); + +$sth->bind_param(1, 2); +$sth->bind_param(2, 'foo'); +ok($sth->execute(), + 'exectute with two bind params' + ); + +eval { + local $dbh->{PrintError} = 0; + $sth = $dbh->prepare($sql); + $sth->bind_param(1, 2); + $sth->execute(); +}; +ok(!$@, + 'execute with only first of two params bound' + ); + +eval { + local $dbh->{PrintError} = 0; + $sth = $dbh->prepare($sql); + $sth->bind_param(2, 'foo'); + $sth->execute(); +}; +ok(!$@, + 'execute with only second of two params bound' + ); + +eval { + local $dbh->{PrintError} = 0; + $sth = $dbh->prepare($sql); + $sth->execute(); +}; +ok(!$@, + 'execute with neither of two params bound' + ); + +$sth = $dbh->prepare($sql); +ok($sth->execute(1, 'foo'), + 'execute with both params bound in execute' + ); + +eval { + local $dbh->{PrintError} = 0; + $sth = $dbh->prepare(q{ + SELECT id + , name + FROM test + WHERE id = ? + AND name = ? + }); + $sth->execute(1); +}; +ok($@, + 'execute with only one of two params bound in execute' + ); + + +ok($sth->finish(), + 'finish' + ); + +ok($dbh->disconnect(), + 'disconnect' + ); diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/05fetch.t b/install/5.005/DBD-Pg-1.22-fixvercmp/t/05fetch.t new file mode 100644 index 0000000..b6f8f66 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/05fetch.t @@ -0,0 +1,131 @@ +use strict; +use DBI; +use Test::More; + +if (defined $ENV{DBI_DSN}) { + plan tests => 10; +} else { + plan skip_all => 'cannot test without DB info'; +} + +my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS}, + {RaiseError => 1, AutoCommit => 0} + ); +ok(defined $dbh, + 'connect with transaction' + ); + +$dbh->do(q{INSERT INTO test (id, name, val) VALUES (1, 'foo', 'horse')}); +$dbh->do(q{INSERT INTO test (id, name, val) VALUES (2, 'bar', 'chicken')}); +$dbh->do(q{INSERT INTO test (id, name, val) VALUES (3, 'baz', 'pig')}); +ok($dbh->commit(), + 'commit' + ); + +my $sql = <<SQL; + SELECT id + , name + FROM test +SQL +my $sth = $dbh->prepare($sql); +$sth->execute(); + +my $rows = 0; +while (my ($id, $name) = $sth->fetchrow_array()) { + if (defined($id) && defined($name)) { + $rows++; + } +} +$sth->finish(); +ok($rows == 3, + 'fetch three rows' + ); + +$sql = <<SQL; + SELECT id + , name + FROM test + WHERE 1 = 0 +SQL +$sth = $dbh->prepare($sql); +$sth->execute(); + +$rows = 0; +while (my ($id, $name) = $sth->fetchrow_array()) { + $rows++; +} +$sth->finish(); + +ok($rows == 0, + 'fetch zero rows' + ); + +$sql = <<SQL; + SELECT id + , name + FROM test + WHERE id = ? +SQL +$sth = $dbh->prepare($sql); +$sth->execute(1); + +$rows = 0; +while (my ($id, $name) = $sth->fetchrow_array()) { + if (defined($id) && defined($name)) { + $rows++; + } +} +$sth->finish(); + +ok($rows == 1, + 'fetch one row on id' + ); + +# Attempt to test whether or not we can get unicode out of the database +# correctly. Reuse the previous sth. +SKIP: { + eval "use Encode"; + skip "need Encode module for unicode tests", 3 if $@; + local $dbh->{pg_enable_utf8} = 1; + $dbh->do("INSERT INTO test (id, name, val) VALUES (4, '\001\000dam', 'cow')"); + $sth->execute(4); + my ($id, $name) = $sth->fetchrow_array(); + ok(Encode::is_utf8($name), + 'returned data has utf8 bit set' + ); + is(length($name), 4, + 'returned utf8 data is not corrupted' + ); + $sth->finish(); + $sth->execute(1); + my ($id2, $name2) = $sth->fetchrow_array(); + ok(! Encode::is_utf8($name2), + 'returned ASCII data has not got utf8 bit set' + ); + $sth->finish(); +} + +$sql = <<SQL; + SELECT id + , name + FROM test + WHERE name = ? +SQL +$sth = $dbh->prepare($sql); +$sth->execute('foo'); + +$rows = 0; +while (my ($id, $name) = $sth->fetchrow_array()) { + if (defined($id) && defined($name)) { + $rows++; + } +} +$sth->finish(); + +ok($rows == 1, + 'fetch one row on name' + ); + +ok($dbh->disconnect(), + 'disconnect' + ); diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/06disconnect.t b/install/5.005/DBD-Pg-1.22-fixvercmp/t/06disconnect.t new file mode 100644 index 0000000..5d76bc0 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/06disconnect.t @@ -0,0 +1,31 @@ +use strict; +use DBI; +use Test::More; + +if (defined $ENV{DBI_DSN}) { + plan tests => 3; +} else { + plan skip_all => 'cannot test without DB info'; +} + +my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS}, + {RaiseError => 1, AutoCommit => 0} + ); +ok(defined $dbh, + 'connect with transaction' + ); + +ok($dbh->disconnect(), + 'disconnect' + ); + +$dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS}, + {RaiseError => 1, AutoCommit => 0} + ); + +$dbh->disconnect(); +$dbh->disconnect(); +$dbh->disconnect(); +ok($dbh->disconnect(), + 'disconnect on already disconnected dbh' + ); diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/07reuse.t b/install/5.005/DBD-Pg-1.22-fixvercmp/t/07reuse.t new file mode 100644 index 0000000..d09dfc0 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/07reuse.t @@ -0,0 +1,28 @@ +use strict; +use DBI; +use Test::More; + +if (defined $ENV{DBI_DSN}) { + plan tests => 3; +} else { + plan skip_all => 'cannot test without DB info'; +} + +my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS}, + {RaiseError => 1, PrintError => 0, AutoCommit => 0} + ); +ok(defined $dbh, + 'connect with transaction' + ); + +my $sth = $dbh->prepare(q{SELECT * FROM test}); +ok($dbh->disconnect(), + 'disconnect with un-finished statement' + ); + +eval { + $sth->execute(); +}; +ok($@, + 'execute on disconnected statement' + ); diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/08txn.t b/install/5.005/DBD-Pg-1.22-fixvercmp/t/08txn.t new file mode 100644 index 0000000..467aa31 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/08txn.t @@ -0,0 +1,102 @@ +use strict; +use DBI; +use Test::More; + +if (defined $ENV{DBI_DSN}) { + plan tests => 18; +} else { + plan skip_all => 'cannot test without DB info'; +} + +my $dbh1 = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS}, + {RaiseError => 1, AutoCommit => 0} + ); +ok(defined $dbh1, + 'connect first dbh' + ); + +my $dbh2 = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS}, + {RaiseError => 1, AutoCommit => 0} + ); +ok(defined $dbh2, + 'connect second dbh' + ); + +$dbh1->do(q{DELETE FROM test}); +ok($dbh1->commit(), + 'delete' + ); + +my $rows = ($dbh1->selectrow_array(q{SELECT COUNT(*) FROM test}))[0]; +ok($rows == 0, + 'fetch on empty table from dbh1' + ); + +$rows = ($dbh2->selectrow_array(q{SELECT COUNT(*) FROM test}))[0]; +ok($rows == 0, + 'fetch on empty table from dbh2' + ); + +$dbh1->do(q{INSERT INTO test (id, name, val) VALUES (1, 'foo', 'horse')}); +$dbh1->do(q{INSERT INTO test (id, name, val) VALUES (2, 'bar', 'chicken')}); +$dbh1->do(q{INSERT INTO test (id, name, val) VALUES (3, 'baz', 'pig')}); + +$rows = ($dbh1->selectrow_array(q{SELECT COUNT(*) FROM test}))[0]; +ok($rows == 3, + 'fetch three rows on dbh1' + ); + +$rows = ($dbh2->selectrow_array(q{SELECT COUNT(*) FROM test}))[0]; +ok($rows == 0, + 'fetch on dbh2 before commit' + ); + +ok($dbh1->commit(), + 'commit work' + ); + +$rows = ($dbh1->selectrow_array(q{SELECT COUNT(*) FROM test}))[0]; +ok($rows == 3, + 'fetch on dbh1 after commit' + ); + +$rows = ($dbh2->selectrow_array(q{SELECT COUNT(*) FROM test}))[0]; +ok($rows == 3, + 'fetch on dbh2 after commit' + ); + +ok($dbh1->do(q{DELETE FROM test}), + 'delete' + ); + +$rows = ($dbh1->selectrow_array(q{SELECT COUNT(*) FROM test}))[0]; +ok($rows == 0, + 'fetch on empty table from dbh1' + ); + +$rows = ($dbh2->selectrow_array(q{SELECT COUNT(*) FROM test}))[0]; +ok($rows == 3, + 'fetch on from dbh2 without commit' + ); + +ok($dbh1->rollback(), + 'rollback' + ); + +$rows = ($dbh1->selectrow_array(q{SELECT COUNT(*) FROM test}))[0]; +ok($rows == 3, + 'fetch on from dbh1 after rollback' + ); + +$rows = ($dbh2->selectrow_array(q{SELECT COUNT(*) FROM test}))[0]; +ok($rows == 3, + 'fetch on from dbh2 after rollback' + ); + +ok($dbh1->disconnect(), + 'disconnect on dbh1' +); + +ok($dbh2->disconnect(), + 'disconnect on dbh2' +); diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/09autocommit.t b/install/5.005/DBD-Pg-1.22-fixvercmp/t/09autocommit.t new file mode 100644 index 0000000..9b1b69f --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/09autocommit.t @@ -0,0 +1,68 @@ +use strict; +use DBI; +use Test::More; + +if (defined $ENV{DBI_DSN}) { + plan tests => 12; +} else { + plan skip_all => 'cannot test without DB info'; +} + +my $dbh1 = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS}, + {RaiseError => 1, AutoCommit => 1} + ); +ok(defined $dbh1, + 'connect first dbh' + ); + +my $dbh2 = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS}, + {RaiseError => 1, AutoCommit => 1} + ); +ok(defined $dbh2, + 'connect second dbh' + ); + +ok($dbh1->do(q{DELETE FROM test}), + 'delete' + ); + +my $rows = ($dbh1->selectrow_array(q{SELECT COUNT(*) FROM test}))[0]; +ok($rows == 0, + 'fetch on empty table from dbh1' + ); + +$rows = ($dbh2->selectrow_array(q{SELECT COUNT(*) FROM test}))[0]; +ok($rows == 0, + 'fetch on empty table from dbh2' + ); + +ok($dbh1->do(q{INSERT INTO test (id, name, val) VALUES (1, 'foo', 'horse')}), + 'insert' + ); + +$rows = ($dbh1->selectrow_array(q{SELECT COUNT(*) FROM test}))[0]; +ok($rows == 1, + 'fetch one row from dbh1' + ); + +$rows = ($dbh2->selectrow_array(q{SELECT COUNT(*) FROM test}))[0]; +ok($rows == 1, + 'fetch one row from dbh1' + ); + +local $SIG{__WARN__} = sub {}; +ok(!$dbh1->commit(), + 'commit' + ); + +ok(!$dbh1->rollback(), + 'rollback' + ); + +ok($dbh1->disconnect(), + 'disconnect on dbh1' +); + +ok($dbh2->disconnect(), + 'disconnect on dbh2' +); diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/11quoting.t b/install/5.005/DBD-Pg-1.22-fixvercmp/t/11quoting.t new file mode 100644 index 0000000..afec963 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/11quoting.t @@ -0,0 +1,50 @@ +use strict; +use DBI; +use Test::More; + +if (defined $ENV{DBI_DSN}) { + plan tests => 8; +} else { + plan skip_all => 'cannot test without DB info'; +} + +my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS}, + {RaiseError => 1, AutoCommit => 0} + ); +ok(defined $dbh, + 'connect with transaction' + ); + +my %tests = ( + one=>["'", "'\\" . sprintf("%03o", ord("'")) . "'"], + two=>["''", "'" . ("\\" . sprintf("%03o", ord("'")))x2 . "'"], + three=>["\\", "'\\" . sprintf("%03o", ord("\\")) . "'"], + four=>["\\'", sprintf("'\\%03o\\%03o'", ord("\\"), ord("'"))], + five=>["\\'?:", sprintf("'\\%03o\\%03o?:'", ord("\\"), ord("'"))], + ); + +foreach my $test (keys %tests) { + my ($unq, $quo, $ref); + + $unq = $tests{$test}->[0]; + $ref = $tests{$test}->[1]; + $quo = $dbh->quote($unq); + + ok($quo eq $ref, + "$test: $unq -> expected $quo got $ref" + ); +} + +# Make sure that SQL_BINARY doesn't work. +# eval { $dbh->quote('foo', { TYPE => DBI::SQL_BINARY })}; +eval { + local $dbh->{PrintError} = 0; + $dbh->quote('foo', DBI::SQL_BINARY); +}; +ok($@ && $@ =~ /Use of SQL_BINARY invalid in quote/, + 'SQL_BINARY' +); + +ok($dbh->disconnect(), + 'disconnect' + ); diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/12placeholders.t b/install/5.005/DBD-Pg-1.22-fixvercmp/t/12placeholders.t new file mode 100644 index 0000000..bd79ea7 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/12placeholders.t @@ -0,0 +1,125 @@ +use strict; +use DBI; +use Test::More; + +if (defined $ENV{DBI_DSN}) { + plan tests => 9; +} else { + plan skip_all => 'cannot test without DB info'; +} + +my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS}, + {RaiseError => 1, AutoCommit => 0} + ); +ok(defined $dbh, + 'connect with transaction' + ); + +my $quo = $dbh->quote("\\'?:"); +my $sth = $dbh->prepare(qq{ + INSERT INTO test (name) VALUES ($quo) + }); +$sth->execute(); + +my $sql = <<SQL; + SELECT name + FROM test + WHERE name = $quo; +SQL +$sth = $dbh->prepare($sql); +$sth->execute(); + +my ($retr) = $sth->fetchrow_array(); +ok((defined($retr) && $retr eq "\\'?:"), + 'fetch' + ); + +eval { + local $dbh->{PrintError} = 0; + $sth->execute('foo'); +}; +ok($@, + 'execute with one bind param where none expected' + ); + +$sql = <<SQL; + SELECT name + FROM test + WHERE name = ? +SQL +$sth = $dbh->prepare($sql); + +$sth->execute("\\'?:"); + +($retr) = $sth->fetchrow_array(); +ok((defined($retr) && $retr eq "\\'?:"), + 'execute with ? placeholder' + ); + +$sql = <<SQL; + SELECT name + FROM test + WHERE name = :1 +SQL +$sth = $dbh->prepare($sql); + +$sth->execute("\\'?:"); + +($retr) = $sth->fetchrow_array(); +ok((defined($retr) && $retr eq "\\'?:"), + 'execute with :1 placeholder' + ); + +$sql = <<SQL; + SELECT name + FROM test + WHERE name = '?' +SQL +$sth = $dbh->prepare($sql); + +eval { + local $dbh->{PrintError} = 0; + $sth->execute('foo'); +}; +ok($@, + 'execute with quoted ?' + ); + +$sql = <<SQL; + SELECT name + FROM test + WHERE name = ':1' +SQL +$sth = $dbh->prepare($sql); + +eval { + local $dbh->{PrintError} = 0; + $sth->execute('foo'); +}; +ok($@, + 'execute with quoted :1' + ); + +$sql = <<SQL; + SELECT name + FROM test + WHERE name = '\\\\' + AND name = '?' +SQL +$sth = $dbh->prepare($sql); + +eval { + local $dbh->{PrintError} = 0; + local $sth->{PrintError} = 0; + $sth->execute('foo'); +}; +ok($@, + 'execute with quoted ?' + ); + +$sth->finish(); +$dbh->rollback(); + +ok($dbh->disconnect(), + 'disconnect' + ); diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/13pgtype.t b/install/5.005/DBD-Pg-1.22-fixvercmp/t/13pgtype.t new file mode 100644 index 0000000..8db819e --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/13pgtype.t @@ -0,0 +1,43 @@ +use strict; +use DBI; +use Test::More; + +if (defined $ENV{DBI_DSN}) { + plan tests => 3; +} else { + plan skip_all => 'cannot test without DB info'; +} + +my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS}, + {RaiseError => 1, AutoCommit => 0} + ); +ok(defined $dbh, + 'connect with transaction' + ); + +eval { + local $dbh->{PrintError} = 0; + $dbh->do(q{DROP TABLE tt}); + $dbh->commit(); +}; +$dbh->rollback(); + +$dbh->do(q{CREATE TABLE tt (blah numeric(5,2), foo text)}); +my $sth = $dbh->prepare(qq{ + SELECT * FROM tt WHERE FALSE + }); +$sth->execute(); + +my @types = @{$sth->{pg_type}}; + +ok($types[0] eq 'numeric', + 'type numeric' + ); + +ok($types[1] eq 'text', + 'type text' + ); + +$sth->finish(); +$dbh->rollback(); +$dbh->disconnect(); diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/15funct.t b/install/5.005/DBD-Pg-1.22-fixvercmp/t/15funct.t new file mode 100644 index 0000000..1bc2cf9 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/15funct.t @@ -0,0 +1,353 @@ +#!/usr/bin/perl -w -I./t +$| = 1; + +# vim:ts=2:sw=2:ai:aw:nu: +use DBI qw(:sql_types); +use Data::Dumper; +use strict; +use Test::More; +if (defined $ENV{DBI_DSN}) { + plan tests => 59; +} else { + plan skip_all => 'cannot test without DB info'; +} + +my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS}, + {RaiseError => 1, AutoCommit => 0} + ); +ok(defined $dbh, + 'connect with transaction' + ); + +# +# Test the different methods, so are expected to fail. +# + +my $sth; + +# foreach (@{ $DBI::EXPORT_TAGS{sql_types} }) { +# no strict 'refs'; +# printf "%s=%d\n", $_, &{"DBI::$_"}; +# } + +my $get_info = { + SQL_DBMS_NAME => 17 + , SQL_DBMS_VER => 18 + , SQL_IDENTIFIER_QUOTE_CHAR => 29 + , SQL_CATALOG_NAME_SEPARATOR => 41 + , SQL_CATALOG_LOCATION => 114 +}; + +# Ping + eval { + ok( $dbh->ping(), "Testing Ping" ); + }; +ok ( !$@, "Ping Tested" ); + +# Get Info + eval { + $sth = $dbh->get_info(); + }; +ok ($@, "Call to get_info with 0 arguements, error expected: $@" ); +$sth = undef; + +# Table Info + eval { + $sth = $dbh->table_info(); + }; +ok ((!$@ and defined $sth), "table_info tested" ); +$sth = undef; + +# Column Info + eval { + $sth = $dbh->column_info(); + }; +ok ((!$@ and defined $sth), "column_info tested" ); +#ok ($@, "Call to column_info with 0 arguements, error expected: $@" ); +$sth = undef; + + +# Tables + eval { + $sth = $dbh->tables(); + }; +ok ((!$@ and defined $sth), "tables tested" ); +$sth = undef; + +# Type Info All + eval { + $sth = $dbh->type_info_all(); + }; +ok ((!$@ and defined $sth), "type_info_all tested" ); +$sth = undef; + +# Type Info + eval { + my @types = $dbh->type_info(); + die unless @types; + }; +ok (!$@, "type_info(undef)"); +$sth = undef; + +# Quote + eval { + my $val = $dbh->quote(); + die unless $val; + }; +ok ($@, "quote error expected: $@"); + +$sth = undef; +# Tests for quote: +my @qt_vals = (1, 2, undef, 'NULL', "ThisIsAString", "This is Another String"); +my @expt_vals = (q{'1'}, q{'2'}, "NULL", q{'NULL'}, q{'ThisIsAString'}, q{'This is Another String'}); +for (my $x = 0; $x <= $#qt_vals; $x++) { + local $^W = 0; + my $val = $dbh->quote( $qt_vals[$x] ); + is( $val, $expt_vals[$x], "$x: quote on $qt_vals[$x] returned $val" ); +} + +is( $dbh->quote( 1, SQL_INTEGER() ), 1, "quote(1, SQL_INTEGER)" ); + + +# Quote Identifier + eval { + my $val = $dbh->quote_identifier(); + die unless $val; + }; + +ok ($@, "quote_identifier error expected: $@"); +$sth = undef; + +SKIP: { + skip("get_info() not yet implemented", 1); + # , SQL_IDENTIFIER_QUOTE_CHAR => 29 + # , SQL_CATALOG_NAME_SEPARATOR => 41 + my $qt = $dbh->get_info( $get_info->{SQL_IDENTIFIER_QUOTE_CHAR} ); + my $sep = $dbh->get_info( $get_info->{SQL_CATALOG_NAME_SEPARATOR} ); + + # Uncomment this line and remove the next line when get_info() is implemented. +# my $cmp_str = qq{${qt}link${qt}${sep}${qt}schema${qt}${sep}${qt}table${qt}}; + my $cmp_str = ''; + is( $dbh->quote_identifier( "link", "schema", "table" ) + , $cmp_str + , q{quote_identifier( "link", "schema", "table" )} + ); +} + +# Test ping + +ok ($dbh->ping, "Ping the current connection ..." ); + +# Test Get Info. + +# SQL_KEYWORDS +# SQL_CATALOG_TERM +# SQL_DATA_SOURCE_NAME +# SQL_DBMS_NAME +# SQL_DBMS_VERSION +# SQL_DRIVER_NAME +# SQL_DRIVER_VER +# SQL_PROCEDURE_TERM +# SQL_SCHEMA_TERM +# SQL_TABLE_TERM +# SQL_USER_NAME + +SKIP: { + skip("get_info() not yet implemented", 5); + foreach my $info (sort keys %$get_info) { + my $type = $dbh->get_info($get_info->{$info}); + ok( defined $type, "get_info($info) ($get_info->{$info}) " . + ($type || '') ); + } +} + +# Test Table Info +$sth = $dbh->table_info( undef, undef, undef ); +ok( defined $sth, "table_info(undef, undef, undef) tested" ); +DBI::dump_results($sth) if defined $sth; +$sth = undef; + +$sth = $dbh->table_info( undef, undef, undef, "VIEW" ); +ok( defined $sth, "table_info(undef, undef, undef, \"VIEW\") tested" ); +DBI::dump_results($sth) if defined $sth; +$sth = undef; + +# Test Table Info Rule 19a +$sth = $dbh->table_info( '%', '', ''); +ok( defined $sth, "table_info('%', '', '',) tested" ); +DBI::dump_results($sth) if defined $sth; +$sth = undef; + +# Test Table Info Rule 19b +$sth = $dbh->table_info( '', '%', ''); +ok( defined $sth, "table_info('', '%', '',) tested" ); +DBI::dump_results($sth) if defined $sth; +$sth = undef; + +# Test Table Info Rule 19c +$sth = $dbh->table_info( '', '', '', '%'); +ok( defined $sth, "table_info('', '', '', '%',) tested" ); +DBI::dump_results($sth) if defined $sth; +$sth = undef; + +# Test to see if this database contains any of the defined table types. +$sth = $dbh->table_info( '', '', '', '%'); +ok( defined $sth, "table_info('', '', '', '%',) tested" ); +if ($sth) { + my $ref = $sth->fetchall_hashref( 'TABLE_TYPE' ); + foreach my $type ( sort keys %$ref ) { + my $tsth = $dbh->table_info( undef, undef, undef, $type ); + ok( defined $tsth, "table_info(undef, undef, undef, $type) tested" ); + DBI::dump_results($tsth) if defined $tsth; + $tsth->finish; + } + $sth->finish; +} +$sth = undef; + +# Test Column Info +$sth = $dbh->column_info( undef, undef, undef, undef ); +ok( defined $sth, "column_info(undef, undef, undef, undef) tested" ); +DBI::dump_results($sth) if defined $sth; +$sth = undef; + +$sth = $dbh->column_info( undef, "'auser'", undef, undef ); +ok( defined $sth, "column_info(undef, 'auser', undef, undef) tested" ); +DBI::dump_results($sth) if defined $sth; +$sth = undef; + +$sth = $dbh->column_info( undef, "'ause%'", undef, undef ); +ok( defined $sth, "column_info(undef, 'ause%', undef, undef) tested" ); +DBI::dump_results($sth) if defined $sth; +$sth = undef; + +$sth = $dbh->column_info( undef, "'auser','replicator'", undef, undef ); +ok( defined $sth, "column_info(undef, 'auser','replicator', undef, undef) tested" ); +DBI::dump_results($sth) if defined $sth; +$sth = undef; + +$sth = $dbh->column_info( undef, "'auser','repl%'", undef, undef ); +ok( defined $sth, "column_info(undef, 'auser','repl%', undef, undef) tested" ); +DBI::dump_results($sth) if defined $sth; +$sth = undef; + +$sth = $dbh->column_info( undef, "'fred','repl%'", undef, undef ); +ok( defined $sth, "column_info(undef, 'fred','repl%', undef, undef) tested" ); +DBI::dump_results($sth) if defined $sth; +$sth = undef; + +$sth = $dbh->column_info( undef, "'fred','jim'", undef, undef ); +ok( defined $sth, "column_info(undef, 'fred','jim', undef, undef) tested" ); +DBI::dump_results($sth) if defined $sth; +$sth = undef; + +$sth = $dbh->column_info( undef, "'auser'", "'pga_schema'", undef ); +ok( defined $sth, "column_info(undef, 'auser', 'pga_schema', undef) tested" ); +DBI::dump_results($sth) if defined $sth; +$sth = undef; + +$sth = $dbh->column_info( undef, "'auser'", "'pga_%'", undef ); +ok( defined $sth, "column_info(undef, 'auser', 'pga_%', undef) tested" ); +DBI::dump_results($sth) if defined $sth; +$sth = undef; + +$sth = $dbh->column_info( undef, "'ause%'", "'pga_%'", undef ); +ok( defined $sth, "column_info(undef, 'ause%', 'pga_%', undef) tested" ); +DBI::dump_results($sth) if defined $sth; +$sth = undef; + +$sth = $dbh->column_info( undef, "'auser'", "'pga_schema'", "'schemaname'" ); +ok( defined $sth, "column_info(undef, 'auser', 'pga_schema', 'schemaname') tested" ); +DBI::dump_results($sth) if defined $sth; +$sth = undef; + +$sth = $dbh->column_info( undef, "'auser'", "'pga_schema'", "'schema%'" ); +ok( defined $sth, "column_info(undef, 'auser', 'pga_schema', 'schema%') tested" ); +DBI::dump_results($sth) if defined $sth; +$sth = undef; + +$sth = $dbh->column_info( undef, "'auser'", "'pga_%'", "'schema%'" ); +ok( defined $sth, "column_info(undef, 'auser', 'pga_%', 'schema%') tested" ); +DBI::dump_results($sth) if defined $sth; +$sth = undef; + +$sth = $dbh->column_info( undef, "'ause%'", "'pga_%'", "'schema%'" ); +ok( defined $sth, "column_info(undef, 'ause%', 'pga_%', 'schema%') tested" ); +DBI::dump_results($sth) if defined $sth; +$sth = undef; + +# Test call to primary_key_info +local ($dbh->{Warn}, $dbh->{PrintError}); +$dbh->{PrintError} = $dbh->{Warn} = 0; + +# Primary Key Info +eval { + $sth = $dbh->primary_key_info(); + die unless $sth; +}; +ok ($@, "Call to primary_key_info with 0 arguements, error expected: $@" ); +$sth = undef; + +# Primary Key +eval { + $sth = $dbh->primary_key(); + die unless $sth; +}; +ok ($@, "Call to primary_key with 0 arguements, error expected: $@" ); +$sth = undef; + +$sth = $dbh->primary_key_info(undef, undef, undef ); + +ok( defined $sth, "Statement handle defined for primary_key_info()" ); + +if ( defined $sth ) { + while( my $row = $sth->fetchrow_arrayref ) { + local $^W = 0; + # print join( ", ", @$row, "\n" ); + } + + undef $sth; + +} + +$sth = $dbh->primary_key_info(undef, undef, undef ); +ok( defined $sth, "Statement handle defined for primary_key_info()" ); + +my ( %catalogs, %schemas, %tables); + +my $cnt = 0; +while( my ($catalog, $schema, $table) = $sth->fetchrow_array ) { + local $^W = 0; + $catalogs{$catalog}++ if $catalog; + $schemas{$schema}++ if $schema; + $tables{$table}++ if $table; + $cnt++; +} +ok( $cnt > 0, "At least one table has a primary key." ); + +$sth = $dbh->primary_key_info(undef, qq{'$ENV{DBI_USER}'}, undef ); +ok( + defined $sth + , "Getting primary keys for tables owned by $ENV{DBI_USER}"); +DBI::dump_results($sth) if defined $sth; + +undef $sth; + +SKIP: { + # foreign_key_info + local ($dbh->{Warn}, $dbh->{PrintError}); + $dbh->{PrintError} = $dbh->{Warn} = 0; + eval { + $sth = $dbh->foreign_key_info(); + die unless $sth; + }; + skip "foreign_key_info not supported by driver", 1 if $@; + ok( defined $sth, "Statement handle defined for foreign_key_info()" ); + DBI::dump_results($sth) if defined $sth; + $sth = undef; +} + +ok( $dbh->disconnect, "Disconnect from database" ); + +exit(0); + diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/99cleanup.t b/install/5.005/DBD-Pg-1.22-fixvercmp/t/99cleanup.t new file mode 100644 index 0000000..e7563ab --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/99cleanup.t @@ -0,0 +1,24 @@ +use strict; +use DBI; +use Test::More; + +if (defined $ENV{DBI_DSN}) { + plan tests => 3; +} else { + plan skip_all => 'cannot test without DB info'; +} + +my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS}, + {RaiseError => 1, AutoCommit => 0} + ); +ok(defined $dbh, + 'connect with transaction' + ); + +ok($dbh->do(q{DROP TABLE test}), + 'drop' + ); + +ok($dbh->disconnect(), + 'disconnect' + ); diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info.pm b/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info.pm new file mode 100644 index 0000000..417247f --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info.pm @@ -0,0 +1,1167 @@ +package App::Info; + +# $Id: Info.pm,v 1.1 2004-04-29 09:21:28 ivan Exp $ + +=head1 NAME + +App::Info - Information about software packages on a system + +=head1 SYNOPSIS + + use App::Info::Category::FooApp; + + my $app = App::Info::Category::FooApp->new; + + if ($app->installed) { + print "App name: ", $app->name, "\n"; + print "Version: ", $app->version, "\n"; + print "Bin dir: ", $app->bin_dir, "\n"; + } else { + print "App not installed on your system. :-(\n"; + } + +=head1 DESCRIPTION + +App::Info is an abstract base class designed to provide a generalized +interface for subclasses that provide metadata about software packages +installed on a system. The idea is that these classes can be used in Perl +application installers in order to determine whether software dependencies +have been fulfilled, and to get necessary metadata about those software +packages. + +App::Info provides an event model for handling events triggered by App::Info +subclasses. The events are classified as "info", "error", "unknown", and +"confirm" events, and multiple handlers may be specified to handle any or all +of these event types. This allows App::Info clients to flexibly handle events +in any way they deem necessary. Implementing new event handlers is +straight-forward, and use the triggering of events by App::Info subclasses is +likewise kept easy-to-use. + +A few L<sample subclasses|"SEE ALSO"> are provided with the distribution, but +others are invited to write their own subclasses and contribute them to the +CPAN. Contributors are welcome to extend their subclasses to provide more +information relevant to the application for which data is to be provided (see +L<App::Info::HTTPD::Apache|App::Info::HTTPD::Apache> for an example), but are +encouraged to, at a minimum, implement the abstract methods defined here and +in the category abstract base classes (e.g., +L<App::Info::HTTPD|App::Info::HTTPD> and L<App::Info::Lib|App::Info::Lib>). +See L<Subclassing|"SUBCLASSING"> for more information on implementing new +subclasses. + +=cut + +use strict; +use Carp (); +use App::Info::Handler; +use App::Info::Request; +use vars qw($VERSION); + +$VERSION = '0.23'; + +############################################################################## +############################################################################## +# This code ref is used by the abstract methods to throw an exception when +# they're called directly. +my $croak = sub { + my ($caller, $meth) = @_; + $caller = ref $caller || $caller; + if ($caller eq __PACKAGE__) { + $meth = __PACKAGE__ . '::' . $meth; + Carp::croak(__PACKAGE__ . " is an abstract base class. Attempt to " . + " call non-existent method $meth"); + } else { + Carp::croak("Class $caller inherited from the abstract base class " . + __PACKAGE__ . ", but failed to redefine the $meth() " . + "method. Attempt to call non-existent method " . + "${caller}::$meth"); + } +}; + +############################################################################## +# This code reference is used by new() and the on_* error handler methods to +# set the error handlers. +my $set_handlers = sub { + my $on_key = shift; + # Default is to do nothing. + return [] unless $on_key; + my $ref = ref $on_key; + if ($ref) { + $on_key = [$on_key] unless $ref eq 'ARRAY'; + # Make sure they're all handlers. + foreach my $h (@$on_key) { + if (my $r = ref $h) { + Carp::croak("$r object is not an App::Info::Handler") + unless UNIVERSAL::isa($h, 'App::Info::Handler'); + } else { + # Look up the handler. + $h = App::Info::Handler->new( key => $h); + } + } + # Return 'em! + return $on_key; + } else { + # Look up the handler. + return [ App::Info::Handler->new( key => $on_key) ]; + } +}; + +############################################################################## +############################################################################## + +=head1 INTERFACE + +This section documents the public interface of App::Info. + +=head2 Constructor + +=head3 new + + my $app = App::Info::Category::FooApp->new(@params); + +Constructs an App::Info object and returns it. The @params arguments define +how the App::Info object will respond to certain events, and correspond to +their like-named methods. See the L<"Event Handler Object Methods"> section +for more information on App::Info events and how to handle them. The +parameters to C<new()> for the different types of App::Info events are: + +=over 4 + +=item on_info + +=item on_error + +=item on_unknown + +=item on_confirm + +=back + +When passing event handlers to C<new()>, the list of handlers for each type +should be an anonymous array, for example: + + my $app = App::Info::Category::FooApp->new( on_info => \@handlers ); + +=cut + +sub new { + my ($pkg, %p) = @_; + my $class = ref $pkg || $pkg; + # Fail if the method isn't overridden. + $croak->($pkg, 'new') if $class eq __PACKAGE__; + + # Set up handlers. + for (qw(on_error on_unknown on_info on_confirm)) { + $p{$_} = $set_handlers->($p{$_}); + } + + # Do it! + return bless \%p, $class; +} + +############################################################################## +############################################################################## + +=head2 Metadata Object Methods + +These are abstract methods in App::Info and must be provided by its +subclasses. They provide the essential metadata of the software package +supported by the App::Info subclass. + +=head3 key_name + + my $key_name = $app->key_name; + +Returns a string that uniquely identifies the software for which the App::Info +subclass provides data. This value should be unique across all App::Info +classes. Typically, it's simply the name of the software. + +=cut + +sub key_name { $croak->(shift, 'key_name') } + +=head3 installed + + if ($app->installed) { + print "App is installed.\n" + } else { + print "App is not installed.\n" + } + +Returns a true value if the application is installed, and a false value if it +is not. + +=cut + +sub installed { $croak->(shift, 'installed') } + +############################################################################## + +=head3 name + + my $name = $app->name; + +Returns the name of the application. + +=cut + +sub name { $croak->(shift, 'name') } + +############################################################################## + +=head3 version + + my $version = $app->version; + +Returns the full version number of the application. + +=cut + +############################################################################## + +sub version { $croak->(shift, 'version') } + +=head3 major_version + + my $major_version = $app->major_version; + +Returns the major version number of the application. For example, if +C<version()> returns "7.1.2", then this method returns "7". + +=cut + +sub major_version { $croak->(shift, 'major_version') } + +############################################################################## + +=head3 minor_version + + my $minor_version = $app->minor_version; + +Returns the minor version number of the application. For example, if +C<version()> returns "7.1.2", then this method returns "1". + +=cut + +sub minor_version { $croak->(shift, 'minor_version') } + +############################################################################## + +=head3 patch_version + + my $patch_version = $app->patch_version; + +Returns the patch version number of the application. For example, if +C<version()> returns "7.1.2", then this method returns "2". + +=cut + +sub patch_version { $croak->(shift, 'patch_version') } + +############################################################################## + +=head3 bin_dir + + my $bin_dir = $app->bin_dir; + +Returns the full path the application's bin directory, if it exists. + +=cut + +sub bin_dir { $croak->(shift, 'bin_dir') } + +############################################################################## + +=head3 inc_dir + + my $inc_dir = $app->inc_dir; + +Returns the full path the application's include directory, if it exists. + +=cut + +sub inc_dir { $croak->(shift, 'inc_dir') } + +############################################################################## + +=head3 lib_dir + + my $lib_dir = $app->lib_dir; + +Returns the full path the application's lib directory, if it exists. + +=cut + +sub lib_dir { $croak->(shift, 'lib_dir') } + +############################################################################## + +=head3 so_lib_dir + + my $so_lib_dir = $app->so_lib_dir; + +Returns the full path the application's shared library directory, if it +exists. + +=cut + +sub so_lib_dir { $croak->(shift, 'so_lib_dir') } + +############################################################################## + +=head3 home_url + + my $home_url = $app->home_url; + +The URL for the software's home page. + +=cut + +sub home_url { $croak->(shift, 'home_url') } + +############################################################################## + +=head3 download_url + + my $download_url = $app->download_url; + +The URL for the software's download page. + +=cut + +sub download_url { $croak->(shift, 'download_url') } + +############################################################################## +############################################################################## + +=head2 Event Handler Object Methods + +These methods provide control over App::Info event handling. Events can be +handled by one or more objects of subclasses of App::Info::Handler. The first +to return a true value will be the last to execute. This approach allows +handlers to be stacked, and makes it relatively easy to create new handlers. +L<App::Info::Handler|App::Info::Handler> for information on writing event +handlers. + +Each of the event handler methods takes a list of event handlers as its +arguments. If none are passed, the existing list of handlers for the relevant +event type will be returned. If new handlers are passed in, they will be +returned. + +The event handlers may be specified as one or more objects of the +App::Info::Handler class or subclasses, as one or more strings that tell +App::Info construct such handlers itself, or a combination of the two. The +strings can only be used if the relevant App::Info::Handler subclasses have +registered strings with App::Info. For example, the App::Info::Handler::Print +class included in the App::Info distribution registers the strings "stderr" +and "stdout" when it starts up. These strings may then be used to tell +App::Info to construct App::Info::Handler::Print objects that print to STDERR +or to STDOUT, respectively. See the App::Info::Handler subclasses for what +strings they register with App::Info. + +=head3 on_info + + my @handlers = $app->on_info; + $app->on_info(@handlers); + +Info events are triggered when the App::Info subclass wants to send an +informational status message. By default, these events are ignored, but a +common need is for such messages to simply print to STDOUT. Use the +L<App::Info::Handler::Print|App::Info::Handler::Print> class included with the +App::Info distribution to have info messages print to STDOUT: + + use App::Info::Handler::Print; + $app->on_info('stdout'); + # Or: + my $stdout_handler = App::Info::Handler::Print->new('stdout'); + $app->on_info($stdout_handler); + +=cut + +sub on_info { + my $self = shift; + $self->{on_info} = $set_handlers->(\@_) if @_; + return @{ $self->{on_info} }; +} + +=head3 on_error + + my @handlers = $app->on_error; + $app->on_error(@handlers); + +Error events are triggered when the App::Info subclass runs into an unexpected +but not fatal problem. (Note that fatal problems will likely throw an +exception.) By default, these events are ignored. A common way of handling +these events is to print them to STDERR, once again using the +L<App::Info::Handler::Print|App::Info::Handler::Print> class included with the +App::Info distribution: + + use App::Info::Handler::Print; + my $app->on_error('stderr'); + # Or: + my $stderr_handler = App::Info::Handler::Print->new('stderr'); + $app->on_error($stderr_handler); + +Another approach might be to turn such events into fatal exceptions. Use the +included L<App::Info::Handler::Carp|App::Info::Handler::Carp> class for this +purpose: + + use App::Info::Handler::Carp; + my $app->on_error('croak'); + # Or: + my $croaker = App::Info::Handler::Carp->new('croak'); + $app->on_error($croaker); + +=cut + +sub on_error { + my $self = shift; + $self->{on_error} = $set_handlers->(\@_) if @_; + return @{ $self->{on_error} }; +} + +=head3 on_unknown + + my @handlers = $app->on_unknown; + $app->on_uknown(@handlers); + +Unknown events are trigged when the App::Info subclass cannot find the value +to be returned by a method call. By default, these events are ignored. A +common way of handling them is to have the application prompt the user for the +relevant data. The App::Info::Handler::Prompt class included with the +App::Info distribution can do just that: + + use App::Info::Handler::Prompt; + my $app->on_unknown('prompt'); + # Or: + my $prompter = App::Info::Handler::Prompt; + $app->on_unknown($prompter); + +See L<App::Info::Handler::Prompt|App::Info::Handler::Prompt> for information +on how it works. + +=cut + +sub on_unknown { + my $self = shift; + $self->{on_unknown} = $set_handlers->(\@_) if @_; + return @{ $self->{on_unknown} }; +} + +=head3 on_confirm + + my @handlers = $app->on_confirm; + $app->on_confirm(@handlers); + +Confirm events are triggered when the App::Info subclass has found an +important piece of information (such as the location of the executable it'll +use to collect information for the rest of its methods) and wants to confirm +that the information is correct. These events will most often be triggered +during the App::Info subclass object construction. Here, too, the +App::Info::Handler::Prompt class included with the App::Info distribution can +help out: + + use App::Info::Handler::Prompt; + my $app->on_confirm('prompt'); + # Or: + my $prompter = App::Info::Handler::Prompt; + $app->on_confirm($prompter); + +=cut + +sub on_confirm { + my $self = shift; + $self->{on_confirm} = $set_handlers->(\@_) if @_; + return @{ $self->{on_confirm} }; +} + +############################################################################## +############################################################################## + +=head1 SUBCLASSING + +As an abstract base class, App::Info is not intended to be used directly. +Instead, you'll use concrete subclasses that implement the interface it +defines. These subclasses each provide the metadata necessary for a given +software package, via the interface outlined above (plus any additional +methods the class author deems sensible for a given application). + +This section describes the facilities App::Info provides for subclassing. The +goal of the App::Info design has been to make subclassing straight-forward, so +that developers can focus on gathering the data they need for their +application and minimize the work necessary to handle unknown values or to +confirm values. As a result, there are essentially three concepts that +developers need to understand when subclassing App::Info: organization, +utility methods, and events. + +=head2 Organization + +The organizational idea behind App::Info is to name subclasses by broad +software categories. This approach allows the categories themselves to +function as abstract base classes that extend App::Info, so that they can +specify more methods for all of their base classes to implement. For example, +App::Info::HTTPD has specified the C<httpd_root()> abstract method that its +subclasses must implement. So as you get ready to implement your own subclass, +think about what category of software you're gathering information about. +New categories can be added as necessary. + +=head2 Utility Methods + +Once you've decided on the proper category, you can start implementing your +App::Info concrete subclass. As you do so, take advantage of App::Info::Util, +wherein I've tried to encapsulate common functionality to make subclassing +easier. I found that most of what I was doing repetitively was looking for +files and directories, and searching through files. Thus, App::Info::Util +subclasses L<File::Spec|File::Spec> in order to offer easy access to +commonly-used methods from that class, e.g., C<path()>. Plus, it has several +of its own methods to assist you in finding files and directories in lists of +files and directories, as well as methods for searching through files and +returning the values found in those files. See +L<App::Info::Util|App::Info::Util> for more information, and the App::Info +subclasses in this distribution for usage examples. + +I recommend the use of a package-scoped lexical App::Info::Util object. That +way it's nice and handy when you need to carry out common tasks. If you find +you're doing something over and over that's not already addressed by an +App::Info::Util method, consider submitting a patch to App::Info::Util to add +the functionality you need. + +=head2 Events + +Use the methods described below to trigger events. Events are designed to +provide a simple way for App::Info subclass developers to send status messages +and errors, to confirm data values, and to request a value when the class +caonnot determine a value itself. Events may optionally be handled by module +users who assign App::Info::Handler subclass objects to your App::Info +subclass object using the event handling methods described in the L<"Event +Handler Object Methods"> section. + +=cut + +############################################################################## +# This code reference is used by the event methods to manage the stack of +# event handlers that may be available to handle each of the events. +my $handler = sub { + my ($self, $meth, $params) = @_; + + # Sanity check. We really want to keep control over this. + Carp::croak("Cannot call protected method $meth()") + unless UNIVERSAL::isa($self, scalar caller(1)); + + # Create the request object. + $params->{type} ||= $meth; + my $req = App::Info::Request->new(%$params); + + # Do the deed. The ultimate handling handler may die. + foreach my $eh (@{$self->{"on_$meth"}}) { + last if $eh->handler($req); + } + + # Return the requst. + return $req; +}; + +############################################################################## + +=head3 info + + $self->info(@message); + +Use this method to display status messages for the user. You may wish to use +it to inform users that you're searching for a particular file, or attempting +to parse a file or some other resource for the data you need. For example, a +common use might be in the object constructor: generally, when an App::Info +object is created, some important initial piece of information is being +sought, such as an executable file. That file may be in one of many locations, +so it makes sense to let the user know that you're looking for it: + + $self->info("Searching for executable"); + +Note that, due to the nature of App::Info event handlers, your informational +message may be used or displayed any number of ways, or indeed not at all (as +is the default behavior). + +The C<@message> will be joined into a single string and stored in the +C<message> attribute of the App::Info::Request object passed to info event +handlers. + +=cut + +sub info { + my $self = shift; + # Execute the handler sequence. + my $req = $handler->($self, 'info', { message => join '', @_ }); +} + +############################################################################## + +=head3 error + + $self->error(@error); + +Use this method to inform the user that something unexpected has happened. An +example might be when you invoke another program to parse its output, but it's +output isn't what you expected: + + $self->error("Unable to parse version from `/bin/myapp -c`"); + +As with all events, keep in mind that error events may be handled in any +number of ways, or not at all. + +The C<@erorr> will be joined into a single string and stored in the C<message> +attribute of the App::Info::Request object passed to error event handlers. If +that seems confusing, think of it as an "error message" rather than an "error +error." :-) + +=cut + +sub error { + my $self = shift; + # Execute the handler sequence. + my $req = $handler->($self, 'error', { message => join '', @_ }); +} + +############################################################################## + +=head3 unknown + + my $val = $self->unknown(@params); + +Use this method when a value is unknown. This will give the user the option -- +assuming the appropriate handler handles the event -- to provide the needed +data. The value entered will be returned by C<unknown()>. The parameters are +as follows: + +=over 4 + +=item key + +The C<key> parameter uniquely identifies the data point in your class, and is +used by App::Info to ensure that an unknown event is handled only once, no +matter how many times the method is called. The same value will be returned by +subsequent calls to C<unknown()> as was returned by the first call, and no +handlers will be activated. Typical values are "version" and "lib_dir". + +=item prompt + +The C<prompt> parameter is the prompt to be displayed should an event handler +decide to prompt for the appropriate value. Such a prompt might be something +like "Path to your httpd executable?". If this parameter is not provided, +App::Info will construct one for you using your class' C<key_name()> method +and the C<key> parameter. The result would be something like "Enter a valid +FooApp version". The C<prompt> parameter value will be stored in the +C<message> attribute of the App::Info::Request object passed to event +handlers. + +=item callback + +Assuming a handler has collected a value for your unknown data point, it might +make sense to validate the value. For example, if you prompt the user for a +directory location, and the user enters one, it makes sense to ensure that the +directory actually exists. The C<callback> parameter allows you to do this. It +is a code reference that takes the new value or values as its arguments, and +returns true if the value is valid, and false if it is not. For the sake of +convenience, the first argument to the callback code reference is also stored +in C<$_> .This makes it easy to validate using functions or operators that, +er, operate on C<$_> by default, but still allows you to get more information +from C<@_> if necessary. For the directory example, a good callback might be +C<sub { -d }>. The C<callback> parameter code reference will be stored in the +C<callback> attribute of the App::Info::Request object passed to event +handlers. + +=item error + +The error parameter is the error message to display in the event that the +C<callback> code reference returns false. This message may then be used by the +event handler to let the user know what went wrong with the data she entered. +For example, if the unknown value was a directory, and the user entered a +value that the C<callback> identified as invalid, a message to display might +be something like "Invalid directory path". Note that if the C<error> +parameter is not provided, App::Info will supply the generic error message +"Invalid value". This value will be stored in the C<error> attribute of the +App::Info::Request object passed to event handlers. + +=back + +This may be the event method you use most, as it should be called in every +metadata method if you cannot provide the data needed by that method. It will +typically be the last part of the method. Here's an example demonstrating each +of the above arguments: + + my $dir = $self->unknown( key => 'lib_dir', + prompt => "Enter lib directory path", + callback => sub { -d }, + error => "Not a directory"); + +=cut + +sub unknown { + my ($self, %params) = @_; + my $key = delete $params{key} + or Carp::croak("No key parameter passed to unknown()"); + # Just return the value if we've already handled this value. Ideally this + # shouldn't happen. + return $self->{__unknown__}{$key} if exists $self->{__unknown__}{$key}; + + # Create a prompt and error message, if necessary. + $params{message} = delete $params{prompt} || + "Enter a valid " . $self->key_name . " $key"; + $params{error} ||= 'Invalid value'; + + # Execute the handler sequence. + my $req = $handler->($self, "unknown", \%params); + + # Mark that we've provided this value and then return it. + $self->{__unknown__}{$key} = $req->value; + return $self->{__unknown__}{$key}; +} + +############################################################################## + +=head3 confirm + + my $val = $self->confirm(@params); + +This method is very similar to C<unknown()>, but serves a different purpose. +Use this method for significant data points where you've found an appropriate +value, but want to ensure it's really the correct value. A "significant data +point" is usually a value essential for your class to collect metadata values. +For example, you might need to locate an executable that you can then call to +collect other data. In general, this will only happen once for an object -- +during object construction -- but there may be cases in which it is needed +more than that. But hopefully, once you've confirmed in the constructor that +you've found what you need, you can use that information to collect the data +needed by all of the metadata methods and can assume that they'll be right +because that first, significant data point has been confirmed. + +Other than where and how often to call C<confirm()>, its use is quite similar +to that of C<unknown()>. Its parameters are as follows: + +=over + +=item key + +Same as for C<unknown()>, a string that uniquely identifies the data point in +your class, and ensures that the event is handled only once for a given key. +The same value will be returned by subsequent calls to C<confirm()> as was +returned by the first call for a given key. + +=item prompt + +Same as for C<unknown()>. Although C<confirm()> is called to confirm a value, +typically the prompt should request the relevant value, just as for +C<unknown()>. The difference is that the handler I<should> use the C<value> +parameter as the default should the user not provide a value. The C<prompt> +parameter will be stored in the C<message> attribute of the App::Info::Request +object passed to event handlers. + +=item value + +The value to be confirmed. This is the value you've found, and it will be +provided to the user as the default option when they're prompted for a new +value. This value will be stored in the C<value> attribute of the +App::Info::Request object passed to event handlers. + +=item callback + +Same as for C<unknown()>. Because the user can enter data to replace the +default value provided via the C<value> parameter, you might want to validate +it. Use this code reference to do so. The callback will be stored in the +C<callback> attribute of the App::Info::Request object passed to event +handlers. + +=item error + +Same as for C<unknown()>: an error message to display in the event that a +value entered by the user isn't validated by the C<callback> code reference. +This value will be stored in the C<error> attribute of the App::Info::Request +object passed to event handlers. + +=back + +Here's an example usage demonstrating all of the above arguments: + + my $exe = $self->confirm( key => 'shell', + prompt => 'Path to your shell?', + value => '/bin/sh', + callback => sub { -x }, + error => 'Not an executable'); + + +=cut + +sub confirm { + my ($self, %params) = @_; + my $key = delete $params{key} + or Carp::croak("No key parameter passed to confirm()"); + return $self->{__confirm__}{$key} if exists $self->{__confirm__}{$key}; + + # Create a prompt and error message, if necessary. + $params{message} = delete $params{prompt} || + "Enter a valid " . $self->key_name . " $key"; + $params{error} ||= 'Invalid value'; + + # Execute the handler sequence. + my $req = $handler->($self, "confirm", \%params); + + # Mark that we've confirmed this value. + $self->{__confirm__}{$key} = $req->value; + + return $self->{__confirm__}{$key} +} + +1; +__END__ + +=head2 Event Examples + +Below I provide some examples demonstrating the use of the event methods. +These are meant to emphasize the contexts in which it's appropriate to use +them. + +Let's start with the simplest, first. Let's say that to find the version +number for an application, you need to search a file for the relevant data. +Your App::Info concrete subclass might have a private method that handles this +work, and this method is the appropriate place to use the C<info()> and, if +necessary, C<error()> methods. + + sub _find_version { + my $self = shift; + + # Try to find the revelant file. We cover this method below. + # Just return if we cant' find it. + my $file = $self->_find_file('version.conf') or return; + + # Send a status message. + $self->info("Searching '$file' file for version"); + + # Search the file. $util is an App::Info::Util object. + my $ver = $util->search_file($file, qr/^Version\s+(.*)$/); + + # Trigger an error message, if necessary. We really think we'll have the + # value, but we have to cover our butts in the unlikely event that we're + # wrong. + $self->error("Unable to find version in file '$file'") unless $ver; + + # Return the version number. + return $ver; + } + +Here we've used the C<info()> method to display a status message to let the +user know what we're doing. Then we used the C<error()> method when something +unexpected happened, which in this case was that we weren't able to find the +version number in the file. + +Note the C<_find_file()> method we've thrown in. This might be a method that +we call whenever we need to find a file that might be in one of a list of +directories. This method, too, will be an appropriate place for an C<info()> +method call. But rather than call the C<error()> method when the file can't be +found, you might want to give an event handler a chance to supply that value +for you. Use the C<unknown()> method for a case such as this: + + sub _find_file { + my ($self, $file) = @_; + + # Send a status message. + $self->info("Searching for '$file' file"); + + # Look for the file. See App::Info:Utility for its interface. + my @paths = qw(/usr/conf /etc/conf /foo/conf); + my $found = $util->first_cat_path($file, @paths); + + # If we didn't find it, trigger an unknown event to + # give a handler a chance to get the value. + $found ||= $self->unknown( key => "file_$file", + prompt => "Location of '$file' file?", + callback => sub { -f }, + error => "Not a file"); + + # Now return the file name, regardless of whether we found it or not. + return $found; + } + +Note how in this method, we've tried to locate the file ourselves, but if we +can't find it, we trigger an unknown event. This allows clients of our +App::Info subclass to try to establish the value themselves by having an +App::Info::Handler subclass handle the event. If a value is found by an +App::Info::Handler subclass, it will be returned by C<unknown()> and we can +continue. But we can't assume that the unknown event will even be handled, and +thus must expect that an unknown value may remain unknown. This is why the +C<_find_version()> method above simply returns if C<_find_file()> doesn't +return a file name; there's no point in searching through a file that doesn't +exist. + +Attentive readers may be left to wonder how to decide when to use C<error()> +and when to use C<unknown()>. To a large extent, this decision must be based +on one's own understanding of what's most appropriate. Nevertheless, I offer +the following simple guidelines: Use C<error()> when you expect something to +work and then it just doesn't (as when a file exists and should contain the +information you seek, but then doesn't). Use C<unknown()> when you're less +sure of your processes for finding the value, and also for any of the values +that should be returned by any of the L<metadata object methods|"Metadata +Object Methods">. And of course, C<error()> would be more appropriate when you +encounter an unexpected condition and don't think that it could be handled in +any other way. + +Now, more than likely, a method such C<_find_version()> would be called by the +C<version()> method, which is a metadata method mandated by the App::Info +abstract base class. This is an appropriate place to handle an unknown version +value. Indeed, every one of your metadata methods should make use of the +C<unknown()> method. The C<version()> method then should look something like +this: + + sub version { + my $self = shift; + + unless (exists $self->{version}) { + # Try to find the version number. + $self->{version} = $self->_find_version || + $self->unknown( key => 'version', + prompt => "Enter the version number"); + } + + # Now return the version number. + return $self->{version}; + } + +Note how this method only tries to find the version number once. Any +subsequent calls to C<version()> will return the same value that was returned +the first time it was called. Of course, thanks to the C<key> parameter in the +call to C<unknown()>, we could have have tried to enumerate the version number +every time, as C<unknown()> will return the same value every time it is called +(as, indeed, should C<_find_version()>. But by checking for the C<version> key +in C<$self> ourselves, we save some of the overhead. + +But as I said before, every metadata method should make use of the +C<unknown()> method. Thus, the C<major()> method might looks something like +this: + + sub major { + my $self = shift; + + unless (exists $self->{major}) { + # Try to get the major version from the full version number. + ($self->{major}) = $self->version =~ /^(\d+)\./; + # Handle an unknown value. + $self->{major} = $self->unknown( key => 'major', + prompt => "Enter major version", + callback => sub { /^\d+$/ }, + error => "Not a number") + unless defined $self->{major}; + } + + return $self->{version}; + } + +Finally, the C<confirm()> method should be used to verify core pieces of data +that significant numbers of other methods rely on. Typically such data are +executables or configuration files from which will be drawn other metadata. +Most often, such major data points will be sought in the object constructor. +Here's an example: + + sub new { + # Construct the object so that handlers will work properly. + my $self = shift->SUPER::new(@_); + + # Try to find the executable. + $self->info("Searching for executable"); + if (my $exe = $util->first_exe('/bin/myapp', '/usr/bin/myapp')) { + # Confirm it. + $self->{exe} = + $self->confirm( key => 'binary', + prompt => 'Path to your executable?', + value => $exe, + callback => sub { -x }, + error => 'Not an executable'); + } else { + # Handle an unknown value. + $self->{exe} = + $self->unknown( key => 'binary', + prompt => 'Path to your executable?', + callback => sub { -x }, + error => 'Not an executable'); + } + + # We're done. + return $self; + } + +By now, most of what's going on here should be quite familiar. The use of the +C<confirm()> method is quite similar to that of C<unknown()>. Really the only +difference is that the value is known, but we need verification or a new value +supplied if the value we found isn't correct. Such may be the case when +multiple copies of the executable have been installed on the system, we found +F</bin/myapp>, but the user may really be interested in F</usr/bin/myapp>. +Thus the C<confirm()> event gives the user the chance to change the value if +the confirm event is handled. + +The final thing to note about this constructor is the first line: + + my $self = shift->SUPER::new(@_); + +The first thing an App::Info subclass should do is execute this line to allow +the super class to construct the object first. Doing so allows any event +handling arguments to set up the event handlers, so that when we call +C<confirm()> or C<unknown()> the event will be handled as the client expects. + +If we needed our subclass constructor to take its own parameter argumente, the +approach is to specify the same C<key => $arg> syntax as is used by +App::Info's C<new()> method. Say we wanted to allow clients of our App::Info +subclass to pass in a list of alternate executable locations for us to search. +Such an argument would most make sense as an array reference. So we specify +that the key be C<alt_paths> and allow the user to construct an object like +this: + + my $app = App::Info::Category::FooApp->new( alt_paths => \@paths ); + +This approach allows the super class constructor arguments to pass unmolested +(as long as we use unique keys!): + + my $app = App::Info::Category::FooApp->new( on_error => \@handlers, + alt_paths => \@paths ); + +Then, to retrieve these paths inside our C<new()> constructor, all we need do +is access them directly from the object: + + my $self = shift->SUPER::new(@_); + my $alt_paths = $self->{alt_paths}; + +=head2 Subclassing Guidelines + +To summarize, here are some guidelines for subclassing App::Info. + +=over 4 + +=item * + +Always subclass an App::Info category subclass. This will help to keep the +App::Info namespace well-organized. New categories can be added as needed. + +=item * + +When you create the C<new()> constructor, always call C<SUPER::new(@_)>. This +ensures that the event handling methods methods defined by the App::Info base +classes (e.g., C<error()>) will work properly. + +=item * + +Use a package-scoped lexical App::Info::Util object to carry out common tasks. +If you find you're doing something over and over that's not already addressed +by an App::Info::Util method, and you think that others might find your +solution useful, consider submitting a patch to App::Info::Util to add the +functionality you need. See L<App::Info::Util|App::Info::Util> for complete +documentation of its interface. + +=item * + +Use the C<info()> event triggering method to send messages to users of your +subclass. + +=item * + +Use the C<error()> event triggering method to alert users of unexpected +conditions. Fatal errors should still be fatal; use C<Carp::croak()> to throw +exceptions for fatal errors. + +=item * + +Use the C<unknown()> event triggering method when a metadata or other +important value is unknown and you want to give any event handlers the chance +to provide the data. + +=item * + +Use the C<confirm()> event triggering method when a core piece of data is +known (such as the location of an executable in the C<new()> constructor) and +you need to make sure that you have the I<correct> information. + +=item * + +Be sure to implement B<all> of the abstract methods defined by App::Info and +by your category abstract base class -- even if they don't do anything. Doing +so ensures that all App::Info subclasses share a common interface, and can, if +necessary, be used without regard to subclass. Any method not implemented but +called on an object will generate a fatal exception. + +=back + +Otherwise, have fun! There are a lot of software packages for which relevant +information might be collected and aggregated into an App::Info concrete +subclass (witness all of the Automake macros in the world!), and folks who are +knowledgeable about particular software packages or categories of software are +warmly invited to contribute. As more subclasses are implemented, it will make +sense, I think, to create separate distributions based on category -- or even, +when necessary, on a single software package. Broader categories can then be +aggregated in Bundle distributions. + +But I get ahead of myself... + +=head1 BUGS + +Report all bugs via the CPAN Request Tracker at +L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=App-Info>. + +=head1 AUTHOR + +David Wheeler <L<david@wheeler.net|"david@wheeler.net">> + +=head1 SEE ALSO + +The following classes define a few software package categories in which +App::Info subclasses can be placed. Check them out for ideas on how to +create new category subclasses. + +=over 4 + +=item L<App::Info::HTTP|App::Info::HTTPD> + +=item L<App::Info::RDBMS|App::Info::RDBMS> + +=item L<App::Info::Lib|App::Info::Lib> + +=back + +The following classes implement the App::Info interface for various software +packages. Check them out for examples of how to implement new App::Info +concrete subclasses. + +=over + +=item L<App::Info::HTTPD::Apache|App::Info::HTTPD::Apache> + +=item L<App::Info::RDBMS::PostgreSQL|App::Info::RDBMS::PostgreSQL> + +=item L<App::Info::Lib::Expat|App::Info::Lib::Expat> + +=item L<App::Info::Lib::Iconv|App::Info::Lib::Iconv> + +=back + +L<App::Info::Util|App::Info::Util> provides utility methods for App::Info +subclasses. + +L<App::Info::Handler|App::Info::Handler> defines an interface for event +handlers to subclass. Consult its documentation for information on creating +custom event handlers. + +The following classes implement the App::Info::Handler interface to offer some +simple event handling. Check them out for examples of how to implement new +App::Info::Handler subclasses. + +=over 4 + +=item L<App::Info::Handler::Print|App::Info::Handler::Print> + +=item L<App::Info::Handler::Carp|App::Info::Handler::Carp> + +=item L<App::Info::Handler::Prompt|App::Info::Handler::Prompt> + +=back + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2002, David Wheeler. All Rights Reserved. + +This module is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=cut diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/Handler.pm b/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/Handler.pm new file mode 100644 index 0000000..65416a8 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/Handler.pm @@ -0,0 +1,305 @@ +package App::Info::Handler; + +# $Id: Handler.pm,v 1.1 2004-04-29 09:21:28 ivan Exp $ + +=head1 NAME + +App::Info::Handler - App::Info event handler base class + +=head1 SYNOPSIS + + use App::Info::Category::FooApp; + use App::Info::Handler; + + my $app = App::Info::Category::FooApp->new( on_info => ['default'] ); + +=head1 DESCRIPTION + +This class defines the interface for subclasses that wish to handle events +triggered by App::Info concrete subclasses. The different types of events +triggered by App::Info can all be handled by App::Info::Handler (indeed, by +default they're all handled by a single App::Info::Handler object), and +App::Info::Handler subclasses may be designed to handle whatever events they +wish. + +If you're interested in I<using> an App::Info event handler, this is probably +not the class you should look at, since all it does is define a simple handler +that does nothing with an event. Look to the L<App::Info::Handler +subclasses|"SEE ALSO"> included in this distribution to do more interesting +things with App::Info events. + +If, on the other hand, you're interested in implementing your own event +handlers, read on! + +=cut + +use strict; +use vars qw($VERSION); +$VERSION = '0.22'; + +my %handlers; + +=head1 INTERFACE + +This section documents the public interface of App::Info::Handler. + +=head2 Class Method + +=head3 register_handler + + App::Info::Handler->register_handler( $key => $code_ref ); + +This class method may be used by App::Info::Handler subclasses to register +themselves with App::Info::Handler. Multiple registrations are supported. The +idea is that a subclass can define different functionality by specifying +different strings that represent different modes of constructing an +App::Info::Handler subclass object. The keys are case-sensitve, and should be +unique across App::Info::Handler subclasses so that many subclasses can be +loaded and used separately. If the C<$key> is already registered, +C<register_handler()> will throw an exception. The values are code references +that, when executed, return the appropriate App::Info::Handler subclass +object. + +=cut + +sub register_handler { + my ($pkg, $key, $code) = @_; + Carp::croak("Handler '$key' already exists") + if $handlers{$key}; + $handlers{$key} = $code; +} + +# Register ourself. +__PACKAGE__->register_handler('default', sub { __PACKAGE__->new } ); + +############################################################################## + +=head2 Constructor + +=head3 new + + my $handler = App::Info::Handler->new; + $handler = App::Info::Handler->new( key => $key); + +Constructs an App::Info::Handler object and returns it. If the key parameter +is provided and has been registered by an App::Info::Handler subclass via the +C<register_handler()> class method, then the relevant code reference will be +executed and the resulting App::Info::Handler subclass object returned. This +approach provides a handy shortcut for having C<new()> behave as an abstract +factory method, returning an object of the subclass appropriate to the key +parameter. + +=cut + +sub new { + my ($pkg, %p) = @_; + my $class = ref $pkg || $pkg; + $p{key} ||= 'default'; + if ($class eq __PACKAGE__ && $p{key} ne 'default') { + # We were called directly! Handle it. + Carp::croak("No such handler '$p{key}'") unless $handlers{$p{key}}; + return $handlers{$p{key}}->(); + } else { + # A subclass called us -- just instantiate and return. + return bless \%p, $class; + } +} + +=head2 Instance Method + +=head3 handler + + $handler->handler($req); + +App::Info::Handler defines a single instance method that must be defined by +its subclasses, C<handler()>. This is the method that will be executed by an +event triggered by an App::Info concrete subclass. It takes as its single +argument an App::Info::Request object, and returns a true value if it has +handled the event request. Returning a false value declines the request, and +App::Info will then move on to the next handler in the chain. + +The C<handler()> method implemented in App::Info::Handler itself does nothing +more than return a true value. It thus acts as a very simple default event +handler. See the App::Info::Handler subclasses for more interesting handling +of events, or create your own! + +=cut + +sub handler { 1 } + +1; +__END__ + +=head1 SUBCLASSING + +I hatched the idea of the App::Info event model with its subclassable handlers +as a way of separating the aggregation of application metadata from writing a +user interface for handling certain conditions. I felt it a better idea to +allow people to create their own user interfaces, and instead to provide only +a few examples. The App::Info::Handler class defines the API interface for +handling these conditions, which App::Info refers to as "events". + +There are various types of events defined by App::Info ("info", "error", +"unknown", and "confirm"), but the App::Info::Handler interface is designed to +be flexible enough to handle any and all of them. If you're interested in +creating your own App::Info event handler, this is the place to learn how. + +=head2 The Interface + +To create an App::Info event handler, all one need do is subclass +App::Info::Handler and then implement the C<new()> constructor and the +C<handler()> method. The C<new()> constructor can do anything you like, and +take any arguments you like. However, I do recommend that the first thing +you do in your implementation is to call the super constructor: + + sub new { + my $pkg = shift; + my $self = $pkg->SUPER::new(@_); + # ... other stuff. + return $self; + } + +Although the default C<new()> constructor currently doesn't do much, that may +change in the future, so this call will keep you covered. What it does do is +take the parameterized arguments and assign them to the App::Info::Handler +object. Thus if you've specified a "mode" argument, where clients can +construct objects of you class like this: + + my $handler = FooHandler->new( mode => 'foo' ); + +You can access the mode parameter directly from the object, like so: + + sub new { + my $pkg = shift; + my $self = $pkg->SUPER::new(@_); + if ($self->{mode} eq 'foo') { + # ... + } + return $self; + } + +Just be sure not to use a parameter key name required by App::Info::Handler +itself. At the moment, the only parameter accepted by App::Info::Handler is +"key", so in general you'll be pretty safe. + +Next, I recommend that you take advantage of the C<register_handler()> method +to create some shortcuts for creating handlers of your class. For example, say +we're creating a handler subclass FooHandler. It has two modes, a default +"foo" mode and an advanced "bar" mode. To allow both to be constructed by +stringified shortcuts, the FooHandler class implementation might start like +this: + + package FooHandler; + + use strict; + use App::Info::Handler; + use vars qw(@ISA); + @ISA = qw(App::Info::Handler); + + foreach my $c (qw(foo bar)) { + App::Info::Handler->register_handler + ( $c => sub { __PACKAGE__->new( mode => $c) } ); + } + +The strings "foo" and "bar" can then be used by clients as shortcuts to have +App::Info objects automatically create and use handlers for certain events. +For example, if a client wanted to use a "bar" event handler for its info +events, it might do this: + + use App::Info::Category::FooApp; + use FooHandler; + + my $app = App::Info::Category::FooApp->new(on_info => ['bar']); + +Take a look at App::Info::Handler::Print and App::Info::Handler::Carp to see +concrete examples of C<register_handler()> usage. + +The final step in creating a new App::Info event handler is to implement the +C<handler()> method itself. This method takes a single argument, an +App::Info::Request object, and is expected to return true if it handled the +request, and false if it did not. The App::Info::Request object contains all +the metadata relevant to a request, including the type of event that triggered +it; see L<App::Info::Request|App::Info::Request> for its documentation. + +Use the App::Info::Request object however you like to handle the request +however you like. You are, however, expected to abide by a a few guidelines: + +=over 4 + +=item * + +For error and info events, you are expected (but not required) to somehow +display the info or error message for the user. How your handler chooses to do +so is up to you and the handler. + +=item * + +For unknown and confirm events, you are expected to prompt the user for a +value. If it's a confirm event, offer the known value (found in +C<$req-E<gt>value>) as a default. + +=item * + +For unknown and confirm events, you are expected to call C<$req-E<gt>callback> +and pass in the new value. If C<$req-E<gt>callback> returns a false value, you +are expected to display the error message in C<$req-E<gt>error> and prompt the +user again. Note that C<$req-E<gt>value> calls C<$req-E<gt>callback> +internally, and thus assigns the value and returns true if +C<$req-E<gt>callback> returns true, and does not assign the value and returns +false if C<$req-E<gt>callback> returns false. + +=item * + +For unknown and confirm events, if you've collected a new value and +C<$req-E<gt>callback> returns true for that value, you are expected to assign +the value by passing it to C<$req-E<gt>value>. This allows App::Info to give +the value back to the calling App::Info concrete subclass. + +=back + +Probably the easiest way to get started creating new App::Info event handlers +is to check out the simple handlers provided with the distribution and follow +their logical examples. Consult the App::Info documentation of the L<event +methods|App::Info/"Events"> for details on how App::Info constructs the +App::Info::Request object for each event type. + +=head1 BUGS + +Report all bugs via the CPAN Request Tracker at +L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=App-Info>. + +=head1 AUTHOR + +David Wheeler <L<david@wheeler.net|"david@wheeler.net">> + +=head1 SEE ALSO + +L<App::Info|App::Info> thoroughly documents the client interface for setting +event handlers, as well as the event triggering interface for App::Info +concrete subclasses. + +L<App::Info::Request|App::Info::Request> documents the interface for the +request objects passed to App::Info::Handler C<handler()> methods. + +The following App::Info::Handler subclasses offer examples for event handler +authors, and, of course, provide actual event handling functionality for +App::Info clients. + +=over 4 + +=item L<App::Info::Handler::Carp|App::Info::Handler::Carp> + +=item L<App::Info::Handler::Print|App::Info::Handler::Print> + +=item L<App::Info::Handler::Prompt|App::Info::Handler::Prompt> + +=back + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2002, David Wheeler. All Rights Reserved. + +This module is free software; you can redistribute it and/or modify it under the +same terms as Perl itself. + +=cut diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/Handler/Prompt.pm b/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/Handler/Prompt.pm new file mode 100644 index 0000000..47edd78 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/Handler/Prompt.pm @@ -0,0 +1,170 @@ +package App::Info::Handler::Prompt; + +# $Id: Prompt.pm,v 1.1 2004-04-29 09:21:29 ivan Exp $ + +=head1 NAME + +App::Info::Handler::Prompt - Prompting App::Info event handler + +=head1 SYNOPSIS + + use App::Info::Category::FooApp; + use App::Info::Handler::Print; + + my $prompter = App::Info::Handler::Print->new; + my $app = App::Info::Category::FooApp->new( on_unknown => $prompter ); + + # Or... + my $app = App::Info::Category::FooApp->new( on_confirm => 'prompt' ); + +=head1 DESCRIPTION + +App::Info::Handler::Prompt objects handle App::Info events by printing their +messages to C<STDOUT> and then accepting a new value from C<STDIN>. The new +value is validated by any callback supplied by the App::Info concrete subclass +that triggered the event. If the value is valid, App::Info::Handler::Prompt +assigns the new value to the event request. If it isn't it prints the error +message associated with the event request, and then prompts for the data +again. + +Although designed with unknown and confirm events in mind, +App::Info::Handler::Prompt handles info and error events as well. It will +simply print info event messages to C<STDOUT> and print error event messages +to C<STDERR>. For more interesting info and error event handling, see +L<App::Info::Handler::Print|App::Info::Handler::Print> and +L<App::Info::Handler::Carp|App::Info::Handler::Carp>. + +Upon loading, App::Info::Handler::Print registers itself with +App::Info::Handler, setting up a single string, "prompt", that can be passed +to an App::Info concrete subclass constructor. This string is a shortcut that +tells App::Info how to create an App::Info::Handler::Print object for handling +events. + +=cut + +use strict; +use App::Info::Handler; +use vars qw($VERSION @ISA); +$VERSION = '0.22'; +@ISA = qw(App::Info::Handler); + +# Register ourselves. +App::Info::Handler->register_handler + ('prompt' => sub { __PACKAGE__->new('prompt') } ); + +=head1 INTERFACE + +=head2 Constructor + +=head3 new + + my $prompter = App::Info::Handler::Prompt->new; + +Constructs a new App::Info::Handler::Prompt object and returns it. No special +arguments are required. + +=cut + +sub new { + my $pkg = shift; + my $self = $pkg->SUPER::new(@_); + $self->{tty} = -t STDIN && ( -t STDOUT || !( -f STDOUT || -c STDOUT ) ); + # We're done! + return $self; +} + +my $get_ans = sub { + my ($prompt, $tty, $def) = @_; + # Print the message. + local $| = 1; + local $\; + print $prompt; + + # Collect the answer. + my $ans; + if ($tty) { + $ans = <STDIN>; + if (defined $ans ) { + chomp $ans; + } else { # user hit ctrl-D + print "\n"; + } + } else { + print "$def\n" if defined $def; + } + return $ans; +}; + +sub handler { + my ($self, $req) = @_; + my $ans; + my $type = $req->type; + if ($type eq 'unknown' || $type eq 'confirm') { + # We'll want to prompt for a new value. + my $val = $req->value; + my ($def, $dispdef) = defined $val ? ($val, " [$val] ") : ('', ' '); + my $msg = $req->message or Carp::croak("No message in request"); + $msg .= $dispdef; + + # Get the answer. + $ans = $get_ans->($msg, $self->{tty}, $def); + # Just return if they entered an empty string or we couldnt' get an + # answer. + return 1 unless defined $ans && $ans ne ''; + + # Validate the answer. + my $err = $req->error; + while (!$req->value($ans)) { + print "$err: '$ans'\n"; + $ans = $get_ans->($msg, $self->{tty}, $def); + return 1 unless defined $ans && $ans ne ''; + } + + } elsif ($type eq 'info') { + # Just print the message. + print STDOUT $req->message, "\n"; + } elsif ($type eq 'error') { + # Just print the message. + print STDERR $req->message, "\n"; + } else { + # This shouldn't happen. + Carp::croak("Invalid request type '$type'"); + } + + # Return true to indicate that we've handled the request. + return 1; +} + +1; +__END__ + +=head1 BUGS + +Report all bugs via the CPAN Request Tracker at +L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=App-Info>. + +=head1 AUTHOR + +David Wheeler <L<david@wheeler.net|"david@wheeler.net">> + +=head1 SEE ALSO + +L<App::Info|App::Info> documents the event handling interface. + +L<App::Info::Handler::Carp|App::Info::Handler::Carp> handles events by +passing their messages Carp module functions. + +L<App::Info::Handler::Print|App::Info::Handler::Print> handles events by +printing their messages to a file handle. + +L<App::Info::Handler|App::Info::Handler> describes how to implement custom +App::Info event handlers. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2002, David Wheeler. All Rights Reserved. + +This module is free software; you can redistribute it and/or modify it under the +same terms as Perl itself. + +=cut diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/RDBMS.pm b/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/RDBMS.pm new file mode 100644 index 0000000..504d570 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/RDBMS.pm @@ -0,0 +1,55 @@ +package App::Info::RDBMS; + +# $Id: RDBMS.pm,v 1.1 2004-04-29 09:21:28 ivan Exp $ + +use strict; +use App::Info; +use vars qw(@ISA $VERSION); +@ISA = qw(App::Info); +$VERSION = '0.22'; + +1; +__END__ + +=head1 NAME + +App::Info::RDBMS - Information about databases on a system + +=head1 DESCRIPTION + +This class is an abstract base class for App::Info subclasses that provide +information about relational databases. Its subclasses are required to +implement its interface. See L<App::Info|App::Info> for a complete description +and L<App::Info::RDBMS::PostgreSQL|App::Info::RDBMS::PostgreSQL> for an example +implementation. + +=head1 INTERFACE + +Currently, App::Info::RDBMS adds no more methods than those from its parent +class, App::Info. + +=head1 BUGS + +Report all bugs via the CPAN Request Tracker at +L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=App-Info>. + +=head1 AUTHOR + +David Wheeler <L<david@wheeler.net|"david@wheeler.net">> + +=head1 SEE ALSO + +L<App::Info|App::Info>, +L<App::Info::RDBMS::PostgreSQL|App::Info::RDBMS::PostgreSQL> + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2002, David Wheeler. All Rights Reserved. + +This module is free software; you can redistribute it and/or modify it under the +same terms as Perl itself. + +=cut + + + diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/RDBMS/PostgreSQL.pm b/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/RDBMS/PostgreSQL.pm new file mode 100644 index 0000000..aef326c --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/RDBMS/PostgreSQL.pm @@ -0,0 +1,730 @@ +package App::Info::RDBMS::PostgreSQL; + +# $Id: PostgreSQL.pm,v 1.1 2004-04-29 09:21:29 ivan Exp $ + +=head1 NAME + +App::Info::RDBMS::PostgreSQL - Information about PostgreSQL + +=head1 SYNOPSIS + + use App::Info::RDBMS::PostgreSQL; + + my $pg = App::Info::RDBMS::PostgreSQL->new; + + if ($pg->installed) { + print "App name: ", $pg->name, "\n"; + print "Version: ", $pg->version, "\n"; + print "Bin dir: ", $pg->bin_dir, "\n"; + } else { + print "PostgreSQL is not installed. :-(\n"; + } + +=head1 DESCRIPTION + +App::Info::RDBMS::PostgreSQL supplies information about the PostgreSQL +database server installed on the local system. It implements all of the +methods defined by App::Info::RDBMS. Methods that trigger events will trigger +them only the first time they're called (See L<App::Info|App::Info> for +documentation on handling events). To start over (after, say, someone has +installed PostgreSQL) construct a new App::Info::RDBMS::PostgreSQL object to +aggregate new metadata. + +Some of the methods trigger the same events. This is due to cross-calling of +shared subroutines. However, any one event should be triggered no more than +once. For example, although the info event "Executing `pg_config --version`" +is documented for the methods C<name()>, C<version()>, C<major_version()>, +C<minor_version()>, and C<patch_version()>, rest assured that it will only be +triggered once, by whichever of those four methods is called first. + +=cut + +use strict; +use App::Info::RDBMS; +use App::Info::Util; +use vars qw(@ISA $VERSION); +@ISA = qw(App::Info::RDBMS); +$VERSION = '0.22'; + +my $u = App::Info::Util->new; + +=head1 INTERFACE + +=head2 Constructor + +=head3 new + + my $pg = App::Info::RDBMS::PostgreSQL->new(@params); + +Returns an App::Info::RDBMS::PostgreSQL object. See L<App::Info|App::Info> for +a complete description of argument parameters. + +When it called, C<new()> searches the file system for the F<pg_config> +application. If found, F<pg_config> will be called by the object methods below +to gather the data necessary for each. If F<pg_config> cannot be found, then +PostgreSQL is assumed not to be installed, and each of the object methods will +return C<undef>. + +App::Info::RDBMS::PostgreSQL searches for F<pg_config> along your path, as +defined by C<File::Spec-E<gt>path>. Failing that, it searches the following +directories: + +=over 4 + +=item /usr/local/pgsql/bin + +=item /usr/local/postgres/bin + +=item /opt/pgsql/bin + +=item /usr/local/bin + +=item /usr/local/sbin + +=item /usr/bin + +=item /usr/sbin + +=item /bin + +=back + +B<Events:> + +=over 4 + +=item info + +Looking for pg_config + +=item confirm + +Path to pg_config? + +=item unknown + +Path to pg_config? + +=back + +=cut + +sub new { + # Construct the object. + my $self = shift->SUPER::new(@_); + + # Find pg_config. + $self->info("Looking for pg_config"); + my @paths = ($u->path, + qw(/usr/local/pgsql/bin + /usr/local/postgres/bin + /opt/pgsql/bin + /usr/local/bin + /usr/local/sbin + /usr/bin + /usr/sbin + /bin)); + + if (my $cfg = $u->first_cat_exe('pg_config', @paths)) { + # We found it. Confirm. + $self->{pg_config} = $self->confirm( key => 'pg_config', + prompt => 'Path to pg_config?', + value => $cfg, + callback => sub { -x }, + error => 'Not an executable'); + } else { + # Handle an unknown value. + $self->{pg_config} = $self->unknown( key => 'pg_config', + prompt => 'Path to pg_config?', + callback => sub { -x }, + error => 'Not an executable'); + } + + return $self; +} + +# We'll use this code reference as a common way of collecting data. +my $get_data = sub { + return unless $_[0]->{pg_config}; + $_[0]->info("Executing `$_[0]->{pg_config} $_[1]`"); + my $info = `$_[0]->{pg_config} $_[1]`; + chomp $info; + return $info; +}; + +############################################################################## + +=head2 Class Method + +=head3 key_name + + my $key_name = App::Info::RDBMS::PostgreSQL->key_name; + +Returns the unique key name that describes this class. The value returned is +the string "PostgreSQL". + +=cut + +sub key_name { 'PostgreSQL' } + +############################################################################## + +=head2 Object Methods + +=head3 installed + + print "PostgreSQL is ", ($pg->installed ? '' : 'not '), "installed.\n"; + +Returns true if PostgreSQL is installed, and false if it is not. +App::Info::RDBMS::PostgreSQL determines whether PostgreSQL is installed based +on the presence or absence of the F<pg_config> application on the file system +as found when C<new()> constructed the object. If PostgreSQL does not appear +to be installed, then all of the other object methods will return empty +values. + +=cut + +sub installed { return $_[0]->{pg_config} ? 1 : undef } + +############################################################################## + +=head3 name + + my $name = $pg->name; + +Returns the name of the application. App::Info::RDBMS::PostgreSQL parses the +name from the system call C<`pg_config --version`>. + +B<Events:> + +=over 4 + +=item info + +Executing `pg_config --version` + +=item error + +Failed to find PostgreSQL version with `pg_config --version` + +Unable to parse name from string + +Unable to parse version from string + +Failed to parse PostgreSQL version parts from string + +=item unknown + +Enter a valid PostgreSQL name + +=back + +=cut + +# This code reference is used by name(), version(), major_version(), +# minor_version(), and patch_version() to aggregate the data they need. +my $get_version = sub { + my $self = shift; + $self->{'--version'} = 1; + my $data = $get_data->($self, '--version'); + unless ($data) { + $self->error("Failed to find PostgreSQL version with ". + "`$self->{pg_config} --version"); + return; + } + + chomp $data; + my ($name, $version) = split /\s+/, $data, 2; + + # Check for and assign the name. + $name ? + $self->{name} = $name : + $self->error("Unable to parse name from string '$data'"); + + # Parse the version number. + if ($version) { + my ($x, $y, $z) = $version =~ /(\d+)\.(\d+).(\d+)/; + if (defined $x and defined $y and defined $z) { + @{$self}{qw(version major minor patch)} = + ($version, $x, $y, $z); + } else { + $self->error("Failed to parse PostgreSQL version parts from " . + "string '$version'"); + } + } else { + $self->error("Unable to parse version from string '$data'"); + } +}; + +sub name { + my $self = shift; + return unless $self->{pg_config}; + + # Load data. + $get_version->($self) unless $self->{'--version'}; + + # Handle an unknown name. + $self->{name} ||= $self->unknown( key => 'name' ); + + # Return the name. + return $self->{name}; +} + +############################################################################## + +=head3 version + + my $version = $pg->version; + +Returns the PostgreSQL version number. App::Info::RDBMS::PostgreSQL parses the +version number from the system call C<`pg_config --version`>. + +B<Events:> + +=over 4 + +=item info + +Executing `pg_config --version` + +=item error + +Failed to find PostgreSQL version with `pg_config --version` + +Unable to parse name from string + +Unable to parse version from string + +Failed to parse PostgreSQL version parts from string + +=item unknown + +Enter a valid PostgreSQL version number + +=back + +=cut + +sub version { + my $self = shift; + return unless $self->{pg_config}; + + # Load data. + $get_version->($self) unless $self->{'--version'}; + + # Handle an unknown value. + unless ($self->{version}) { + # Create a validation code reference. + my $chk_version = sub { + # Try to get the version number parts. + my ($x, $y, $z) = /^(\d+)\.(\d+).(\d+)$/; + # Return false if we didn't get all three. + return unless $x and defined $y and defined $z; + # Save all three parts. + @{$self}{qw(major minor patch)} = ($x, $y, $z); + # Return true. + return 1; + }; + $self->{version} = $self->unknown( key => 'version number', + callback => $chk_version); + } + + return $self->{version}; +} + +############################################################################## + +=head3 major version + + my $major_version = $pg->major_version; + +Returns the PostgreSQL major version number. App::Info::RDBMS::PostgreSQL +parses the major version number from the system call C<`pg_config --version`>. +For example, C<version()> returns "7.1.2", then this method returns "7". + +B<Events:> + +=over 4 + +=item info + +Executing `pg_config --version` + +=item error + +Failed to find PostgreSQL version with `pg_config --version` + +Unable to parse name from string + +Unable to parse version from string + +Failed to parse PostgreSQL version parts from string + +=item unknown + +Enter a valid PostgreSQL major version number + +=back + +=cut + +# This code reference is used by major_version(), minor_version(), and +# patch_version() to validate a version number entered by a user. +my $is_int = sub { /^\d+$/ }; + +sub major_version { + my $self = shift; + return unless $self->{pg_config}; + # Load data. + $get_version->($self) unless exists $self->{'--version'}; + # Handle an unknown value. + $self->{major} = $self->unknown( key => 'major version number', + callback => $is_int) + unless $self->{major}; + return $self->{major}; +} + +############################################################################## + +=head3 minor version + + my $minor_version = $pg->minor_version; + +Returns the PostgreSQL minor version number. App::Info::RDBMS::PostgreSQL +parses the minor version number from the system call C<`pg_config --version`>. +For example, if C<version()> returns "7.1.2", then this method returns "2". + +B<Events:> + +=over 4 + +=item info + +Executing `pg_config --version` + +=item error + +Failed to find PostgreSQL version with `pg_config --version` + +Unable to parse name from string + +Unable to parse version from string + +Failed to parse PostgreSQL version parts from string + +=item unknown + +Enter a valid PostgreSQL minor version number + +=back + +=cut + +sub minor_version { + my $self = shift; + return unless $self->{pg_config}; + # Load data. + $get_version->($self) unless exists $self->{'--version'}; + # Handle an unknown value. + $self->{minor} = $self->unknown( key => 'minor version number', + callback => $is_int) + unless defined $self->{minor}; + return $self->{minor}; +} + +############################################################################## + +=head3 patch version + + my $patch_version = $pg->patch_version; + +Returns the PostgreSQL patch version number. App::Info::RDBMS::PostgreSQL +parses the patch version number from the system call C<`pg_config --version`>. +For example, if C<version()> returns "7.1.2", then this method returns "1". + +B<Events:> + +=over 4 + +=item info + +Executing `pg_config --version` + +=item error + +Failed to find PostgreSQL version with `pg_config --version` + +Unable to parse name from string + +Unable to parse version from string + +Failed to parse PostgreSQL version parts from string + +=item unknown + +Enter a valid PostgreSQL minor version number + +=back + +=cut + +sub patch_version { + my $self = shift; + return unless $self->{pg_config}; + # Load data. + $get_version->($self) unless exists $self->{'--version'}; + # Handle an unknown value. + $self->{patch} = $self->unknown( key => 'patch version number', + callback => $is_int) + unless defined $self->{patch}; + return $self->{patch}; +} + +############################################################################## + +=head3 bin_dir + + my $bin_dir = $pg->bin_dir; + +Returns the PostgreSQL binary directory path. App::Info::RDBMS::PostgreSQL +gathers the path from the system call C<`pg_config --bindir`>. + +B<Events:> + +=over 4 + +=item info + +Executing `pg_config --bindir` + +=item error + +Cannot find bin directory + +=item unknown + +Enter a valid PostgreSQL bin directory + +=back + +=cut + +# This code reference is used by bin_dir(), lib_dir(), and so_lib_dir() to +# validate a directory entered by the user. +my $is_dir = sub { -d }; + +sub bin_dir { + my $self = shift; + return unless $self->{pg_config}; + unless (exists $self->{bin_dir} ) { + if (my $dir = $get_data->($self, '--bindir')) { + $self->{bin_dir} = $dir; + } else { + # Handle an unknown value. + $self->error("Cannot find bin directory"); + $self->{bin_dir} = $self->unknown( key => 'bin directory', + callback => $is_dir) + } + } + + return $self->{bin_dir}; +} + +############################################################################## + +=head3 inc_dir + + my $inc_dir = $pg->inc_dir; + +Returns the PostgreSQL include directory path. App::Info::RDBMS::PostgreSQL +gathers the path from the system call C<`pg_config --includedir`>. + +B<Events:> + +=over 4 + +=item info + +Executing `pg_config --includedir` + +=item error + +Cannot find include directory + +=item unknown + +Enter a valid PostgreSQL include directory + +=back + +=cut + +sub inc_dir { + my $self = shift; + return unless $self->{pg_config}; + unless (exists $self->{inc_dir} ) { + if (my $dir = $get_data->($self, '--includedir')) { + $self->{inc_dir} = $dir; + } else { + # Handle an unknown value. + $self->error("Cannot find include directory"); + $self->{inc_dir} = $self->unknown( key => 'include directory', + callback => $is_dir) + } + } + + return $self->{inc_dir}; +} + +############################################################################## + +=head3 lib_dir + + my $lib_dir = $pg->lib_dir; + +Returns the PostgreSQL library directory path. App::Info::RDBMS::PostgreSQL +gathers the path from the system call C<`pg_config --libdir`>. + +B<Events:> + +=over 4 + +=item info + +Executing `pg_config --libdir` + +=item error + +Cannot find library directory + +=item unknown + +Enter a valid PostgreSQL library directory + +=back + +=cut + +sub lib_dir { + my $self = shift; + return unless $self->{pg_config}; + unless (exists $self->{lib_dir} ) { + if (my $dir = $get_data->($self, '--libdir')) { + $self->{lib_dir} = $dir; + } else { + # Handle an unknown value. + $self->error("Cannot find library directory"); + $self->{lib_dir} = $self->unknown( key => 'library directory', + callback => $is_dir) + } + } + + return $self->{lib_dir}; +} + +############################################################################## + +=head3 so_lib_dir + + my $so_lib_dir = $pg->so_lib_dir; + +Returns the PostgreSQL shared object library directory path. +App::Info::RDBMS::PostgreSQL gathers the path from the system call +C<`pg_config --pkglibdir`>. + +B<Events:> + +=over 4 + +=item info + +Executing `pg_config --pkglibdir` + +=item error + +Cannot find shared object library directory + +=item unknown + +Enter a valid PostgreSQL shared object library directory + +=back + +=cut + +# Location of dynamically loadable modules. +sub so_lib_dir { + my $self = shift; + return unless $self->{pg_config}; + unless (exists $self->{so_lib_dir} ) { + if (my $dir = $get_data->($self, '--pkglibdir')) { + $self->{so_lib_dir} = $dir; + } else { + # Handle an unknown value. + $self->error("Cannot find shared object library directory"); + $self->{so_lib_dir} = + $self->unknown( key => 'shared object library directory', + callback => $is_dir) + } + } + + return $self->{so_lib_dir}; +} + +############################################################################## + +=head3 home_url + + my $home_url = $pg->home_url; + +Returns the PostgreSQL home page URL. + +=cut + +sub home_url { "http://www.postgresql.org/" } + +############################################################################## + +=head3 download_url + + my $download_url = $pg->download_url; + +Returns the PostgreSQL download URL. + +=cut + +sub download_url { "http://www.ca.postgresql.org/sitess.html" } + +1; +__END__ + +=head1 BUGS + +Report all bugs via the CPAN Request Tracker at +L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=App-Info>. + +=head1 AUTHOR + +David Wheeler <L<david@wheeler.net|"david@wheeler.net">> based on code by Sam +Tregar <L<sam@tregar.com|"sam@tregar.com">>. + +=head1 SEE ALSO + +L<App::Info|App::Info> documents the event handling interface. + +L<App::Info::RDBMS|App::Info::RDBMS> is the App::Info::RDBMS::PostgreSQL +parent class. + +L<DBD::Pg|DBD::Pg> is the L<DBI|DBI> driver for connecting to PostgreSQL +databases. + +L<http://www.postgresql.org/> is the PostgreSQL home page. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2002, David Wheeler. All Rights Reserved. + +This module is free software; you can redistribute it and/or modify it under the +same terms as Perl itself. + +=cut diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/Request.pm b/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/Request.pm new file mode 100644 index 0000000..c02c97b --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/Request.pm @@ -0,0 +1,287 @@ +package App::Info::Request; + +# $Id: Request.pm,v 1.1 2004-04-29 09:21:28 ivan Exp $ + +=head1 NAME + +App::Info::Request - App::Info event handler request object + +=head1 SYNOPSIS + + # In an App::Info::Handler subclass: + sub handler { + my ($self, $req) = @_; + print "Event Type: ", $req->type; + print "Message: ", $req->message; + print "Error: ", $req->error; + print "Value: ", $req->value; + } + +=head1 DESCRIPTION + +Objects of this class are passed to the C<handler()> method of App::Info event +handlers. Generally, this class will be of most interest to App::Info::Handler +subclass implementers. + +The L<event triggering methods|App::Info/"Events"> in App::Info each construct +a new App::Info::Request object and initialize it with their arguments. The +App::Info::Request object is then the sole argument passed to the C<handler()> +method of any and all App::Info::Handler objects in the event handling chain. +Thus, if you'd like to create your own App::Info event handler, this is the +object you need to be familiar with. Consult the +L<App::Info::Handler|App::Info::Handler> documentation for details on creating +custom event handlers. + +Each of the App::Info event triggering methods constructs an +App::Info::Request object with different attribute values. Be sure to consult +the documentation for the L<event triggering methods|App::Info/"Events"> in +App::Info, where the values assigned to the App::Info::Request object are +documented. Then, in your event handler subclass, check the value returned by +the C<type()> method to determine what type of event request you're handling +to handle the request appropriately. + +=cut + +use strict; +use vars qw($VERSION); +$VERSION = '0.23'; + +############################################################################## + +=head1 INTERFACE + +The following sections document the App::Info::Request interface. + +=head2 Constructor + +=head3 new + + my $req = App::Info::Request->new(%params); + +This method is used internally by App::Info to construct new +App::Info::Request objects to pass to event handler objects. Generally, you +won't need to use it, other than perhaps for testing custom App::Info::Handler +classes. + +The parameters to C<new()> are passed as a hash of named parameters that +correspond to their like-named methods. The supported parameters are: + +=over 4 + +=item type + +=item message + +=item error + +=item value + +=item callback + +=back + +See the object methods documentation below for details on these object +attributes. + +=cut + +sub new { + my $pkg = shift; + + # Make sure we've got a hash of arguments. + Carp::croak("Odd number of parameters in call to " . __PACKAGE__ . + "->new() when named parameters expected" ) if @_ % 2; + my %params = @_; + + # Validate the callback. + if ($params{callback}) { + Carp::croak("Callback parameter '$params{callback}' is not a code ", + "reference") + unless UNIVERSAL::isa($params{callback}, 'CODE'); + } else { + # Otherwise just assign a default approve callback. + $params{callback} = sub { 1 }; + } + + # Validate type parameter. + if (my $t = $params{type}) { + Carp::croak("Invalid handler type '$t'") + unless $t eq 'error' or $t eq 'info' or $t eq 'unknown' + or $t eq 'confirm'; + } else { + $params{type} = 'info'; + } + + # Return the request object. + bless \%params, ref $pkg || $pkg; +} + +############################################################################## + +=head2 Object Methods + +=head3 message + + my $message = $req->message; + +Returns the message stored in the App::Info::Request object. The message is +typically informational, or an error message, or a prompt message. + +=cut + +sub message { $_[0]->{message} } + +############################################################################## + +=head3 error + + my $error = $req->error; + +Returns any error message associated with the App::Info::Request object. The +error message is typically there to display for users when C<callback()> +returns false. + +=cut + +sub error { $_[0]->{error} } + +############################################################################## + +=head3 type + + my $type = $req->type; + +Returns a string representing the type of event that triggered this request. +The types are the same as the event triggering methods defined in App::Info. +As of this writing, the supported types are: + +=over + +=item info + +=item error + +=item unknown + +=item confirm + +=back + +Be sure to consult the App::Info documentation for more details on the event +types. + +=cut + +sub type { $_[0]->{type} } + +############################################################################## + +=head3 callback + + if ($req->callback($value)) { + print "Value '$value' is valid.\n"; + } else { + print "Value '$value' is not valid.\n"; + } + +Executes the callback anonymous subroutine supplied by the App::Info concrete +base class that triggered the event. If the callback returns false, then +C<$value> is invalid. If the callback returns true, then C<$value> is valid +and can be assigned via the C<value()> method. + +Note that the C<value()> method itself calls C<callback()> if it was passed a +value to assign. See its documentation below for more information. + +=cut + +sub callback { + my $self = shift; + my $code = $self->{callback}; + local $_ = $_[0]; + $code->(@_); +} + +############################################################################## + +=head3 value + + my $value = $req->value; + if ($req->value($value)) { + print "Value '$value' successfully assigned.\n"; + } else { + print "Value '$value' not successfully assigned.\n"; + } + +When called without an argument, C<value()> simply returns the value currently +stored by the App::Info::Request object. Typically, the value is the default +value for a confirm event, or a value assigned to an unknown event. + +When passed an argument, C<value()> attempts to store the the argument as a +new value. However, C<value()> calls C<callback()> on the new value, and if +C<callback()> returns false, then C<value()> returns false and does not store +the new value. If C<callback()> returns true, on the other hand, then +C<value()> goes ahead and stores the new value and returns true. + +=cut + +sub value { + my $self = shift; + if ($#_ >= 0) { + # grab the value. + my $value = shift; + # Validate the value. + if ($self->callback($value)) { + # The value is good. Assign it and return true. + $self->{value} = $value; + return 1; + } else { + # Invalid value. Return false. + return; + } + } + # Just return the value. + return $self->{value}; +} + +1; +__END__ + +=head1 BUGS + +Report all bugs via the CPAN Request Tracker at +L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=App-Info>. + +=head1 AUTHOR + +David Wheeler <L<david@wheeler.net|"david@wheeler.net">> + +=head1 SEE ALSO + +L<App::Info|App::Info> documents the event triggering methods and how they +construct App::Info::Request objects to pass to event handlers. + +L<App::Info::Handler:|App::Info::Handler> documents how to create custom event +handlers, which must make use of the App::Info::Request object passed to their +C<handler()> object methods. + +The following classes subclass App::Info::Handler, and thus offer good +exemplars for using App::Info::Request objects when handling events. + +=over 4 + +=item L<App::Info::Handler::Carp|App::Info::Handler::Carp> + +=item L<App::Info::Handler::Print|App::Info::Handler::Print> + +=item L<App::Info::Handler::Prompt|App::Info::Handler::Prompt> + +=back + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2002, David Wheeler. All Rights Reserved. + +This module is free software; you can redistribute it and/or modify it under the +same terms as Perl itself. + +=cut diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/Util.pm b/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/Util.pm new file mode 100644 index 0000000..55bb333 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/t/lib/App/Info/Util.pm @@ -0,0 +1,456 @@ +package App::Info::Util; + +# $Id: Util.pm,v 1.1 2004-04-29 09:21:28 ivan Exp $ + +=head1 NAME + +App::Info::Util - Utility class for App::Info subclasses + +=head1 SYNOPSIS + + use App::Info::Util; + + my $util = App::Info::Util->new; + + # Subclasses File::Spec. + my @paths = $util->paths; + + # First directory that exists in a list. + my $dir = $util->first_dir(@paths); + + # First directory that exists in a path. + $dir = $util->first_path($ENV{PATH}); + + # First file that exists in a list. + my $file = $util->first_file('this.txt', '/that.txt', 'C:\\foo.txt'); + + # First file found among file base names and directories. + my $files = ['this.txt', 'that.txt']; + $file = $util->first_cat_file($files, @paths); + +=head1 DESCRIPTION + +This class subclasses L<File::Spec|File::Spec> and adds its own methods in +order to offer utility methods to L<App::Info|App::Info> classes. Although +intended to be used by App::Info subclasses, in truth App::Info::Util's +utility may be considered more general, so feel free to use it elsewhere. + +The methods added in addition to the usual File::Spec suspects are designed to +facilitate locating files and directories on the file system, as well as +searching those files. The assumption is that, in order to provide useful +metadata about a given software package, an App::Info subclass must find +relevant files and directories and parse them with regular expressions. This +class offers methods that simplify those tasks. + +=cut + +use strict; +use File::Spec (); +use vars qw(@ISA $VERSION); +@ISA = qw(File::Spec); +$VERSION = '0.22'; + +my %path_dems = (MacOS => qr',', + MSWin32 => qr';', + os2 => qr';', + VMS => undef, + epoc => undef); + +my $path_dem = exists $path_dems{$^O} ? $path_dems{$^O} : qr':'; + +=head1 CONSTRUCTOR + +=head2 new + + my $util = App::Info::Util->new; + +This is a very simple constructor that merely returns an App::Info::Util +object. Since, like its File::Spec super class, App::Info::Util manages no +internal data itself, all methods may be used as class methods, if one prefers +to. The constructor here is provided merely as a convenience. + +=cut + +sub new { bless {}, ref $_[0] || $_[0] } + +=head1 OBJECT METHODS + +In addition to all of the methods offered by its super class, +L<File::Spec|File::Spec>, App::Info::Util offers the following methods. + +=head2 first_dir + + my @paths = $util->paths; + my $dir = $util->first_dir(@dirs); + +Returns the first file system directory in @paths that exists on the local +file system. Only the first item in @paths that exists as a directory will be +returned; any other paths leading to non-directories will be ignored. + +=cut + +sub first_dir { + shift; + foreach (@_) { return $_ if -d } + return; +} + +=head2 first_path + + my $path = $ENV{PATH}; + $dir = $util->first_path($path); + +Takes the $path string and splits it into a list of directory paths, based on +the path demarcator on the local file system. Then calls C<first_dir()> to +return the first directoy in the path list that exists on the local file +system. The path demarcator is specified for the following file systems: + +=over 4 + +=item MacOS: "," + +=item MSWin32: ";" + +=item os2: ";" + +=item VMS: undef + +This method always returns undef on VMS. Patches welcome. + +=item epoc: undef + +This method always returns undef on epoch. Patches welcome. + +=item Unix: ":" + +All other operating systems are assumed to be Unix-based. + +=back + +=cut + +sub first_path { + return unless $path_dem; + shift->first_dir(split /$path_dem/, shift) +} + +=head2 first_file + + my $file = $util->first_file(@filelist); + +Examines each of the files in @filelist and returns the first one that exists +on the file system. The file must be a regular file -- directories will be +ignored. + +=cut + +sub first_file { + shift; + foreach (@_) { return $_ if -f } + return; +} + +=head2 first_exe + + my $exe = $util->first_exe(@exelist); + +Examines each of the files in @exelist and returns the first one that exists +on the file system as an executable file. Directories will be ignored. + +=cut + +sub first_exe { + shift; + foreach (@_) { return $_ if -f && -x } + return; +} + +=head2 first_cat_path + + my $file = $util->first_cat_path('ick.txt', @paths); + $file = $util->first_cat_path(['this.txt', 'that.txt'], @paths); + +The first argument to this method may be either a file or directory base name +(that is, a file or directory name without a full path specification), or a +reference to an array of file or directory base names. The remaining arguments +constitute a list of directory paths. C<first_cat_path()> processes each of +these directory paths, concatenates (by the method native to the local +operating system) each of the file or directory base names, and returns the +first one that exists on the file system. + +For example, let us say that we were looking for a file called either F<httpd> +or F<apache>, and it could be in any of the following paths: +F</usr/local/bin>, F</usr/bin/>, F</bin>. The method call looks like this: + + my $httpd = $util->first_cat_path(['httpd', 'apache'], '/usr/local/bin', + '/usr/bin/', '/bin'); + +If the OS is a Unix variant, C<first_cat_path()> will then look for the first +file that exists in this order: + +=over 4 + +=item /usr/local/bin/httpd + +=item /usr/local/bin/apache + +=item /usr/bin/httpd + +=item /usr/bin/apache + +=item /bin/httpd + +=item /bin/apache + +=back + +The first of these complete paths to be found will be returned. If none are +found, then undef will be returned. + +=cut + +sub first_cat_path { + my $self = shift; + my $files = ref $_[0] ? shift() : [shift()]; + foreach my $p (@_) { + foreach my $f (@$files) { + my $path = $self->catfile($p, $f); + return $path if -e $path; + } + } + return; +} + +=head2 first_cat_dir + + my $dir = $util->first_cat_dir('ick.txt', @paths); + $dir = $util->first_cat_dir(['this.txt', 'that.txt'], @paths); + +Funtionally identical to C<first_cat_path()>, except that it returns the +directory path in which the first file was found, rather than the full +concatenated path. Thus, in the above example, if the file found was +F</usr/bin/httpd>, while C<first_cat_path()> would return that value, +C<first_cat_dir()> would return F</usr/bin> instead. + +=cut + +sub first_cat_dir { + my $self = shift; + my $files = ref $_[0] ? shift() : [shift()]; + foreach my $p (@_) { + foreach my $f (@$files) { + my $path = $self->catfile($p, $f); + return $p if -e $path; + } + } + return; +} + +=head2 first_cat_exe + + my $exe = $util->first_cat_exe('ick.txt', @paths); + $exe = $util->first_cat_exe(['this.txt', 'that.txt'], @paths); + +Funtionally identical to C<first_cat_path()>, except that it returns the full +path to the first executable file found, rather than simply the first file +found. + +=cut + +sub first_cat_exe { + my $self = shift; + my $files = ref $_[0] ? shift() : [shift()]; + foreach my $p (@_) { + foreach my $f (@$files) { + my $path = $self->catfile($p, $f); + return $path if -f $path && -x $path; + } + } + return; +} + +=head2 search_file + + my $file = 'foo.txt'; + my $regex = qr/(text\s+to\s+find)/; + my $value = $util->search_file($file, $regex); + +Opens C<$file> and executes the C<$regex> regular expression against each line +in the file. Once the line matches and one or more values is returned by the +match, the file is closed and the value or values returned. + +For example, say F<foo.txt> contains the line "Version 6.5, patch level 8", +and you need to grab each of the three version parts. All three parts can +be grabbed like this: + + my $regex = qr/Version\s+(\d+)\.(\d+),[^\d]*(\d+)/; + my @nums = $util->search_file($file, $regex); + +Now C<@nums> will contain the values C<(6, 5, 8)>. Note that in a scalar +context, the above search would yeild an array reference: + + my $regex = qr/Version\s+(\d+)\.(\d+),[^\d]*(\d+)/; + my $nums = $util->search_file($file, $regex); + +So now C<$nums> contains C<[6, 5, 8]>. The same does not hold true if the +match returns only one value, however. Say F<foo.txt> contains the line +"king of the who?", and you wish to know who the king is king of. Either +of the following two calls would get you the data you need: + + my $minions = $util->search_file($file, qr/King\s+of\s+(.*)/); + my @minions = $util->search_file($file, qr/King\s+of\s+(.*)/); + +In the first case, because the regular expression contains only one set of +parentheses, C<search_file()> will simply return that value: C<$minions> +contains the string "the who?". In the latter case, C<@minions> of course +contains a single element: C<("the who?")>. + +Note that a regular expression without parentheses -- that is, one that +doesn't grab values and put them into $1, $2, etc., will never successfully +match a line in this method. You must include something to parentetically +match. If you just want to know the value of what was matched, parenthesize +the whole thing and if the value returns, you have a match. Also, if you need +to match patterns across lines, try using multiple regular expressions with +C<multi_search_file()>, instead. + +=cut + +sub search_file { + my ($self, $file, $regex) = @_; + return unless $file && $regex; + open F, "<$file" or Carp::croak "Cannot open $file: $!\n"; + my @ret; + while (<F>) { + # If we find a match, we're done. + (@ret) = /$regex/ and last; + } + close F; + # If the match returned an more than one value, always return the full + # array. Otherwise, return just the first value in a scalar context. + return unless @ret; + return wantarray ? @ret : $#ret <= 0 ? $ret[0] : \@ret; +} + +=head2 multi_search_file + + my @regexen = (qr/(one)/, qr/(two)\s+(three)/); + my @matches = $util->multi_search_file($file, @regexen); + +Like C<search_file()>, this mehod opens C<$file> and parses it for regular +expresion matches. This method, however, can take a list of regular +expressions to look for, and will return the values found for all of them. +Regular expressions that match and return multiple values will be returned as +array referernces, while those that match and return a single value will +return just that single value. + +For example, say you are parsing a file with lines like the following: + + #define XML_MAJOR_VERSION 1 + #define XML_MINOR_VERSION 95 + #define XML_MICRO_VERSION 2 + +You need to get each of these numbers, but calling C<search_file()> for each +of them would be wasteful, as each call to C<search_file()> opens the file and +parses it. With C<multi_search_file()>, on the other hand, the file will be +opened only once, and, once all of the regular expressions have returned +matches, the file will be closed and the matches returned. + +Thus the above values can be collected like this: + + my @regexen = ( qr/XML_MAJOR_VERSION\s+(\d+)$/, + qr/XML_MINOR_VERSION\s+(\d+)$/, + qr/XML_MICRO_VERSION\s+(\d+)$/ ); + + my @nums = $file->multi_search_file($file, @regexen); + +The result will be that C<@nums> contains C<(1, 95, 2)>. Note that +C<multi_file_search()> tries to do the right thing by only parsing the file +until all of the regular expressions have been matched. Thus, a large file +with the values you need near the top can be parsed very quickly. + +As with C<search_file()>, C<multi_search_file()> can take regular expressions +that match multiple values. These will be returned as array references. For +example, say the file you're parsing has files like this: + + FooApp Version 4 + Subversion 2, Microversion 6 + +To get all of the version numbers, you can either use three regular +expressions, as in the previous example: + + my @regexen = ( qr/FooApp\s+Version\s+(\d+)$/, + qr/Subversion\s+(\d+),/, + qr/Microversion\s+(\d$)$/ ); + + my @nums = $file->multi_search_file($file, @regexen); + +In which case C<@nums> will contain C<(4, 2, 6)>. Or, you can use just two +regular expressions: + + my @regexen = ( qr/FooApp\s+Version\s+(\d+)$/, + qr/Subversion\s+(\d+),\s+Microversion\s+(\d$)$/ ); + + my @nums = $file->multi_search_file($file, @regexen); + +In which case C<@nums> will contain C<(4, [2, 6])>. Note that the two +parentheses that return values in the second regular expression cause the +matches to be returned as an array reference. + +=cut + +sub multi_search_file { + my ($self, $file, @regexen) = @_; + return unless $file && @regexen; + my @each = @regexen; + open F, "<$file" or Carp::croak "Cannot open $file: $!\n"; + my %ret; + while (my $line = <F>) { + my @splice; + # Process each of the regular expresssions. + for (my $i = 0; $i < @each; $i++) { + if ((my @ret) = $line =~ /$each[$i]/) { + # We have a match! If there's one match returned, just grab + # it. If there's more than one, keep it as an array ref. + $ret{$each[$i]} = $#ret > 0 ? \@ret : $ret[0]; + # We got values for this regex, so not its place in the @each + # array. + push @splice, $i; + } + } + # Remove any regexen that have already found a match. + for (@splice) { splice @each, $_, 1 } + # If there are no more regexes, we're done -- no need to keep + # processing lines in the file! + last unless @each; + } + close F; + return unless %ret; + return wantarray ? @ret{@regexen} : \@ret{@regexen}; +} + +1; +__END__ + +=head1 BUGS + +Report all bugs via the CPAN Request Tracker at +L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=App-Info>. + +=head1 AUTHOR + +David Wheeler <L<david@wheeler.net|"david@wheeler.net">> + +=head1 SEE ALSO + +L<App::Info|App::Info>, L<File::Spec|File::Spec>, +L<App::Info::HTTPD::Apache|App::Info::HTTPD::Apache> +L<App::Info::RDBMS::PostgreSQL|App::Info::RDBMS::PostgreSQL> + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2002, David Wheeler. All Rights Reserved. + +This module is free software; you can redistribute it and/or modify it under the +same terms as Perl itself. + +=cut |