statistics_info patch

Index: Pg.pm
===================================================================
RCS file: /usr/local/cvsroot/dbdpg/dbdpg/Pg.pm,v
retrieving revision 1.203
diff -u -r1.203 Pg.pm
--- Pg.pm	9 May 2006 21:27:49 -0000	1.203
+++ Pg.pm	28 Jun 2006 04:00:55 -0000
@@ -495,6 +495,151 @@
 		return $sth;
 	}
 
+	sub statistics_info {
+		my $dbh = shift;
+		my ($catalog, $schema, $table, $unique_only, $quick, $attr) = @_;
+
+		## Catalog is ignored, but table is mandatory
+		return undef unless defined $table and length $table;
+
+		my $version = $dbh->{private_dbdpg}{version};
+
+		# These defaults are for schema-less pre-7.3 versions...
+		my $schema_out = 'NULL::text AS nspname';
+		my $schema_from = '';
+		my $schema_where = '';
+		my @exe_args = ($table);
+
+		my $gotschema = $version >= 70300 ? 1 : 0;
+		my $input_schema = (defined $schema and length $schema) ? 1 : 0;
+
+		if($gotschema) {
+			$schema_out = 'n.nspname';
+			$schema_from = ", ${DBD::Pg::dr::CATALOG}pg_namespace n";
+			if($input_schema) {
+				$schema_where = 'AND n.nspname = ? AND n.oid = d.relnamespace';
+				push(@exe_args, $schema);
+			}
+			else {
+				$schema_where = 'AND n.oid = d.relnamespace';
+			}
+		}
+
+		my $table_stats_sql = qq{
+			SELECT d.relpages, d.reltuples, $schema_out
+			FROM   pg_class d $schema_from
+			WHERE  d.relname = ? $schema_where
+		};
+
+		my $colnames_sql = qq{
+			SELECT
+				a.attnum, a.attname
+			FROM
+				${DBD::Pg::dr::CATALOG}pg_attribute a, ${DBD::Pg::dr::CATALOG}pg_class d
+				$schema_from
+			WHERE
+				a.attrelid = d.oid AND d.relname = ? $schema_where
+		};
+
+		my $stats_sql = qq{
+			SELECT
+				c.relname, i.indkey, i.indisunique, i.indisclustered, a.amname,
+				$schema_out, c.relpages, c.reltuples, i.indexprs,
+				pg_get_expr(i.indpred,i.indrelid) as predicate
+			FROM
+				${DBD::Pg::dr::CATALOG}pg_index i, ${DBD::Pg::dr::CATALOG}pg_class c,
+				${DBD::Pg::dr::CATALOG}pg_class d, ${DBD::Pg::dr::CATALOG}pg_am a
+				$schema_from
+			WHERE
+				d.relname = ? $schema_where AND d.oid = i.indrelid
+				AND i.indexrelid = c.oid AND c.relam = a.oid
+			ORDER BY
+				i.indisunique desc, a.amname, c.relname
+		};
+
+		my @output_rows;
+
+		# Table-level stats
+		if(!$unique_only) {
+			my $table_stats_sth = $dbh->prepare($table_stats_sql);
+			$table_stats_sth->execute(@exe_args) or return undef;
+			my $tst = $table_stats_sth->fetchrow_hashref or return undef;
+			push(@output_rows, [
+				undef,			# TABLE_CAT
+				$tst->{nspname},	# TABLE_SCHEM
+				$table,			# TABLE_NAME
+				undef,			# NON_UNIQUE
+				undef,			# INDEX_QUALIFIER
+				undef,			# INDEX_NAME
+				'table',		# TYPE
+				undef,			# ORDINAL_POSITION
+				undef,			# COLUMN_NAME
+				undef,			# ASC_OR_DESC
+				$tst->{reltuples},	# CARDINALITY
+				$tst->{relpages},	# PAGES
+				undef,			# FILTER_CONDITION
+			]);
+		}
+
+		# Fetch the column names for later use
+		my $colnames_sth = $dbh->prepare($colnames_sql);
+		$colnames_sth->execute(@exe_args) or return undef;
+		my $colnames = $colnames_sth->fetchall_hashref('attnum');
+
+		# Fetch the index definitions
+		my $sth = $dbh->prepare($stats_sql);
+		$sth->execute(@exe_args) or return undef;
+
+		STAT_ROW:
+		while(my $row = $sth->fetchrow_hashref) {
+			next if $row->{indexprs}; # We can't return these accurately via this interface ...
+			next if $unique_only && !$row->{indisunique};
+
+			my $indtype = $row->{indisclustered}
+				? 'clustered'
+				: ( $row->{amname} eq 'btree' )
+					? 'btree'
+					: ($row->{amname} eq 'hash' )
+						? 'hashed' : 'other';
+
+			my $nonunique = $row->{indisunique} ? 0 : 1;
+
+			my @index_row = (
+				undef,			# TABLE_CAT
+				$row->{nspname},	# TABLE_SCHEM
+				$table,			# TABLE_NAME
+				$nonunique,		# NON_UNIQUE
+				undef,			# INDEX_QUALIFIER
+				$row->{relname},	# INDEX_NAME
+				$indtype,		# TYPE
+				undef,			# ORDINAL_POSITION
+				undef,			# COLUMN_NAME
+				'A',			# ASC_OR_DESC
+				$row->{reltuples},	# CARDINALITY
+				$row->{relpages},	# PAGES
+				$row->{predicate},	# FILTER_CONDITION
+			);
+
+			my $col_nums = $row->{indkey};
+			$col_nums =~ s/^\s+//;
+			my @col_nums = split(/\s+/, $col_nums);
+
+			my $ord_pos = 1;
+			foreach my $col_num (@col_nums) {
+				my @copy = @index_row;
+				$copy[7] = $ord_pos++;				# ORDINAL_POSITION
+				$copy[8] = $colnames->{$col_num}->{attname};	# COLUMN_NAME
+				push(@output_rows, \@copy);
+			}
+		}
+
+		my @output_colnames = qw/ TABLE_CAT TABLE_SCHEM TABLE_NAME NON_UNIQUE INDEX_QUALIFIER
+					INDEX_NAME TYPE ORDINAL_POSITION COLUMN_NAME ASC_OR_DESC
+					CARDINALITY PAGES FILTER_CONDITION /;
+
+		return _prepare_from_data('statistics_info', \@output_rows, \@output_colnames);
+	}
+
 	sub primary_key_info {
 
 		my $dbh = shift;
Index: t/03dbmethod.t
===================================================================
RCS file: /usr/local/cvsroot/dbdpg/dbdpg/t/03dbmethod.t,v
retrieving revision 1.43
diff -u -r1.43 03dbmethod.t
--- t/03dbmethod.t	9 Apr 2006 20:06:20 -0000	1.43
+++ t/03dbmethod.t	28 Jun 2006 04:00:56 -0000
@@ -18,7 +18,7 @@
 $|=1;
 
 if (defined $ENV{DBI_DSN}) {
-	plan tests => 186;
+	plan tests => 196;
 }
 else {
 	plan skip_all => 'Cannot run test unless DBI_DSN is defined. See the README file';
@@ -430,6 +430,131 @@
 is_deeply( \@result, $expected, 'DB handle method "primary_key" returns empty list for invalid table');
 
 #
+# Test of the "statistics_info" database handle method
+#
+
+$sth = $dbh->statistics_info(undef,undef,undef,undef,undef);
+is ($sth, undef, 'DB handle method "statistics_info" returns undef: no table');
+
+# Drop any tables that may exist
+my $fktables = join "," => map { "'dbd_pg_test$_'" } (1..3);
+$SQL = "SELECT relname FROM pg_catalog.pg_class WHERE relkind='r' AND relname IN ($fktables)";
+{
+	local $SIG{__WARN__} = sub {};
+	for (@{$dbh->selectall_arrayref($SQL)}) {
+		$dbh->do("DROP TABLE $_->[0] CASCADE");
+	}
+}
+
+## Invalid table
+$sth = $dbh->statistics_info(undef,undef,'dbd_pg_test9',undef,undef);
+is ($sth, undef, 'DB handle method "statistics_info" returns undef: bad table');
+
+## Create some tables with various indexes
+{
+	local $SIG{__WARN__} = sub {};
+	$dbh->do("CREATE TABLE dbd_pg_test1 (a INT, b INT NOT NULL, c INT NOT NULL, ".
+					 "CONSTRAINT dbd_pg_test1_pk PRIMARY KEY (a))");
+	$dbh->do("ALTER TABLE dbd_pg_test1 ADD CONSTRAINT dbd_pg_test1_uc1 UNIQUE (b)");
+	$dbh->do("CREATE UNIQUE INDEX dbd_pg_test1_index_c ON dbd_pg_test1(c)");
+	$dbh->do("CREATE TABLE dbd_pg_test2 (a INT, b INT, c INT, PRIMARY KEY(a,b), UNIQUE(b,c))");
+	$dbh->do("CREATE INDEX dbd_pg_test2_skipme ON dbd_pg_test2(c,(a+b))");
+	$dbh->do("CREATE TABLE dbd_pg_test3 (a INT, b INT, c INT, PRIMARY KEY(a)) WITH OIDS");
+	$dbh->do("CREATE UNIQUE INDEX dbd_pg_test3_index_b ON dbd_pg_test3(b)");
+	$dbh->do("CREATE INDEX dbd_pg_test3_index_c ON dbd_pg_test3 USING hash(c)");
+	$dbh->do("CREATE INDEX dbd_pg_test3_oid ON dbd_pg_test3(oid)");
+	$dbh->do("CREATE UNIQUE INDEX dbd_pg_test3_pred ON dbd_pg_test3(c) WHERE c > 0 AND c < 45");
+	$dbh->commit();
+}
+
+my $correct_stats = {
+one => [
+	[ undef, 'public', 'dbd_pg_test1', undef, undef, undef, 'table', undef, undef, undef, '0', '0', undef ],
+	[ undef, 'public', 'dbd_pg_test1', '0', undef, 'dbd_pg_test1_index_c', 'btree',  1, 'c', 'A', '0', '1', undef ],
+	[ undef, 'public', 'dbd_pg_test1', '0', undef, 'dbd_pg_test1_pk',      'btree',  1, 'a', 'A', '0', '1', undef ],
+	[ undef, 'public', 'dbd_pg_test1', '0', undef, 'dbd_pg_test1_uc1',     'btree',  1, 'b', 'A', '0', '1', undef ],
+],
+two => [
+	[ undef, 'public', 'dbd_pg_test2', undef, undef, undef, 'table', undef, undef, undef, '0', '0', undef ],
+	[ undef, 'public', 'dbd_pg_test2', '0', undef, 'dbd_pg_test2_b_key',   'btree',  1, 'b', 'A', '0', '1', undef ],
+	[ undef, 'public', 'dbd_pg_test2', '0', undef, 'dbd_pg_test2_b_key',   'btree',  2, 'c', 'A', '0', '1', undef ],
+	[ undef, 'public', 'dbd_pg_test2', '0', undef, 'dbd_pg_test2_pkey',    'btree',  1, 'a', 'A', '0', '1', undef ],
+	[ undef, 'public', 'dbd_pg_test2', '0', undef, 'dbd_pg_test2_pkey',    'btree',  2, 'b', 'A', '0', '1', undef ],
+],
+three => [
+	[ undef, 'public', 'dbd_pg_test3', undef, undef, undef, 'table', undef, undef, undef, '0', '0', undef ],
+	[ undef, 'public', 'dbd_pg_test3', '0', undef, 'dbd_pg_test3_index_b', 'btree',  1, 'b', 'A', '0', '1', undef ],
+	[ undef, 'public', 'dbd_pg_test3', '0', undef, 'dbd_pg_test3_pkey',    'btree',  1, 'a', 'A', '0', '1', undef ],
+	[ undef, 'public', 'dbd_pg_test3', '0', undef, 'dbd_pg_test3_pred',    'btree',  1, 'c', 'A', '0', '1', '((c > 0) AND (c < 45))' ],
+	[ undef, 'public', 'dbd_pg_test3', '1', undef, 'dbd_pg_test3_oid',     'btree',  1, 'oid', 'A', '0', '1', undef ],
+	[ undef, 'public', 'dbd_pg_test3', '1', undef, 'dbd_pg_test3_index_c', 'hashed', 1, 'c', 'A', '0', '0', undef ],
+],
+three_uo => [
+	[ undef, 'public', 'dbd_pg_test3', '0', undef, 'dbd_pg_test3_index_b', 'btree',  1, 'b', 'A', '0', '1', undef ],
+	[ undef, 'public', 'dbd_pg_test3', '0', undef, 'dbd_pg_test3_pkey',    'btree',  1, 'a', 'A', '0', '1', undef ],
+	[ undef, 'public', 'dbd_pg_test3', '0', undef, 'dbd_pg_test3_pred',    'btree',  1, 'c', 'A', '0', '1', '((c > 0) AND (c < 45))' ],
+],
+};
+
+if(!$got73) { # wipe out the schema names in the expected results above
+	foreach my $subset (values %$correct_stats) {
+		foreach (@$subset) {
+			$_->[1] = undef;
+		}
+	}
+}
+
+SKIP: {
+	skip qq{Cannot test statistics_info with schema arg on pre-7.3 servers.}, 3
+		if ! $got73;
+
+        my $stats;
+
+	$sth = $dbh->statistics_info(undef,'public','dbd_pg_test1',undef,undef);
+        $stats = $sth->fetchall_arrayref;
+	is_deeply($stats, $correct_stats->{one}, 'Correct stats output for public.dbd_pg_test1');
+
+	$sth = $dbh->statistics_info(undef,'public','dbd_pg_test2',undef,undef);
+        $stats = $sth->fetchall_arrayref;
+	is_deeply($stats, $correct_stats->{two}, 'Correct stats output for public.dbd_pg_test2');
+
+	$sth = $dbh->statistics_info(undef,'public','dbd_pg_test3',undef,undef);
+        $stats = $sth->fetchall_arrayref;
+	is_deeply($stats, $correct_stats->{three}, 'Correct stats output for public.dbd_pg_test3');
+
+	$sth = $dbh->statistics_info(undef,'public','dbd_pg_test3',1,undef);
+        $stats = $sth->fetchall_arrayref;
+	is_deeply($stats, $correct_stats->{three_uo}, 'Correct stats output for public.dbd_pg_test3 (unique only)');
+}
+
+{
+        my $stats;
+
+	$sth = $dbh->statistics_info(undef,undef,'dbd_pg_test1',undef,undef);
+        $stats = $sth->fetchall_arrayref;
+	is_deeply($stats, $correct_stats->{one}, 'Correct stats output for dbd_pg_test1');
+
+	$sth = $dbh->statistics_info(undef,undef,'dbd_pg_test2',undef,undef);
+        $stats = $sth->fetchall_arrayref;
+	is_deeply($stats, $correct_stats->{two}, 'Correct stats output for dbd_pg_test2');
+
+	$sth = $dbh->statistics_info(undef,undef,'dbd_pg_test3',undef,undef);
+        $stats = $sth->fetchall_arrayref;
+	is_deeply($stats, $correct_stats->{three}, 'Correct stats output for dbd_pg_test3');
+
+	$sth = $dbh->statistics_info(undef,undef,'dbd_pg_test3',1,undef);
+        $stats = $sth->fetchall_arrayref;
+	is_deeply($stats, $correct_stats->{three_uo}, 'Correct stats output for dbd_pg_test3 (unique only)');
+}
+
+# Clean everything up
+{
+	$dbh->do("DROP TABLE dbd_pg_test3");
+	$dbh->do("DROP TABLE dbd_pg_test2");
+	$dbh->do("DROP TABLE dbd_pg_test1");
+}
+
+#
 # Test of the "foreign_key_info" database handle method
 #

Index: DBI.pm
===================================================================
--- DBI.pm	(revision 6571)
+++ DBI.pm	(working copy)
@@ -423,6 +423,7 @@
 	primary_key_info=> { U =>[4,5,'$catalog, $schema, $table [, \%attr ]' ],	O=>0x2200|0x0800 },
 	primary_key     => { U =>[4,5,'$catalog, $schema, $table [, \%attr ]' ],	O=>0x2200 },
 	foreign_key_info=> { U =>[7,8,'$pk_catalog, $pk_schema, $pk_table, $fk_catalog, $fk_schema, $fk_table [, \%attr ]' ], O=>0x2200|0x0800 },
+        statistics_info => { U =>[6,7,'$catalog, $schema, $table, $unique_only, $quick, [, \%attr ]' ], O=>0x2200|0x0800 },
 	type_info_all	=> { U =>[1,1], O=>0x2200|0x0800 },
 	type_info	=> { U =>[1,2,'$data_type'], O=>0x2200 },
 	get_info	=> { U =>[2,2,'$info_type'], O=>0x2200|0x0800 },
@@ -4723,6 +4724,99 @@
 
 See also L</"Catalog Methods"> and L</"Standards Reference Information">.
 
+=item C<statistics_info>
+
+B<Warning:> This method is experimental and may change.
+
+  $sth = $dbh->statistics_info( $catalog, $schema, $table, $unique_only, $quick );
+
+Returns an active statement handle that can be used to fetch statistical
+information about a table and its indexes.
+
+The arguments don't accept search patterns (unlike L</table_info>).
+
+If the boolean argument $unique_only is true, only UNIQUE indexes will be
+returned in the result set, otherwise all indexes will be returned.
+
+If the boolean argument $quick is set, the actual statistical information
+columns (CARDINALITY and PAGES) will only be returned if they are readily
+available from the server, and might not be current.  Some databases may
+return stale statistics or no statistics at all with this flag set.
+
+For example:
+
+  $sth = $dbh->statistics_info( undef, $user, 'foo', 1, 1 );
+  $data = $sth->fetchall_arrayref;
+
+The statement handle will return at most one row per column name per index,
+plus at most one row for the entire table itself, ordered by NON_UNIQUE, TYPE,
+INDEX_QUALIFIER, INDEX_NAME, and ORDINAL_POSITION.
+
+Note: The support for the selection criteria, such as $catalog, is
+driver specific.  If the driver doesn't support catalogs and/or
+schemas, it may ignore these criteria.
+
+The statement handle returned has at least the following fields in the
+order shown below. Other fields, after these, may also be present.
+
+B<TABLE_CAT>: The catalog identifier.
+This field is NULL (C<undef>) if not applicable to the data source,
+which is often the case.  This field is empty if not applicable to the
+table.
+
+B<TABLE_SCHEM>: The schema identifier.
+This field is NULL (C<undef>) if not applicable to the data source,
+and empty if not applicable to the table.
+
+B<TABLE_NAME>: The table identifier.
+
+B<NON_UNIQUE>: Unique index indicator.
+Returns 0 for unique indexes, 1 for non-unique indexes
+
+B<INDEX_QUALIFIER>: Index qualifier identifier.
+The identifier that is used to qualify the index name when doing a
+C<DROP INDEX>; NULL (C<undef>) is returned if an index qualifier is not
+supported by the data source.
+If a non-NULL (defined) value is returned in this column, it must be used
+to qualify the index name on a C<DROP INDEX> statement; otherwise,
+the TABLE_SCHEM should be used to qualify the index name.
+
+B<INDEX_NAME>: The index identifier.
+
+B<TYPE>: The type of information being returned.  Can be any of the
+following values: 'table', 'btree', 'clustered', 'content', 'hashed',
+or 'other'.
+
+In the case that this field is 'table', all fields
+other than TABLE_CAT, TABLE_SCHEM, TABLE_NAME, TYPE,
+CARDINALITY, and PAGES will be NULL (C<undef>).
+
+B<ORDINAL_POSITION>: Column sequence number (starting with 1).
+
+B<COLUMN_NAME>: The column identifier.
+
+B<ASC_OR_DESC>: Column sort sequence.
+C<A> for Ascending, C<D> for Descending, or NULL (C<undef>) if
+not supported for this index.
+
+B<CARDINALITY>: Cardinality of the table or index.
+For indexes, this is the number of unique values in the index.
+For tables, this is the number of rows in the table.
+If not supported, the value will be NULL (C<undef>).
+
+B<PAGES>: Number of storage pages used by this table or index.
+If not supported, the value will be NULL (C<undef>).
+
+B<FILTER_CONDITION>: The index filter condition as a string.
+If the index is not a filtered index, or it cannot be determined
+whether the index is a filtered index, this value is NULL (C<undef>).
+If the index is a filtered index, but the filter condition
+cannot be determined, this value is the empty string C<''>.
+Otherwise it will be the literal filter condition as a string,
+such as C<SALARY <= 4500>.
+
+See also L</"Catalog Methods"> and L</"Standards Reference Information">.
+
 =item C<tables>
 
   @names = $dbh->tables( $catalog, $schema, $table, $type );
@@ -6307,6 +6401,7 @@
   foreign_key_info
   primary_key_info
   table_info
+  statistics_info
 
 All catalog methods accept arguments in order to restrict the result sets.
 Passing C<undef> to an optional argument does not constrain the search for
@@ -7058,6 +7153,7 @@
  primary_key_info  SQLPrimaryKeys    Page 254
  table_info        SQLTables         Page 294
  type_info         SQLGetTypeInfo    Page 239
+ statistics_info   SQLStatistics
 
 For example, for ODBC information on SQLColumns you'd visit: