diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/DBI/DBD/Metadata.pm')
-rwxr-xr-x | Master/tlpkg/tlperl/lib/DBI/DBD/Metadata.pm | 493 |
1 files changed, 493 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/DBI/DBD/Metadata.pm b/Master/tlpkg/tlperl/lib/DBI/DBD/Metadata.pm new file mode 100755 index 00000000000..31d5b59b04f --- /dev/null +++ b/Master/tlpkg/tlperl/lib/DBI/DBD/Metadata.pm @@ -0,0 +1,493 @@ +package DBI::DBD::Metadata; + +# $Id: Metadata.pm 8696 2007-01-24 23:12:38Z timbo $ +# +# Copyright (c) 1997-2003 Jonathan Leffler, Jochen Wiedmann, +# Steffen Goeldner and Tim Bunce +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + +use Exporter (); +use Carp; + +use DBI; +use DBI::Const::GetInfoType qw(%GetInfoType); + +# Perl 5.005_03 does not recognize 'our' +@ISA = qw(Exporter); +@EXPORT = qw(write_getinfo_pm write_typeinfo_pm); + +$VERSION = sprintf("2.%06d", q$Revision: 8696 $ =~ /(\d+)/o); + + +use strict; + +=head1 NAME + +DBI::DBD::Metadata - Generate the code and data for some DBI metadata methods + +=head1 SYNOPSIS + +The idea is to extract metadata information from a good quality +ODBC driver and use it to generate code and data to use in your own +DBI driver for the same database. + +For generating code to support the get_info method: + + perl -MDBI::DBD::Metadata -e "write_getinfo_pm('dbi:ODBC:dsn-name','user','pass','Driver')" + + perl -MDBI::DBD::Metadata -e write_getinfo_pm dbi:ODBC:foo_db username password Driver + +For generating code to support the type_info method: + + perl -MDBI::DBD::Metadata -e "write_typeinfo_pm('dbi:ODBC:dsn-name','user','pass','Driver')" + + perl -MDBI::DBD::Metadata -e write_typeinfo_pm dbi:ODBC:dsn-name user pass Driver + +Where C<dbi:ODBC:dsn-name> is the connection to use to extract the +data, and C<Driver> is the name of the driver you want the code +generated for (the driver name gets embedded into the output in +many places). + +=head1 Generating a GetInfo package for a driver + +The C<write_getinfo_pm> in the DBI::DBD::Metadata module generates a +DBD::Driver::GetInfo package on standard output. + +This method generates a DBD::Driver::GetInfo package from the data +source you specified in the parameter list or in the environment +variable DBI_DSN. +DBD::Driver::GetInfo should help a DBD author implementing the DBI +get_info() method. +Because you are just creating this package, it's very unlikely that +DBD::Driver already provides a good implementation for get_info(). +Thus you will probably connect via DBD::ODBC. + +Once you are sure that it is producing semi-sane data, you would +typically redirect the standard output to lib/DBD/Driver/GetInfo.pm, and +then hand edit the result. +Do not forget to update your Makefile.PL and MANIFEST to include this as +an extra PM file that should be installed. + +If you connect via DBD::ODBC, you should use version 0.38 or greater; + +Please take a critical look at the data returned! +ODBC drivers vary dramatically in their quality. + +The generator assumes that most values are static and places these +values directly in the %info hash. +A few examples show the use of CODE references and the implementation +via subroutines. +It is very likely that you have to write additional subroutines for +values depending on the session state or server version, e.g. +SQL_DBMS_VER. + +A possible implementation of DBD::Driver::db::get_info() may look like: + + sub get_info { + my($dbh, $info_type) = @_; + require DBD::Driver::GetInfo; + my $v = $DBD::Driver::GetInfo::info{int($info_type)}; + $v = $v->($dbh) if ref $v eq 'CODE'; + return $v; + } + +Please replace Driver (or "<foo>") with the name of your driver. +Note that this stub function is generated for you by write_getinfo_pm +function, but you must manually transfer the code to Driver.pm. + +=cut + +sub write_getinfo_pm +{ + my ($dsn, $user, $pass, $driver) = @_ ? @_ : @ARGV; + my $dbh = DBI->connect($dsn, $user, $pass, {RaiseError=>1}); + $driver = "<foo>" unless defined $driver; + + print <<PERL; + +# Transfer this to ${driver}.pm + +# The get_info function was automatically generated by +# DBI::DBD::Metadata::write_getinfo_pm v$DBI::DBD::Metadata::VERSION. + +package DBD::${driver}::db; # This line can be removed once transferred. + + sub get_info { + my(\$dbh, \$info_type) = \@_; + require DBD::${driver}::GetInfo; + my \$v = \$DBD::${driver}::GetInfo::info{int(\$info_type)}; + \$v = \$v->(\$dbh) if ref \$v eq 'CODE'; + return \$v; + } + +# Transfer this to lib/DBD/${driver}/GetInfo.pm + +# The \%info hash was automatically generated by +# DBI::DBD::Metadata::write_getinfo_pm v$DBI::DBD::Metadata::VERSION. + +package DBD::${driver}::GetInfo; + +use strict; +use DBD::${driver}; + +# Beware: not officially documented interfaces... +# use DBI::Const::GetInfoType qw(\%GetInfoType); +# use DBI::Const::GetInfoReturn qw(\%GetInfoReturnTypes \%GetInfoReturnValues); + +my \$sql_driver = '${driver}'; +my \$sql_ver_fmt = '%02d.%02d.%04d'; # ODBC version string: ##.##.##### +my \$sql_driver_ver = sprintf \$sql_ver_fmt, split (/\\./, \$DBD::${driver}::VERSION); +PERL + +my $kw_map = 0; +{ +# Informix CLI (ODBC) v3.81.0000 does not return a list of keywords. + local $\ = "\n"; + local $, = "\n"; + my ($kw) = $dbh->get_info($GetInfoType{SQL_KEYWORDS}); + if ($kw) + { + print "\nmy \@Keywords = qw(\n"; + print sort split /,/, $kw; + print ");\n\n"; + print "sub sql_keywords {\n"; + print q% return join ',', @Keywords;%; + print "\n}\n\n"; + $kw_map = 1; + } +} + + print <<'PERL'; + +sub sql_data_source_name { + my $dbh = shift; + return "dbi:$sql_driver:" . $dbh->{Name}; +} + +sub sql_user_name { + my $dbh = shift; + # CURRENT_USER is a non-standard attribute, probably undef + # Username is a standard DBI attribute + return $dbh->{CURRENT_USER} || $dbh->{Username}; +} + +PERL + + print "\nour \%info = (\n"; + foreach my $key (sort keys %GetInfoType) + { + my $num = $GetInfoType{$key}; + my $val = eval { $dbh->get_info($num); }; + if ($key eq 'SQL_DATA_SOURCE_NAME') { + $val = '\&sql_data_source_name'; + } + elsif ($key eq 'SQL_KEYWORDS') { + $val = ($kw_map) ? '\&sql_keywords' : 'undef'; + } + elsif ($key eq 'SQL_DRIVER_NAME') { + $val = "\$INC{'DBD/$driver.pm'}"; + } + elsif ($key eq 'SQL_DRIVER_VER') { + $val = '$sql_driver_ver'; + } + elsif ($key eq 'SQL_USER_NAME') { + $val = '\&sql_user_name'; + } + elsif (not defined $val) { + $val = 'undef'; + } + elsif ($val eq '') { + $val = "''"; + } + elsif ($val =~ /\D/) { + $val =~ s/\\/\\\\/g; + $val =~ s/'/\\'/g; + $val = "'$val'"; + } + printf "%s %5d => %-30s # %s\n", (($val eq 'undef') ? '#' : ' '), $num, "$val,", $key; + } + print ");\n\n1;\n\n__END__\n"; +} + + + +=head1 Generating a TypeInfo package for a driver + +The C<write_typeinfo_pm> function in the DBI::DBD::Metadata module generates +on standard output the data needed for a driver's type_info_all method. +It also provides default implementations of the type_info_all +method for inclusion in the driver's main implementation file. + +The driver parameter is the name of the driver for which the methods +will be generated; for the sake of examples, this will be "Driver". +Typically, the dsn parameter will be of the form "dbi:ODBC:odbc_dsn", +where the odbc_dsn is a DSN for one of the driver's databases. +The user and pass parameters are the other optional connection +parameters that will be provided to the DBI connect method. + +Once you are sure that it is producing semi-sane data, you would +typically redirect the standard output to lib/DBD/Driver/TypeInfo.pm, +and then hand edit the result if necessary. +Do not forget to update your Makefile.PL and MANIFEST to include this as +an extra PM file that should be installed. + +Please take a critical look at the data returned! +ODBC drivers vary dramatically in their quality. + +The generator assumes that all the values are static and places these +values directly in the %info hash. + +A possible implementation of DBD::Driver::type_info_all() may look like: + + sub type_info_all { + my ($dbh) = @_; + require DBD::Driver::TypeInfo; + return [ @$DBD::Driver::TypeInfo::type_info_all ]; + } + +Please replace Driver (or "<foo>") with the name of your driver. +Note that this stub function is generated for you by the write_typeinfo_pm +function, but you must manually transfer the code to Driver.pm. + +=cut + + +# These two are used by fmt_value... +my %dbi_inv; +my %sql_type_inv; + +#-DEBUGGING-# +#sub print_hash +#{ +# my ($name, %hash) = @_; +# print "Hash: $name\n"; +# foreach my $key (keys %hash) +# { +# print "$key => $hash{$key}\n"; +# } +#} +#-DEBUGGING-# + +sub inverse_hash +{ + my (%hash) = @_; + my (%inv); + foreach my $key (keys %hash) + { + my $val = $hash{$key}; + die "Double mapping for key value $val ($inv{$val}, $key)!" + if (defined $inv{$val}); + $inv{$val} = $key; + } + return %inv; +} + +sub fmt_value +{ + my ($num, $val) = @_; + if (!defined $val) + { + $val = "undef"; + } + elsif ($val !~ m/^[-+]?\d+$/) + { + # All the numbers in type_info_all are integers! + # Anything that isn't an integer is a string. + # Ensure that no double quotes screw things up. + $val =~ s/"/\\"/g if ($val =~ m/"/o); + $val = qq{"$val"}; + } + elsif ($dbi_inv{$num} =~ m/^(SQL_)?DATA_TYPE$/) + { + # All numeric... + $val = $sql_type_inv{$val} + if (defined $sql_type_inv{$val}); + } + return $val; +} + +sub write_typeinfo_pm +{ + my ($dsn, $user, $pass, $driver) = @_ ? @_ : @ARGV; + my $dbh = DBI->connect($dsn, $user, $pass, {AutoCommit=>1, RaiseError=>1}); + $driver = "<foo>" unless defined $driver; + + print <<PERL; + +# Transfer this to ${driver}.pm + +# The type_info_all function was automatically generated by +# DBI::DBD::Metadata::write_typeinfo_pm v$DBI::DBD::Metadata::VERSION. + +package DBD::${driver}::db; # This line can be removed once transferred. + + sub type_info_all + { + my (\$dbh) = \@_; + require DBD::${driver}::TypeInfo; + return [ \@\$DBD::${driver}::TypeInfo::type_info_all ]; + } + +# Transfer this to lib/DBD/${driver}/TypeInfo.pm. +# Don't forget to add version and intellectual property control information. + +# The \%type_info_all hash was automatically generated by +# DBI::DBD::Metadata::write_typeinfo_pm v$DBI::DBD::Metadata::VERSION. + +package DBD::${driver}::TypeInfo; + +{ + require Exporter; + require DynaLoader; + \@ISA = qw(Exporter DynaLoader); + \@EXPORT = qw(type_info_all); + use DBI qw(:sql_types); + +PERL + + # Generate SQL type name mapping hashes. + # See code fragment in DBI specification. + my %sql_type_map; + foreach (@{$DBI::EXPORT_TAGS{sql_types}}) + { + no strict 'refs'; + $sql_type_map{$_} = &{"DBI::$_"}(); + $sql_type_inv{$sql_type_map{$_}} = $_; + } + #-DEBUG-# print_hash("sql_type_map", %sql_type_map); + #-DEBUG-# print_hash("sql_type_inv", %sql_type_inv); + + my %dbi_map = + ( + TYPE_NAME => 0, + DATA_TYPE => 1, + COLUMN_SIZE => 2, + LITERAL_PREFIX => 3, + LITERAL_SUFFIX => 4, + CREATE_PARAMS => 5, + NULLABLE => 6, + CASE_SENSITIVE => 7, + SEARCHABLE => 8, + UNSIGNED_ATTRIBUTE => 9, + FIXED_PREC_SCALE => 10, + AUTO_UNIQUE_VALUE => 11, + LOCAL_TYPE_NAME => 12, + MINIMUM_SCALE => 13, + MAXIMUM_SCALE => 14, + SQL_DATA_TYPE => 15, + SQL_DATETIME_SUB => 16, + NUM_PREC_RADIX => 17, + INTERVAL_PRECISION => 18, + ); + + #-DEBUG-# print_hash("dbi_map", %dbi_map); + + %dbi_inv = inverse_hash(%dbi_map); + + #-DEBUG-# print_hash("dbi_inv", %dbi_inv); + + my $maxlen = 0; + foreach my $key (keys %dbi_map) + { + $maxlen = length($key) if length($key) > $maxlen; + } + + # Print the name/value mapping entry in the type_info_all array; + my $fmt = " \%-${maxlen}s => \%2d,\n"; + my $numkey = 0; + my $maxkey = 0; + print " \$type_info_all = [\n {\n"; + foreach my $i (sort { $a <=> $b } keys %dbi_inv) + { + printf($fmt, $dbi_inv{$i}, $i); + $numkey++; + $maxkey = $i; + } + print " },\n"; + + print STDERR "### WARNING - Non-dense set of keys ($numkey keys, $maxkey max key)\n" + unless $numkey = $maxkey + 1; + + my $h = $dbh->type_info_all; + my @tia = @$h; + my %odbc_map = map { uc $_ => $tia[0]->{$_} } keys %{$tia[0]}; + shift @tia; # Remove the mapping reference. + my $numtyp = $#tia; + + #-DEBUG-# print_hash("odbc_map", %odbc_map); + + # In theory, the key/number mapping sequence for %dbi_map + # should be the same as the one from the ODBC driver. However, to + # prevent the possibility of mismatches, and to deal with older + # missing attributes or unexpected new ones, we chase back through + # the %dbi_inv and %odbc_map hashes, generating @dbi_to_odbc + # to map our new key number to the old one. + # Report if @dbi_to_odbc is not an identity mapping. + my @dbi_to_odbc; + foreach my $num (sort { $a <=> $b } keys %dbi_inv) + { + # Find the name in %dbi_inv that matches this index number. + my $dbi_key = $dbi_inv{$num}; + #-DEBUG-# print "dbi_key = $dbi_key\n"; + #-DEBUG-# print "odbc_key = $odbc_map{$dbi_key}\n"; + # Find the index in %odbc_map that has this key. + $dbi_to_odbc[$num] = (defined $odbc_map{$dbi_key}) ? $odbc_map{$dbi_key} : undef; + } + + # Determine the length of the longest formatted value in each field + my @len; + for (my $i = 0; $i <= $numtyp; $i++) + { + my @odbc_val = @{$tia[$i]}; + for (my $num = 0; $num <= $maxkey; $num++) + { + # Find the value of the entry in the @odbc_val array. + my $val = (defined $dbi_to_odbc[$num]) ? $odbc_val[$dbi_to_odbc[$num]] : undef; + $val = fmt_value($num, $val); + #-DEBUG-# print "val = $val\n"; + $val = "$val,"; + $len[$num] = length($val) if !defined $len[$num] || length($val) > $len[$num]; + } + } + + # Generate format strings to left justify each string in maximum field width. + my @fmt; + for (my $i = 0; $i <= $maxkey; $i++) + { + $fmt[$i] = "%-$len[$i]s"; + #-DEBUG-# print "fmt[$i] = $fmt[$i]\n"; + } + + # Format the data from type_info_all + for (my $i = 0; $i <= $numtyp; $i++) + { + my @odbc_val = @{$tia[$i]}; + print " [ "; + for (my $num = 0; $num <= $maxkey; $num++) + { + # Find the value of the entry in the @odbc_val array. + my $val = (defined $dbi_to_odbc[$num]) ? $odbc_val[$dbi_to_odbc[$num]] : undef; + $val = fmt_value($num, $val); + printf $fmt[$num], "$val,"; + } + print " ],\n"; + } + + print " ];\n\n 1;\n}\n\n__END__\n"; + +} + +1; + +__END__ + +=head1 AUTHORS + +Jonathan Leffler <jleffler@us.ibm.com> (previously <jleffler@informix.com>), +Jochen Wiedmann <joe@ispsoft.de>, +Steffen Goeldner <sgoeldner@cpan.org>, +and Tim Bunce <dbi-users@perl.org>. + +=cut |