diff options
Diffstat (limited to 'Master/tlpkg/tlperl.straw/lib/DBI/Const/GetInfoReturn.pm')
-rwxr-xr-x | Master/tlpkg/tlperl.straw/lib/DBI/Const/GetInfoReturn.pm | 105 |
1 files changed, 105 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl.straw/lib/DBI/Const/GetInfoReturn.pm b/Master/tlpkg/tlperl.straw/lib/DBI/Const/GetInfoReturn.pm new file mode 100755 index 00000000000..d07b7ac8544 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/DBI/Const/GetInfoReturn.pm @@ -0,0 +1,105 @@ +# $Id: GetInfoReturn.pm 8696 2007-01-24 23:12:38Z timbo $ +# +# Copyright (c) 2002 Tim Bunce Ireland +# +# Constant data describing return values from the DBI getinfo function. +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + +package DBI::Const::GetInfoReturn; + +use strict; + +use Exporter (); + +use vars qw(@ISA @EXPORT @EXPORT_OK %GetInfoReturnTypes %GetInfoReturnValues); + +@ISA = qw(Exporter); +@EXPORT = qw(%GetInfoReturnTypes %GetInfoReturnValues); + +my +$VERSION = sprintf("2.%06d", q$Revision: 8696 $ =~ /(\d+)/o); + + +=head1 NAME + +DBI::Const::GetInfoReturn - Data and functions for describing GetInfo results + +=head1 SYNOPSIS + +The interface to this module is undocumented and liable to change. + +=head1 DESCRIPTION + +Data and functions for describing GetInfo results + +=cut + +use DBI::Const::GetInfoType; + +use DBI::Const::GetInfo::ANSI (); +use DBI::Const::GetInfo::ODBC (); + +%GetInfoReturnTypes = +( + %DBI::Const::GetInfo::ANSI::ReturnTypes +, %DBI::Const::GetInfo::ODBC::ReturnTypes +); + +%GetInfoReturnValues = (); +{ + my $A = \%DBI::Const::GetInfo::ANSI::ReturnValues; + my $O = \%DBI::Const::GetInfo::ODBC::ReturnValues; + while ( my ($k, $v) = each %$A ) { + my %h = ( exists $O->{$k} ) ? ( %$v, %{$O->{$k}} ) : %$v; + $GetInfoReturnValues{$k} = \%h; + } + while ( my ($k, $v) = each %$O ) { + next if exists $A->{$k}; + my %h = %$v; + $GetInfoReturnValues{$k} = \%h; + } +} + +# ----------------------------------------------------------------------------- + +sub Format { + my $InfoType = shift; + my $Value = shift; + + return '' unless defined $Value; + + my $ReturnType = $GetInfoReturnTypes{$InfoType}; + + return sprintf '0x%08X', $Value if $ReturnType eq 'SQLUINTEGER bitmask'; + return sprintf '0x%08X', $Value if $ReturnType eq 'SQLINTEGER bitmask'; +# return '"' . $Value . '"' if $ReturnType eq 'SQLCHAR'; + return $Value; +} + + +sub Explain { + my $InfoType = shift; + my $Value = shift; + + return '' unless defined $Value; + return '' unless exists $GetInfoReturnValues{$InfoType}; + + $Value = int $Value; + my $ReturnType = $GetInfoReturnTypes{$InfoType}; + my %h = reverse %{$GetInfoReturnValues{$InfoType}}; + + if ( $ReturnType eq 'SQLUINTEGER bitmask'|| $ReturnType eq 'SQLINTEGER bitmask') { + my @a = (); + for my $k ( sort { $a <=> $b } keys %h ) { + push @a, $h{$k} if $Value & $k; + } + return wantarray ? @a : join(' ', @a ); + } + else { + return $h{$Value} ||'?'; + } +} + +1; |