File Coverage

blib/lib/DBI/DBD/Metadata.pm
Criterion Covered Total %
statement 18 128 14.0
branch 0 54 0.0
condition 0 3 0.0
subroutine 6 10 60.0
pod 0 4 0.0
total 24 199 12.0


line stmt bran cond sub pod time code
1             package DBI::DBD::Metadata;
2              
3             # $Id: Metadata.pm 14213 2010-06-30 19:29:18Z Martin $
4             #
5             # Copyright (c) 1997-2003 Jonathan Leffler, Jochen Wiedmann,
6             # Steffen Goeldner and Tim Bunce
7             #
8             # You may distribute under the terms of either the GNU General Public
9             # License or the Artistic License, as specified in the Perl README file.
10              
11 4     4   7088 use strict;
  4         9  
  4         106  
12              
13 4     4   17 use Exporter ();
  4         8  
  4         53  
14 4     4   16 use Carp;
  4         6  
  4         248  
15              
16 4     4   23 use DBI;
  4         9  
  4         121  
17 4     4   1340 use DBI::Const::GetInfoType qw(%GetInfoType);
  4         10  
  4         3549  
18              
19             our @ISA = qw(Exporter);
20             our @EXPORT = qw(write_getinfo_pm write_typeinfo_pm);
21              
22             our $VERSION = "2.014214";
23              
24              
25             =head1 NAME
26              
27             DBI::DBD::Metadata - Generate the code and data for some DBI metadata methods
28              
29             =head1 SYNOPSIS
30              
31             The idea is to extract metadata information from a good quality
32             ODBC driver and use it to generate code and data to use in your own
33             DBI driver for the same database.
34              
35             To generate code to support the get_info method:
36              
37             perl -MDBI::DBD::Metadata -e "write_getinfo_pm('dbi:ODBC:dsn-name','user','pass','Driver')"
38              
39             perl -MDBI::DBD::Metadata -e write_getinfo_pm dbi:ODBC:foo_db username password Driver
40              
41             To generate code to support the type_info method:
42              
43             perl -MDBI::DBD::Metadata -e "write_typeinfo_pm('dbi:ODBC:dsn-name','user','pass','Driver')"
44              
45             perl -MDBI::DBD::Metadata -e write_typeinfo_pm dbi:ODBC:dsn-name user pass Driver
46              
47             Where C is the connection to use to extract the
48             data, and C is the name of the driver you want the code
49             generated for (the driver name gets embedded into the output in
50             numerous places).
51              
52             =head1 Generating a GetInfo package for a driver
53              
54             The C in the DBI::DBD::Metadata module generates a
55             DBD::Driver::GetInfo package on standard output.
56              
57             This method generates a DBD::Driver::GetInfo package from the data
58             source you specified in the parameter list or in the environment
59             variable DBI_DSN.
60             DBD::Driver::GetInfo should help a DBD author implement the DBI
61             get_info() method.
62             Because you are just creating this package, it is very unlikely that
63             DBD::Driver already provides a good implementation for get_info().
64             Thus you will probably connect via DBD::ODBC.
65              
66             Once you are sure that it is producing reasonably sane data, you should
67             typically redirect the standard output to lib/DBD/Driver/GetInfo.pm, and
68             then hand edit the result.
69             Do not forget to update your Makefile.PL and MANIFEST to include this as
70             an extra PM file that should be installed.
71              
72             If you connect via DBD::ODBC, you should use version 0.38 or greater;
73              
74             Please take a critical look at the data returned!
75             ODBC drivers vary dramatically in their quality.
76              
77             The generator assumes that most values are static and places these
78             values directly in the %info hash.
79             A few examples show the use of CODE references and the implementation
80             via subroutines.
81             It is very likely that you will have to write additional subroutines for
82             values depending on the session state or server version, e.g.
83             SQL_DBMS_VER.
84              
85             A possible implementation of DBD::Driver::db::get_info() may look like:
86              
87             sub get_info {
88             my($dbh, $info_type) = @_;
89             require DBD::Driver::GetInfo;
90             my $v = $DBD::Driver::GetInfo::info{int($info_type)};
91             $v = $v->($dbh) if ref $v eq 'CODE';
92             return $v;
93             }
94              
95             Please replace Driver (or "") with the name of your driver.
96             Note that this stub function is generated for you by write_getinfo_pm
97             function, but you must manually transfer the code to Driver.pm.
98              
99             =cut
100              
101             sub write_getinfo_pm
102             {
103 0 0   0 0   my ($dsn, $user, $pass, $driver) = @_ ? @_ : @ARGV;
104 0           my $dbh = DBI->connect($dsn, $user, $pass, {RaiseError=>1});
105 0 0         $driver = "" unless defined $driver;
106              
107 0           print <
108              
109             # Transfer this to ${driver}.pm
110              
111             # The get_info function was automatically generated by
112             # DBI::DBD::Metadata::write_getinfo_pm v$DBI::DBD::Metadata::VERSION.
113              
114             package DBD::${driver}::db; # This line can be removed once transferred.
115              
116             sub get_info {
117             my(\$dbh, \$info_type) = \@_;
118             require DBD::${driver}::GetInfo;
119             my \$v = \$DBD::${driver}::GetInfo::info{int(\$info_type)};
120             \$v = \$v->(\$dbh) if ref \$v eq 'CODE';
121             return \$v;
122             }
123              
124             # Transfer this to lib/DBD/${driver}/GetInfo.pm
125              
126             # The \%info hash was automatically generated by
127             # DBI::DBD::Metadata::write_getinfo_pm v$DBI::DBD::Metadata::VERSION.
128              
129             package DBD::${driver}::GetInfo;
130              
131             use strict;
132             use DBD::${driver};
133              
134             # Beware: not officially documented interfaces...
135             # use DBI::Const::GetInfoType qw(\%GetInfoType);
136             # use DBI::Const::GetInfoReturn qw(\%GetInfoReturnTypes \%GetInfoReturnValues);
137              
138             my \$sql_driver = '${driver}';
139             my \$sql_ver_fmt = '%02d.%02d.%04d'; # ODBC version string: ##.##.#####
140             my \$sql_driver_ver = sprintf \$sql_ver_fmt, split (/\\./, \$DBD::${driver}::VERSION);
141             PERL
142              
143 0           my $kw_map = 0;
144             {
145             # Informix CLI (ODBC) v3.81.0000 does not return a list of keywords.
146 0           local $\ = "\n";
  0            
147 0           local $, = "\n";
148 0           my ($kw) = $dbh->get_info($GetInfoType{SQL_KEYWORDS});
149 0 0         if ($kw)
150             {
151 0           print "\nmy \@Keywords = qw(\n";
152 0           print sort split /,/, $kw;
153 0           print ");\n\n";
154 0           print "sub sql_keywords {\n";
155 0           print q% return join ',', @Keywords;%;
156 0           print "\n}\n\n";
157 0           $kw_map = 1;
158             }
159             }
160              
161 0           print <<'PERL';
162              
163             sub sql_data_source_name {
164             my $dbh = shift;
165             return "dbi:$sql_driver:" . $dbh->{Name};
166             }
167              
168             sub sql_user_name {
169             my $dbh = shift;
170             # CURRENT_USER is a non-standard attribute, probably undef
171             # Username is a standard DBI attribute
172             return $dbh->{CURRENT_USER} || $dbh->{Username};
173             }
174              
175             PERL
176              
177 0           print "\nour \%info = (\n";
178 0           foreach my $key (sort keys %GetInfoType)
179             {
180 0           my $num = $GetInfoType{$key};
181 0           my $val = eval { $dbh->get_info($num); };
  0            
182 0 0         if ($key eq 'SQL_DATA_SOURCE_NAME') {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
183 0           $val = '\&sql_data_source_name';
184             }
185             elsif ($key eq 'SQL_KEYWORDS') {
186 0 0         $val = ($kw_map) ? '\&sql_keywords' : 'undef';
187             }
188             elsif ($key eq 'SQL_DRIVER_NAME') {
189 0           $val = "\$INC{'DBD/$driver.pm'}";
190             }
191             elsif ($key eq 'SQL_DRIVER_VER') {
192 0           $val = '$sql_driver_ver';
193             }
194             elsif ($key eq 'SQL_USER_NAME') {
195 0           $val = '\&sql_user_name';
196             }
197             elsif (not defined $val) {
198 0           $val = 'undef';
199             }
200             elsif ($val eq '') {
201 0           $val = "''";
202             }
203             elsif ($val =~ /\D/) {
204 0           $val =~ s/\\/\\\\/g;
205 0           $val =~ s/'/\\'/g;
206 0           $val = "'$val'";
207             }
208 0 0         printf "%s %5d => %-30s # %s\n", (($val eq 'undef') ? '#' : ' '), $num, "$val,", $key;
209             }
210 0           print ");\n\n1;\n\n__END__\n";
211             }
212              
213              
214              
215             =head1 Generating a TypeInfo package for a driver
216              
217             The C function in the DBI::DBD::Metadata module generates
218             on standard output the data needed for a driver's type_info_all method.
219             It also provides default implementations of the type_info_all
220             method for inclusion in the driver's main implementation file.
221              
222             The driver parameter is the name of the driver for which the methods
223             will be generated; for the sake of examples, this will be "Driver".
224             Typically, the dsn parameter will be of the form "dbi:ODBC:odbc_dsn",
225             where the odbc_dsn is a DSN for one of the driver's databases.
226             The user and pass parameters are the other optional connection
227             parameters that will be provided to the DBI connect method.
228              
229             Once you are sure that it is producing reasonably sane data, you should
230             typically redirect the standard output to lib/DBD/Driver/TypeInfo.pm,
231             and then hand edit the result if necessary.
232             Do not forget to update your Makefile.PL and MANIFEST to include this as
233             an extra PM file that should be installed.
234              
235             Please take a critical look at the data returned!
236             ODBC drivers vary dramatically in their quality.
237              
238             The generator assumes that all the values are static and places these
239             values directly in the %info hash.
240              
241             A possible implementation of DBD::Driver::type_info_all() may look like:
242              
243             sub type_info_all {
244             my ($dbh) = @_;
245             require DBD::Driver::TypeInfo;
246             return [ @$DBD::Driver::TypeInfo::type_info_all ];
247             }
248              
249             Please replace Driver (or "") with the name of your driver.
250             Note that this stub function is generated for you by the write_typeinfo_pm
251             function, but you must manually transfer the code to Driver.pm.
252              
253             =cut
254              
255              
256             # These two are used by fmt_value...
257             my %dbi_inv;
258             my %sql_type_inv;
259              
260             #-DEBUGGING-#
261             #sub print_hash
262             #{
263             # my ($name, %hash) = @_;
264             # print "Hash: $name\n";
265             # foreach my $key (keys %hash)
266             # {
267             # print "$key => $hash{$key}\n";
268             # }
269             #}
270             #-DEBUGGING-#
271              
272             sub inverse_hash
273             {
274 0     0 0   my (%hash) = @_;
275 0           my (%inv);
276 0           foreach my $key (keys %hash)
277             {
278 0           my $val = $hash{$key};
279             die "Double mapping for key value $val ($inv{$val}, $key)!"
280 0 0         if (defined $inv{$val});
281 0           $inv{$val} = $key;
282             }
283 0           return %inv;
284             }
285              
286             sub fmt_value
287             {
288 0     0 0   my ($num, $val) = @_;
289 0 0         if (!defined $val)
    0          
    0          
290             {
291 0           $val = "undef";
292             }
293             elsif ($val !~ m/^[-+]?\d+$/)
294             {
295             # All the numbers in type_info_all are integers!
296             # Anything that isn't an integer is a string.
297             # Ensure that no double quotes screw things up.
298 0 0         $val =~ s/"/\\"/g if ($val =~ m/"/o);
299 0           $val = qq{"$val"};
300             }
301             elsif ($dbi_inv{$num} =~ m/^(SQL_)?DATA_TYPE$/)
302             {
303             # All numeric...
304             $val = $sql_type_inv{$val}
305 0 0         if (defined $sql_type_inv{$val});
306             }
307 0           return $val;
308             }
309              
310             sub write_typeinfo_pm
311             {
312 0 0   0 0   my ($dsn, $user, $pass, $driver) = @_ ? @_ : @ARGV;
313 0           my $dbh = DBI->connect($dsn, $user, $pass, {AutoCommit=>1, RaiseError=>1});
314 0 0         $driver = "" unless defined $driver;
315              
316 0           print <
317              
318             # Transfer this to ${driver}.pm
319              
320             # The type_info_all function was automatically generated by
321             # DBI::DBD::Metadata::write_typeinfo_pm v$DBI::DBD::Metadata::VERSION.
322              
323             package DBD::${driver}::db; # This line can be removed once transferred.
324              
325             sub type_info_all
326             {
327             my (\$dbh) = \@_;
328             require DBD::${driver}::TypeInfo;
329             return [ \@\$DBD::${driver}::TypeInfo::type_info_all ];
330             }
331              
332             # Transfer this to lib/DBD/${driver}/TypeInfo.pm.
333             # Don't forget to add version and intellectual property control information.
334              
335             # The \%type_info_all hash was automatically generated by
336             # DBI::DBD::Metadata::write_typeinfo_pm v$DBI::DBD::Metadata::VERSION.
337              
338             package DBD::${driver}::TypeInfo;
339              
340             {
341             require Exporter;
342             require DynaLoader;
343             \@ISA = qw(Exporter DynaLoader);
344             \@EXPORT = qw(type_info_all);
345             use DBI qw(:sql_types);
346              
347             PERL
348              
349             # Generate SQL type name mapping hashes.
350             # See code fragment in DBI specification.
351 0           my %sql_type_map;
352 0           foreach (@{$DBI::EXPORT_TAGS{sql_types}})
  0            
353             {
354 4     4   35 no strict 'refs';
  4         7  
  4         2073  
355 0           $sql_type_map{$_} = &{"DBI::$_"}();
  0            
356 0           $sql_type_inv{$sql_type_map{$_}} = $_;
357             }
358             #-DEBUG-# print_hash("sql_type_map", %sql_type_map);
359             #-DEBUG-# print_hash("sql_type_inv", %sql_type_inv);
360              
361 0           my %dbi_map =
362             (
363             TYPE_NAME => 0,
364             DATA_TYPE => 1,
365             COLUMN_SIZE => 2,
366             LITERAL_PREFIX => 3,
367             LITERAL_SUFFIX => 4,
368             CREATE_PARAMS => 5,
369             NULLABLE => 6,
370             CASE_SENSITIVE => 7,
371             SEARCHABLE => 8,
372             UNSIGNED_ATTRIBUTE => 9,
373             FIXED_PREC_SCALE => 10,
374             AUTO_UNIQUE_VALUE => 11,
375             LOCAL_TYPE_NAME => 12,
376             MINIMUM_SCALE => 13,
377             MAXIMUM_SCALE => 14,
378             SQL_DATA_TYPE => 15,
379             SQL_DATETIME_SUB => 16,
380             NUM_PREC_RADIX => 17,
381             INTERVAL_PRECISION => 18,
382             );
383              
384             #-DEBUG-# print_hash("dbi_map", %dbi_map);
385              
386 0           %dbi_inv = inverse_hash(%dbi_map);
387              
388             #-DEBUG-# print_hash("dbi_inv", %dbi_inv);
389              
390 0           my $maxlen = 0;
391 0           foreach my $key (keys %dbi_map)
392             {
393 0 0         $maxlen = length($key) if length($key) > $maxlen;
394             }
395              
396             # Print the name/value mapping entry in the type_info_all array;
397 0           my $fmt = " \%-${maxlen}s => \%2d,\n";
398 0           my $numkey = 0;
399 0           my $maxkey = 0;
400 0           print " \$type_info_all = [\n {\n";
401 0           foreach my $i (sort { $a <=> $b } keys %dbi_inv)
  0            
402             {
403 0           printf($fmt, $dbi_inv{$i}, $i);
404 0           $numkey++;
405 0           $maxkey = $i;
406             }
407 0           print " },\n";
408              
409 0 0         print STDERR "### WARNING - Non-dense set of keys ($numkey keys, $maxkey max key)\n"
410             unless $numkey = $maxkey + 1;
411              
412 0           my $h = $dbh->type_info_all;
413 0           my @tia = @$h;
414 0           my %odbc_map = map { uc $_ => $tia[0]->{$_} } keys %{$tia[0]};
  0            
  0            
415 0           shift @tia; # Remove the mapping reference.
416 0           my $numtyp = $#tia;
417              
418             #-DEBUG-# print_hash("odbc_map", %odbc_map);
419              
420             # In theory, the key/number mapping sequence for %dbi_map
421             # should be the same as the one from the ODBC driver. However, to
422             # prevent the possibility of mismatches, and to deal with older
423             # missing attributes or unexpected new ones, we chase back through
424             # the %dbi_inv and %odbc_map hashes, generating @dbi_to_odbc
425             # to map our new key number to the old one.
426             # Report if @dbi_to_odbc is not an identity mapping.
427 0           my @dbi_to_odbc;
428 0           foreach my $num (sort { $a <=> $b } keys %dbi_inv)
  0            
429             {
430             # Find the name in %dbi_inv that matches this index number.
431 0           my $dbi_key = $dbi_inv{$num};
432             #-DEBUG-# print "dbi_key = $dbi_key\n";
433             #-DEBUG-# print "odbc_key = $odbc_map{$dbi_key}\n";
434             # Find the index in %odbc_map that has this key.
435 0 0         $dbi_to_odbc[$num] = (defined $odbc_map{$dbi_key}) ? $odbc_map{$dbi_key} : undef;
436             }
437              
438             # Determine the length of the longest formatted value in each field
439 0           my @len;
440 0           for (my $i = 0; $i <= $numtyp; $i++)
441             {
442 0           my @odbc_val = @{$tia[$i]};
  0            
443 0           for (my $num = 0; $num <= $maxkey; $num++)
444             {
445             # Find the value of the entry in the @odbc_val array.
446 0 0         my $val = (defined $dbi_to_odbc[$num]) ? $odbc_val[$dbi_to_odbc[$num]] : undef;
447 0           $val = fmt_value($num, $val);
448             #-DEBUG-# print "val = $val\n";
449 0           $val = "$val,";
450 0 0 0       $len[$num] = length($val) if !defined $len[$num] || length($val) > $len[$num];
451             }
452             }
453              
454             # Generate format strings to left justify each string in maximum field width.
455 0           my @fmt;
456 0           for (my $i = 0; $i <= $maxkey; $i++)
457             {
458 0           $fmt[$i] = "%-$len[$i]s";
459             #-DEBUG-# print "fmt[$i] = $fmt[$i]\n";
460             }
461              
462             # Format the data from type_info_all
463 0           for (my $i = 0; $i <= $numtyp; $i++)
464             {
465 0           my @odbc_val = @{$tia[$i]};
  0            
466 0           print " [ ";
467 0           for (my $num = 0; $num <= $maxkey; $num++)
468             {
469             # Find the value of the entry in the @odbc_val array.
470 0 0         my $val = (defined $dbi_to_odbc[$num]) ? $odbc_val[$dbi_to_odbc[$num]] : undef;
471 0           $val = fmt_value($num, $val);
472 0           printf $fmt[$num], "$val,";
473             }
474 0           print " ],\n";
475             }
476              
477 0           print " ];\n\n 1;\n}\n\n__END__\n";
478              
479             }
480              
481             1;
482              
483             __END__