home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / xampp / xampp-perl-addon-1.4.9-installer.exe / ADO.pm < prev    next >
Encoding:
Text File  |  2004-01-11  |  70.9 KB  |  2,112 lines
  1. {
  2.   package DBD::ADO;
  3.  
  4.   use strict;
  5.   use DBI();
  6.   use Win32::OLE();
  7.   use vars qw($VERSION $drh $err $errstr $state);
  8.  
  9.   $VERSION = '2.84';
  10.  
  11.   $drh    = undef;  # holds driver handle once initialised
  12.   $err    = 0;      # The $DBI::err value
  13.   $errstr = '';
  14.   $state  = '';
  15.  
  16.   sub driver {
  17.     return $drh if $drh;
  18.     my($class, $attr) = @_;
  19.     $class .= "::dr";
  20.     ($drh) = DBI::_new_drh( $class, {
  21.       'Name'                 => 'ADO',
  22.       'Version'         => $VERSION,
  23.       'Attribution' => 'DBD ADO for Win32 by Tim Bunce, Phlip, Thomas Lowery and Steffen Goeldner',
  24.             'Err'                 => \$DBD::ADO::err,
  25.             'Errstr'             => \$DBD::ADO::errstr,
  26.             'State'             => \$DBD::ADO::state,
  27.     });
  28.     if ( $DBI::VERSION >= 1.37 ) {
  29.       DBD::ADO::db->install_method('ado_open_schema');
  30.     }
  31.     return $drh;
  32.   }
  33.  
  34.   sub errors {
  35.     my $Conn = shift;
  36.     my @Err  = ();
  37.  
  38.     my $lastError = Win32::OLE->LastError;
  39.     if ( $lastError ) {
  40.       push @Err, "\nLasterror : " . ( $lastError+0 ) . "\n$lastError";
  41.       $DBD::ADO::err = int( sprintf('%f', $lastError+0 ) );
  42.     } else {
  43.       $DBD::ADO::err    = 0;
  44.       $DBD::ADO::errstr = undef;
  45.       $DBD::ADO::state  = undef;
  46.     }
  47.     return unless ref $Conn;
  48.     my $Errors = $Conn->Errors;
  49.  
  50.     if ( $Errors && $Errors->Count ) {
  51.       for my $err ( Win32::OLE::in( $Errors ) ) {
  52.         next if $err->Number == 0;  # Skip warnings
  53.         push @Err, '';
  54.         push @Err, sprintf "\t%11s : %s", $_, $err->$_ ||'' for qw(
  55.           Description HelpContext HelpFile NativeError Number Source SQLState);
  56.         push @Err, '    ';
  57.         $DBD::ADO::state = $err->SQLState;
  58.       }
  59.       $Errors->Clear;
  60.     }
  61.     join "\n", @Err;
  62.   }
  63.  
  64. }
  65.  
  66. { package DBD::ADO::dr; # ====== DRIVER ======
  67.  
  68.   use strict;
  69.   use DBI();
  70.   use Win32::OLE();
  71.  
  72.   $DBD::ADO::dr::imp_data_size = 0;
  73.  
  74.     use constant DBPROPVAL_TC_ALL                    => 8;
  75.     use constant DBPROPVAL_TC_DDL_IGNORE    => 4;
  76.     use constant DBPROPVAL_TC_DDL_COMMIT    => 2;
  77.     use constant DBPROPVAL_TC_DML                    => 1;
  78.     use constant DBPROPVAL_TC_NONE                => 0;
  79.  
  80.   sub data_sources {
  81.     my($drh, $attr) = @_;
  82.     my @list = ();
  83.     $drh->{ado_data_sources} ||= eval { require Local::DBD::ADO::DSN } || [];
  84.     $drh->trace_msg("    !! $@", 7 ) if $@;
  85.     for my $h ( @{$drh->{ado_data_sources}} ) {
  86.       my @a = map "$_=$h->{$_}", sort keys %$h;
  87.       push @list, 'dbi:ADO:' . join(';', @a );
  88.     }
  89.     return @list;
  90.   }
  91.  
  92.     sub connect {
  93.         my ($drh, $dsn, $user, $auth) = @_;
  94.  
  95.         local $Win32::OLE::Warn = 0;
  96.         my $conn = Win32::OLE->new('ADODB.Connection');
  97.         my $lastError = Win32::OLE->LastError;
  98.         return $drh->set_err( $DBD::ADO::err || -1,
  99.             "Can't create 'ADODB.Connection': $lastError")
  100.             if $lastError;
  101.  
  102.         my ($outer, $this) = DBI::_new_dbh($drh, {
  103.             Name => $dsn,
  104.             User => $user,
  105.             AutoCommit => 1,
  106.             Warn => 0,
  107.             LongReadLen => 0,
  108.             LongTruncOk => 0,
  109.         },
  110.         {
  111.           ado_conn                        => undef
  112.         , ado_cursortype            => undef
  113.         , ado_commandtimeout    => undef
  114.         , Attributes                    => undef
  115.         , CommandTimeout            => undef
  116.         , ConnectionString        => undef
  117.         , ConnectionTimeout        => undef
  118.         , CursorLocation            => undef
  119.         , DefaultDatabase            => undef
  120.         , IsolationLevel            => undef
  121.         , Mode                                => undef
  122.         , Provider                        => undef
  123.         , State                                => undef
  124.         , Version                            => undef
  125.         });
  126.  
  127.         # Get the default value;
  128.         $this->{ado_commandtimeout} = $conn->{CommandTimeout};
  129.         # Refer the connection commandtimeout to the handler.
  130.         $conn->{CommandTimeout} = \$this->{ado_commandtimeout};
  131.  
  132.         $this->{ado_conn} = $conn;
  133.         $drh->trace_msg( "->ADO Connection: " . ref $this->{ado_conn} .
  134.             " Connection: " . ref $conn . "\n", 1);
  135.         ##  ODBC rule - Null is not the same as an empty password...
  136.         $auth = '' if !defined $auth;
  137.  
  138.         my (@cdsn,$cdsn);
  139.         # Run thru the dsn extracting connection options.
  140.         if( $dsn =~ /;/ ) {
  141.             for my $s (split( /;/, $dsn)) {
  142.                 if ($s =~ m/^(.*?)=(.*)$/s){
  143.                     my ($c, $v) = ($1, $2);
  144.                     # Only include the options defined.
  145.                     if( $conn->{$c} ) {
  146.                         $this->STORE($c, $v);
  147.                         $drh->trace_msg("->> Storing $c $v\n", 1);
  148.                         next;
  149.                     }
  150.                 }
  151.                 push(@cdsn, $s );
  152.             }
  153.         } else {
  154.             if($dsn =~ m/^(.*?)=(.*)$/s) {
  155.                 $outer->STORE( "ConnectionString", $dsn );
  156.             } else {
  157.                 $outer->STORE( "ConnectionString", "DSN=$dsn" );
  158.                 push(@cdsn, $dsn);
  159.             }
  160.         }
  161.  
  162.         $cdsn = join( ";", @cdsn );
  163.         $drh->trace_msg("->> Open ADO connection using $cdsn\n", 1);
  164.         $conn->Open ($cdsn, $user, $auth);
  165.         $lastError = DBD::ADO::errors($conn);
  166.         return $drh->set_err( $DBD::ADO::err || -1,
  167.             "Can't connect to '$dsn': $lastError")
  168.             if $lastError;
  169.  
  170.         # Determine if the provider supports transaction.
  171.         my $auto = 0;
  172.         eval {
  173.             $auto = $conn->Properties->{qq{Transaction DDL}}->{Value};
  174.         if ( $auto eq &DBPROPVAL_TC_ALL ) {
  175.             $this->{ado_provider_support_auto_commit} = $auto;
  176.             $this->{ado_provider_auto_commit_comments} =
  177.                 qq{Transactions can contain DDL and DML statements in any order.};
  178.         } elsif ( $auto eq &DBPROPVAL_TC_DDL_COMMIT ) {
  179.             $this->{ado_provider_support_auto_commit} = $auto;
  180.             $this->{ado_provider_auto_commit_comments} =
  181.                 qq{Transactions can contain DML statements.  DDL statements within a transaction cause the transaction to be committed.};
  182.         } elsif ( $auto eq &DBPROPVAL_TC_DDL_IGNORE )  {
  183.             $this->{ado_provider_support_auto_commit} = $auto;
  184.             $this->{ado_provider_auto_commit_comments} =
  185.                 qq{Transactions can only contain DML statements.  DDL statements within a transaction are ignored.};
  186.         } elsif ( $auto eq &DBPROPVAL_TC_DML )  {
  187.             $this->{ado_provider_support_auto_commit} = $auto;
  188.             $this->{ado_provider_auto_commit_comments} =
  189.                 qq{Transactions can only contain Data Manipulation (DML) statements.  DDL statements within a trnsaction cause an error.};
  190.         } else {
  191.             $this->{ado_provider_support_auto_commit} = $auto;
  192.             $this->{ado_provider_auto_commit_comments} =
  193.                 qq{Transactions are not supported.};
  194.         }
  195.         };
  196.         if ($@) {
  197.             warn "No transactions";
  198.             $this->{ado_provider_support_auto_commit} = 0;
  199.             $this->{ado_provider_auto_commit_comments} =
  200.                 qq{Transactions are not supported.};
  201.             $auto = 0;
  202.             $lastError = DBD::ADO::errors($conn);
  203.         }
  204.  
  205.         $drh->trace_msg( "->> Transaction support: $auto " .
  206.             $this->{ado_provider_auto_commit_comments} . "\n",1);
  207.  
  208.     $outer->STORE('Active', 1 );
  209.         return $outer;
  210.     }
  211.  
  212.     sub disconnect_all { }
  213.  
  214.     sub DESTROY {
  215.         my $self = shift;
  216.         my $conn = $self->{ado_conn};
  217.         my $auto = $self->{AutoCommit};
  218.         if (defined $conn) {
  219.             $conn->RollbackTrans unless $auto
  220.                 and not $self->{ado_provider_support_auto_commit};
  221.         my $lastError = DBD::ADO::errors($conn);
  222.         return $self->set_err( $DBD::ADO::err || -1, "Failed to Destory: $lastError")
  223.             if $lastError;
  224.         }
  225.     }
  226.  
  227. } # ====== DRIVER ======
  228.  
  229. # names of adSchemaProviderTypes fields
  230. # my $ado_info = [qw{
  231. #     TYPE_NAME DATA_TYPE COLUMN_SIZE LITERAL_PREFIX
  232. #     LITERAL_SUFFIX CREATE_PARAMS IS_NULLABLE CASE_SENSITIVE
  233. #     SEARCHABLE UNSIGNED_ATTRIBUTE FIXED_PREC_SCALE AUTO_UNIQUE_VALUE
  234. #     LOCAL_TYPE_NAME MINIMUM_SCALE MAXIMUM_SCALE GUID TYPELIB
  235. #     VERSION IS_LONG BEST_MATCH IS_FIXEDLENGTH
  236. # }];
  237. # check IS_NULLABLE => NULLABLE (only difference with DBI/ISO field names)
  238. # Information returned from the provider about the schema.  The column names
  239. # are different then the DBI spec.
  240. my $ado_schematables = [
  241.     qw{ TABLE_CAT TABLE_SCHEM TABLE_NAME TABLE_TYPE REMARKS
  242.         TABLE_GUID TABLE_PROPID DATE_CREATED DATE_MODIFIED
  243.     } ];
  244.  
  245. my $ado_dbi_schematables = [
  246.     qw{ TABLE_CAT TABLE_SCHEM TABLE_NAME TABLE_TYPE REMARKS }
  247.     ];
  248.  
  249. my $sch_dbi_to_ado = {
  250.     TABLE_CAT     => 'TABLE_CATALOG',
  251.     TABLE_SCHEM   => 'TABLE_SCHEMA',
  252.     TABLE_NAME    => 'TABLE_NAME',
  253.     TABLE_TYPE    => 'TABLE_TYPE',
  254.     REMARKS       => 'DESCRIPTION',
  255.     TABLE_GUID    => 'TABLE_GUID',
  256.     TABLE_PROPID  => 'TABLE_PROPID',
  257.     DATE_CREATED  => 'DATE_CREATED',
  258.     DATE_MODIFIED => 'DATE_MODIFIED',
  259.     };
  260.  
  261.  
  262. { package DBD::ADO::db; # ====== DATABASE ======
  263.  
  264.   use strict;
  265.   use DBI();
  266.   use Win32::OLE();
  267.   use Win32::OLE::Variant();
  268.   use DBD::ADO::TypeInfo();
  269.   use DBD::ADO::Const();
  270.   use Carp();
  271.  
  272.   $DBD::ADO::db::imp_data_size = 0;
  273.  
  274.   my $ado_consts = DBD::ADO::Const->Enums;
  275.  
  276.   sub ping {
  277.     my ( $dbh ) = @_;
  278.     my $conn = $dbh->{ado_conn};
  279.  
  280.     defined $conn && $conn->State & $ado_consts->{ObjectStateEnum}{adStateOpen};
  281.   }
  282.  
  283.     sub disconnect {
  284.         my ($dbh) = @_;
  285.         my $conn = $dbh->{ado_conn};
  286.         local $Win32::OLE::Warn = 0;
  287.         $dbh->trace_msg('    -- State: ' . $conn->State . "\n");
  288.         if ( $conn->State & $ado_consts->{ObjectStateEnum}{adStateOpen} ) {
  289.             # Change the connection attribute so Commit/Rollback
  290.             # does not start another transaction.
  291.             $conn->{Attributes} = 0;
  292.             my $lastError = DBD::ADO::errors($conn);
  293.             return $dbh->set_err( $DBD::ADO::err || -1,
  294.                 "Failed setting CommitRetaining: $lastError") #-2147168242
  295.             if $lastError && $lastError !~ m/-2147168242/;
  296.             $dbh->trace_msg('    -- Modified ADO Connection Attributes: ' . $conn->{Attributes} . "\n");
  297.  
  298.             my $auto = $dbh->{AutoCommit};
  299.             $dbh->trace_msg("    -- AutoCommit: $auto, Provider Support: $dbh->{ado_provider_support_auto_commit}, Comments: $dbh->{ado_provider_auto_commit_comments}\n");
  300.             $conn->RollbackTrans unless $auto and
  301.                 not $dbh->{ado_provider_support_auto_commit};
  302.             $lastError = DBD::ADO::errors($conn);
  303.             return $dbh->set_err( $DBD::ADO::err || -1,
  304.                 "Failed to execute rollback: $lastError")
  305.             if $lastError && $lastError !~ m/-2147168242/;
  306.             # Provider error about txn not started. Ignore message, clear error codes.
  307.             DBD::ADO::errors($conn) if $lastError && $lastError =~ m/-2147168242/;
  308.  
  309.             $conn->Close;
  310.         }
  311.         $conn = undef;
  312.         $dbh->{ado_conn} = undef;
  313.         $dbh->SUPER::STORE('Active', 0 );
  314.         return 1;
  315.     }
  316.  
  317.     # Commit to the database.
  318.     sub commit {
  319.         my($dbh) = @_;
  320.  
  321.         return warn "Commit ineffective when AutoCommit is on\n"
  322.             if $dbh->{AutoCommit} and $dbh->FETCH('Warn');
  323.         return Carp::carp $dbh->{ado_provider_auto_commit_comments}
  324.             unless $dbh->{ado_provider_support_auto_commit};
  325.     if ( $dbh->FETCH('BegunWork') ) {
  326.       $dbh->{AutoCommit} = 1;
  327.       $dbh->SUPER::STORE('BegunWork', 0 );
  328.       my $conn = $dbh->{ado_conn};
  329.       $conn->{Attributes} = 0;
  330.       my $lastError = DBD::ADO::errors($conn);
  331.       return $dbh->set_err( $DBD::ADO::err || -1,
  332.         "Failed setting CommitRetaining: $lastError")
  333.       if $lastError;
  334.     }
  335.         if (exists $dbh->{ado_conn} and defined $dbh->{ado_conn} and
  336.             $dbh->{ado_conn}->{State} == $ado_consts->{ObjectStateEnum}{adStateOpen}) {
  337.             $dbh->{ado_conn}->CommitTrans;
  338.             my $lastError = DBD::ADO::errors($dbh->{ado_conn});
  339.             return $dbh->set_err( $DBD::ADO::err || -1, "Failed to CommitTrans: $lastError")
  340.                 if $lastError;
  341.         }
  342.     return 1;
  343.     }
  344.  
  345.     # Rollback to the database.
  346.     sub rollback {
  347.         my($dbh) = @_;
  348.  
  349.         return Carp::carp "Rollback ineffective when AutoCommit is on\n"
  350.             if $dbh->{AutoCommit} and $dbh->FETCH('Warn');
  351.         return Carp::carp $dbh->{ado_provider_auto_commit_comments}
  352.             unless $dbh->{ado_provider_support_auto_commit};
  353.     if ( $dbh->FETCH('BegunWork') ) {
  354.       $dbh->{AutoCommit} = 1;
  355.       $dbh->SUPER::STORE('BegunWork', 0 );
  356.       my $conn = $dbh->{ado_conn};
  357.       $conn->{Attributes} = 0;
  358.       my $lastError = DBD::ADO::errors($conn);
  359.       return $dbh->set_err( $DBD::ADO::err || -1,
  360.         "Failed setting CommitRetaining: $lastError")
  361.       if $lastError;
  362.     }
  363.         if (exists $dbh->{ado_conn} and defined $dbh->{ado_conn} and
  364.             $dbh->{ado_conn}->{State} & $ado_consts->{ObjectStateEnum}{adStateOpen}) {
  365.             $dbh->{ado_conn}->RollbackTrans;
  366.             my $lastError = DBD::ADO::errors($dbh->{ado_conn});
  367.             return $dbh->set_err( $DBD::ADO::err || -1,
  368.                 "Failed to Rollback Trans: $lastError")
  369.             if $lastError;
  370.         }
  371.     return 1;
  372.     }
  373.  
  374.     # The create parm methods builds a usable type statement for constructing
  375.     # tables.
  376.     # XXX This method may not stay ...
  377.     sub create_parm {
  378.         my ($dbh, $type) = @_;
  379.  
  380.         my $field = undef;
  381.  
  382.         if ($type) {
  383.         $field = $type->{TYPE_NAME};
  384.             if (defined $type->{CREATE_PARAMS}) {
  385.             $field .= qq{(} . $type->{COLUMN_SIZE} . qq{)}
  386.                 if ($type->{CREATE_PARAMS} =~ /LENGTH/i);
  387.             $field .= qq{(} . $type->{COLUMN_SIZE} . qq{, 0)}
  388.                 if ($type->{CREATE_PARAMS} =~ /PRECISION,SCALE/i);
  389.             }
  390.         }
  391.         return $field;
  392.     }
  393.  
  394.     sub prepare {
  395.         my($dbh, $statement, $attribs) = @_;
  396.         my $conn = $dbh->{ado_conn};
  397.  
  398.         my $comm = Win32::OLE->new('ADODB.Command');
  399.         my $lastError = DBD::ADO::errors($conn);
  400.         return $dbh->set_err( $DBD::ADO::err || -1,
  401.             "Can't create 'object ADODB.Command': $lastError")
  402.         if $lastError;
  403.  
  404.         $comm->{ActiveConnection} = $conn;
  405.         $lastError = DBD::ADO::errors($conn);
  406.         return $dbh->set_err( $DBD::ADO::err || -1,
  407.             "Unable to set ActiveConnection 'ADODB.Command': $lastError")
  408.         if $lastError;
  409.  
  410.         $comm->{CommandText} = $statement;
  411.         $lastError = DBD::ADO::errors($conn);
  412.         return $dbh->set_err( $DBD::ADO::err || -1,
  413.             "Unable to set CommandText 'ADODB.Command': $lastError")
  414.         if $lastError;
  415.  
  416.         my $ct = $attribs->{CommandType}? $attribs->{CommandType}: "adCmdText";
  417.         $comm->{CommandType} = $ado_consts->{CommandTypeEnum}{$ct};
  418.         $lastError = DBD::ADO::errors($conn);
  419.         return $dbh->set_err( $DBD::ADO::err || -1,
  420.             "Unable to set command type 'ADODB.Command': $lastError")
  421.         if $lastError;
  422.  
  423.         my ($outer, $sth) = $dbh->DBI::_new_sth( {
  424.           Statement        => $statement
  425.         , NAME                => undef
  426.         , TYPE                => undef
  427.         , PRECISION        => undef
  428.         , SCALE                => undef
  429.         , NULLABLE        => undef
  430.         , CursorName    => undef
  431.         , RowsInCache    => 0
  432.         , ado_type        => undef
  433.         }, {
  434.           ado_comm            => $comm
  435.         , ado_attribs        => $attribs
  436.         , ado_commandtimeout => undef
  437.         , ado_conn            => $conn
  438.         , ado_cursortype => undef
  439.         , ado_dbh                => $dbh
  440.         , ado_fields        => undef
  441.         , ado_params        => []
  442.         , ado_refresh        => 1
  443.         , ado_rownum        => -1
  444.         , ado_rows            => -1
  445.         , ado_rowset        => undef
  446.         , ado_usecmd        => undef
  447.         , ado_users            => undef
  448.         });
  449.  
  450.         $outer->STORE( LongReadLen    => 0 );
  451.         $outer->STORE( LongTruncOk    => 0 );
  452.  
  453.         if (exists $attribs->{RowsInCache}) {
  454.             $outer->STORE( RowsInCache    => $attribs->{RowsInCache} );
  455.         } else {
  456.             $outer->STORE( RowsInCache    => 0 );
  457.         }
  458.  
  459.         $sth->{ado_comm}        = $comm;
  460.         $sth->{ado_conn}        = $conn;
  461.         $sth->{ado_dbh}            = $dbh;
  462.         $sth->{ado_fields}    = undef;
  463.         $sth->{ado_params}    = [];
  464.         $sth->{ado_refresh}    = 1;
  465.         $sth->{ado_rownum}    = -1;
  466.         $sth->{ado_rows}        = -1;
  467.         $sth->{ado_rowset}    = undef;
  468.         $sth->{ado_attribs}    = $attribs;
  469.         $sth->{ado_usecmd}    = undef;
  470.         $sth->{ado_users}        = undef;
  471.  
  472.         # Inherit from dbh.
  473.         $sth->{ado_commandtimeout} =
  474.             defined $dbh->{ado_commandtimeout} ?  $dbh->{ado_commandtimeout} :
  475.                 $conn->{CommandTimeout};
  476.  
  477.         $comm->{CommandTimeout} = $sth->{ado_commandtimeout};
  478.         $lastError = DBD::ADO::errors($conn);
  479.         return $dbh->set_err( $DBD::ADO::err || -1,
  480.             "Unable to set CommandText 'ADODB.Command': $lastError")
  481.         if $lastError;
  482.  
  483.         $sth->{ado_cursortype} =
  484.             defined $dbh->{ado_cursortype} ?  $dbh->{ado_cursortype} : undef;
  485.  
  486.         # Set overrides for and attributes.
  487.         foreach my $key (grep { /^ado_/ } keys %$attribs) {
  488.             $sth->trace_msg("    -- Attribute: $key => $attribs->{$key}\n");
  489.             if ( exists $sth->{$key} ) {
  490.                 $sth->{$key} = $attribs->{$key};
  491.             } else {
  492.                     warn "Unknown attribute $key\n";
  493.             }
  494.         }
  495.  
  496.     my $Cnt;
  497.     if ( $sth->{ado_refresh} == 1 ) {
  498.       # Refresh() is - among other things - useful to detect syntax errors.
  499.       # The eval block is used because Refresh() may not be supported (but
  500.       # no such case is known).
  501.       # Buggy drivers, e.g. FoxPro, may leave the Parameters collection
  502.       # empty, without returning an error. Then _refresh() is defered until
  503.       # bind_param() is called.
  504.       eval {
  505.         local $Win32::OLE::Warn = 0;
  506.         $comm->Parameters->Refresh;
  507.         $Cnt = $comm->Parameters->Count;
  508.       };
  509.       $lastError = DBD::ADO::errors( $conn );
  510.       if ( $lastError ) {
  511.         $dbh->trace_msg("    !! Refresh error: $lastError\n", 4 );
  512.         $sth->{ado_refresh} = 2;
  513.       }
  514.     }
  515.     if ($sth->{ado_refresh} == 2 ) {
  516.       $Cnt = DBD::ADO::st::_refresh( $outer );
  517.     }
  518.     if ( $Cnt ) {
  519.       # Describe the Parameters:
  520.       for my $p ( Win32::OLE::in( $comm->Parameters ) ) {
  521.         my @p = map "$_ => $p->{$_}", qw(Name Type Direction Size);
  522.         $dbh->trace_msg("    -- Parameter: @p\n", 4 );
  523.       }
  524.       $outer->STORE('NUM_OF_PARAMS' => $Cnt );
  525.     }
  526.     $comm->{Prepared} = 1;
  527.     $lastError = DBD::ADO::errors( $conn );
  528.     return $dbh->set_err( $DBD::ADO::err || -1,
  529.       "Unable to set prepared 'ADODB.Command': $lastError")
  530.       if $lastError;
  531.  
  532.     return $outer;
  533.   } # prepare
  534.     #
  535.     # Creates a Statement handle from a row set.
  536.     #
  537.     sub _rs_sth_prepare {
  538.         my($dbh, $rs, $attribs) = @_;
  539.  
  540.         $dbh->trace_msg( "-> _rs_sth_prepare: Create statement handle from RecordSet\n" );
  541.  
  542.         my $conn = $dbh->FETCH("ado_conn");
  543.         my $ado_fields = [ Win32::OLE::in($rs->Fields) ];
  544.  
  545.         my ($outer, $sth) = DBI::_new_sth($dbh, {
  546.           NAME                => [ map { $_->Name } @$ado_fields ]
  547.         , TYPE                => [ map { $_->Type } @$ado_fields ]
  548.         , PRECISION        => [ map { $_->Precision } @$ado_fields ]
  549.         , SCALE                => [ map { $_->NumericScale } @$ado_fields ]
  550.         , NULLABLE        => [ map { $_->Attributes & $ado_consts->{FieldAttributeEnum}{adFldMayBeNull}? 1 : 0 } @$ado_fields ]
  551.         , Statement        => $rs->Source
  552.         , LongReadLen    => 0
  553.         , LongTruncOk    => 0
  554.         , CursorName    => undef
  555.         , RowsInCache    => 0
  556.         , ado_type        => [ map { $_->Type } @$ado_fields ]
  557.         }, {
  558.           ado_attribs    => $attribs
  559.         , ado_comm        => $conn
  560.         , ado_conn         => $conn
  561.         , ado_dbh            => $dbh
  562.         , ado_fields    => $ado_fields
  563.         , ado_params    => []
  564.         , ado_refresh    => 0
  565.         , ado_rownum    => 0
  566.         , ado_rows        => -1
  567.         , ado_rowset    => $rs
  568.         });
  569.  
  570.         $sth->{ado_comm}        = $conn;
  571.         $sth->{ado_conn}        = $conn;
  572.         $sth->{ado_dbh}            = $dbh;
  573.         $sth->{ado_fields}    = $ado_fields;
  574.         $sth->{ado_params}    = [];
  575.         $sth->{ado_refresh}    = 0;
  576.         $sth->{ado_rownum}    = 0;
  577.         $sth->{ado_rows}        = -1;
  578.         $sth->{ado_rowset}    = $rs;
  579.         $sth->{ado_attribs}    = $attribs;
  580.  
  581.         $sth->STORE( NUM_OF_FIELDS    => scalar @$ado_fields );
  582.         $sth->STORE( Active                    => 1);
  583.  
  584.         $dbh->trace_msg( "<- _rs_sth_prepare: Create statement handle from RecordSet\n" );
  585.         return $outer;
  586.     } # _rs_sth_prepare
  587.  
  588.     sub get_info {
  589.         my($dbh, $info_type) = @_;
  590.         $info_type = int($info_type);
  591.         require DBD::ADO::GetInfo;
  592.         if ( exists $DBD::ADO::GetInfo::odbc2ado{$info_type} ) {
  593.             return $dbh->{ado_conn}->Properties->{$DBD::ADO::GetInfo::odbc2ado{$info_type}}{Value};
  594.         }
  595.         my $v = $DBD::ADO::GetInfo::info{$info_type};
  596.         if (ref $v eq 'CODE') {
  597.             my $get_info_cache = $dbh->{dbd_get_info_cache} ||= {};
  598.             return $get_info_cache->{$info_type} if exists $get_info_cache->{$info_type};
  599.             $v = $v->($dbh);
  600.             return $$v if ref $v eq 'SCALAR';  # don't cache!
  601.             $get_info_cache->{$info_type} = $v;
  602.         }
  603.         return $v;
  604.     }
  605.  
  606.     sub ado_schema_dbinfo_literal {
  607.         my($dbh, $literal_name) = @_;
  608.         my $cache = $dbh->{ado_schema_dbinfo_literal_cache};
  609.         unless ( defined $cache ) {
  610.             $dbh->trace_msg("-> ado_schema_dbinfo_literal: filling cache\n");
  611.             $cache = $dbh->{ado_schema_dbinfo_literal_cache} = {};
  612.             my $sth = $dbh->func('adSchemaDBInfoLiterals','OpenSchema');
  613.             while ( my $row = $sth->fetch ) {
  614.                 $cache->{$row->[0]} = [ @$row ];
  615.             }
  616.         }
  617.         my $row = $cache->{$literal_name};
  618.         return $row->[1] unless wantarray;  # literal value
  619.         return @$row;
  620.     }
  621.  
  622.     sub table_info {
  623.         my($dbh, $attribs) = @_;
  624.         $attribs = {
  625.             TABLE_CAT   => $_[1],
  626.             TABLE_SCHEM => $_[2],
  627.             TABLE_NAME  => $_[3],
  628.             TABLE_TYPE  => $_[4],
  629.         } unless ref $attribs eq 'HASH';
  630.  
  631.         $dbh->trace_msg( "-> table_info\n" );
  632.  
  633.         my @criteria = (undef); # ADO needs at least one element in the criteria array!
  634.  
  635.         my $tmpCursorLocation = $dbh->{ado_conn}->{CursorLocation};
  636.         $dbh->{ado_conn}->{CursorLocation} = $ado_consts->{CursorLocationEnum}{adUseClient};
  637.  
  638.         my @tp;
  639.         my $field_names = $attribs->{ADO_Columns}
  640.             ?  $ado_schematables : $ado_dbi_schematables;
  641.         my $oRec;
  642.  
  643.         #
  644.         # If the value of $catalog is '%' and $schema and $table name are empty
  645.         # strings, the result set contains a list of catalog names.
  646.         #
  647.         if ( (defined $attribs->{TABLE_CAT}   and $attribs->{TABLE_CAT}   eq '%'  )
  648.             && (defined $attribs->{TABLE_SCHEM} and $attribs->{TABLE_SCHEM} eq '' )
  649.             && (defined $attribs->{TABLE_NAME}  and $attribs->{TABLE_NAME}  eq '') ) { # Rule 19a
  650.             # This is the easy way to determine catalog support.
  651.             eval {
  652.                 local $Win32::OLE::Warn = 0;
  653.                 $oRec = $dbh->{ado_conn}->OpenSchema($ado_consts->{SchemaEnum}{adSchemaCatalogs});
  654.                 my $lastError = DBD::ADO::errors($dbh->{ado_conn});
  655.                 $lastError = undef if $lastError =~ m/0x80020007/;
  656.                 die "Died on:\n$lastError" if $lastError;
  657.             };
  658.             $dbh->trace_msg( "->    Eval of adSchemaCatalogs died for $@\n" )
  659.                 if $@;
  660.             $dbh->trace_msg( "->    Rule 19a\n" );
  661.             if ( $oRec ) {
  662.                 $dbh->trace_msg( "->    Rule 19a, record set defined\n" );
  663.                 while(! $oRec->{EOF}) {
  664.                     push @tp, [ $oRec->Fields(0)->{Value}, undef, undef, undef, undef ];
  665.                     $oRec->MoveNext;
  666.                 }
  667.             }
  668.             else {
  669.                 # The provider does not support the adSchemaCatalogs.  Let's attempt
  670.                 # to still return a list of catalogs.
  671.                 $dbh->trace_msg( "->    Rule 19a, record set undefined\n" );
  672.                 my $csth = $dbh->table_info( { Trim_Catalog => 1 } );
  673.                 if ($csth) {
  674.           my $ref = {};
  675.           my $Undef = 0;  # for 'undef' hash keys (which mutate to '')
  676.           while ( my $Row = $csth->fetch ) {
  677.             defined $Row->[0] ? $ref->{$Row->[0]} = 1 : $Undef = 1;
  678.           }
  679.           push @tp, [ undef, undef, undef, undef, undef ] if $Undef;
  680.           push @tp, [    $_, undef, undef, undef, undef ] for sort keys %$ref;
  681.                 }
  682.                 else {
  683.                     push @tp, [ undef, undef, undef, undef, undef ];
  684.                 }
  685.             }
  686.         }
  687.         #
  688.         # If the value of $schema is '%' and $catalog and $table are empty
  689.         # strings, the result set contains a list of schema names.
  690.         #
  691.         elsif ( (defined $attribs->{TABLE_CAT} and $attribs->{TABLE_CAT}   eq '')
  692.                  && (defined $attribs->{TABLE_SCHEM} and $attribs->{TABLE_SCHEM} eq '%')
  693.                  && (defined $attribs->{TABLE_NAME} and $attribs->{TABLE_NAME}  eq '') ) { # Rule 19b
  694.             eval {
  695.                 local $Win32::OLE::Warn = 0;
  696.                 $oRec = $dbh->{ado_conn}->OpenSchema($ado_consts->{SchemaEnum}{adSchemaSchemata});
  697.                 my $lastError = DBD::ADO::errors($dbh->{ado_conn});
  698.                 $lastError = undef if $lastError =~ m/0x80020007/;
  699.                 die "Died on:\n$lastError" if $lastError;
  700.             };
  701.             $dbh->trace_msg( "->    Eval of adSchemaSchemata died for $@\n" )
  702.                 if $@;
  703.             $dbh->trace_msg( "->    Rule 19b\n" );
  704.             if ( $oRec ) {
  705.                 $dbh->trace_msg( "->    Rule 19b, record set defined\n" );
  706.                 while(! $oRec->{EOF}) {
  707.                     push @tp, [ $oRec->Fields(0)->{Value}, $oRec->Fields(1)->{Value}, undef, undef, undef ];
  708.                     $oRec->MoveNext;
  709.                 }
  710.             }
  711.             else {
  712.                 # The provider does not support the adSchemaSchemata.  Let's attempt
  713.                 # to still return a list of schemas.
  714.                 $dbh->trace_msg( "->    Rule 19b, record set undefined\n" );
  715.                 my $csth = $dbh->table_info( { Trim_Catalog => 1 } );
  716.                 if ($csth) {
  717.           my $ref = {};
  718.           my $Undef = 0;  # for 'undef' hash keys (which mutate to '')
  719.           while ( my $Row = $csth->fetch ) {
  720.             defined $Row->[0] ? $ref->{$Row->[0]} = 1 : $Undef = 1;
  721.           }
  722.           push @tp, [ undef, undef, undef, undef, undef ] if $Undef;
  723.           push @tp, [ undef,    $_, undef, undef, undef ] for sort keys %$ref;
  724.                 }
  725.                 else {
  726.                     push @tp, [ undef, undef, undef, undef, undef ];
  727.                 }
  728.             }
  729.         }
  730.         #
  731.         # If the value of $type is '%' and $catalog, $schema, and $table are all
  732.         # empty strings, the result set contains a list of table types.
  733.         #
  734.         elsif ( (defined $attribs->{TABLE_CAT} and $attribs->{TABLE_CAT}   eq '')
  735.                  && (defined $attribs->{TABLE_SCHEM} and $attribs->{TABLE_SCHEM} eq '')
  736.                  && (defined $attribs->{TABLE_NAME} and $attribs->{TABLE_NAME}  eq '')
  737.                  && (defined $attribs->{TABLE_TYPE} and $attribs->{TABLE_TYPE}  eq '%')
  738.                  ) { # Rule 19c
  739.             $dbh->trace_msg( "->    Rule 19c\n" );
  740.             my @TableTypes = ('ALIAS','TABLE','SYNONYM','SYSTEM TABLE','VIEW','GLOBAL TEMPORARY','LOCAL TEMPORARY','SYSTEM VIEW'); # XXX
  741.             for ( sort @TableTypes ) {
  742.                 push @tp, [ undef, undef, undef, $_, undef ];
  743.             }
  744.         }
  745.         else {
  746.             @criteria = (undef); # ADO needs at least one element in the criteria array!
  747.             for (my $i=0; $i<@$ado_dbi_schematables; $i++) {
  748.                 my $field = $ado_dbi_schematables->[$i];
  749.                 if (exists $attribs->{$field}) {
  750.                     $criteria[$i] = $attribs->{$field};
  751.                 }
  752.             }
  753.  
  754.             eval {
  755.                 local $Win32::OLE::Warn = 0;
  756.                 $oRec = $dbh->{ado_conn}->OpenSchema($ado_consts->{SchemaEnum}{adSchemaTables}, \@criteria);
  757.                 my $lastError = DBD::ADO::errors($dbh->{ado_conn});
  758.                 $lastError = undef if $lastError =~ m/0x80020007/;
  759.                 die "Died on:\n$lastError" if $lastError;
  760.             };
  761.             $dbh->trace_msg( "->    Eval of adSchemaTables died for $@\n" )
  762.                 if $@;
  763.             if ($oRec) {
  764.  
  765.                 if (exists $attribs->{Filter}) {
  766.                     $oRec->{Filter} = $attribs->{Filter};
  767.                 }
  768.  
  769.                 while(! $oRec->{EOF}) {
  770.                     my @out = map { $oRec->Fields($_)->{Value} }
  771.                         map { $sch_dbi_to_ado->{$_} } @$field_names;
  772.                     # Jan Dubois jand@activestate.com addition to handle changes
  773.                     # in Win32::OLE return of Variant types of data.
  774.                     foreach ( @out ) {
  775.                         $_ = $_->As( Win32::OLE::Variant::VT_BSTR() )
  776.                             if ( defined $_ ) && ( UNIVERSAL::isa( $_, 'Win32::OLE::Variant') );
  777.                     }
  778.                     if ($attribs->{Trim_Catalog}) {
  779.                         $out[0] =~ s/^(.*\\)// if defined $out[0];  # removes leading
  780.                         $out[0] =~ s/(\..*)$// if defined $out[0];  # removes file extension
  781.                     }
  782.                     push( @tp, \@out );
  783.                     $oRec->MoveNext;
  784.                 }
  785.             }
  786.             else {
  787.                 push @tp, [ undef, undef, undef, undef, undef ];
  788.             }
  789.         }
  790.  
  791.         $oRec->Close if $oRec;
  792.         $oRec = undef;
  793.         $dbh->{ado_conn}->{CursorLocation} = $tmpCursorLocation;
  794.  
  795.         my $statement = "adSchemaTables";
  796.         my $sponge = DBI->connect("dbi:Sponge:","","",{ RaiseError => 1 });
  797.         my $sth = $sponge->prepare($statement,
  798.             { rows=> \@tp, NAME=> $field_names });
  799.  
  800.         $dbh->trace_msg( "<- table_info\n" );
  801.         return $sth;
  802.     }
  803.  
  804.     sub column_info {
  805.         my( $dbh, @Criteria ) = @_;
  806.         my $Criteria = \@Criteria if @Criteria;
  807.         my $QueryType = 'adSchemaColumns';
  808.         my @Rows;
  809.         my $conn = $dbh->{ado_conn};
  810.         my $tmpCursorLocation = $conn->{CursorLocation};
  811.         $conn->{CursorLocation} = $ado_consts->{CursorLocationEnum}{adUseClient};
  812.  
  813.         my $RecSet = $conn->OpenSchema( $ado_consts->{SchemaEnum}{$QueryType}, $Criteria );
  814.         my $lastError = DBD::ADO::errors($conn);
  815.         return $dbh->set_err( $DBD::ADO::err || -1,
  816.             "Error occurred with call to OpenSchema ($QueryType): $lastError")
  817.             if $lastError;
  818.  
  819.         $RecSet->{Sort} = 'TABLE_CATALOG, TABLE_SCHEMA, TABLE_NAME, ORDINAL_POSITION';
  820.         $lastError = DBD::ADO::errors($conn);
  821.         return $dbh->set_err( $DBD::ADO::err || -1,
  822.             "Error occurred defining sort order : $lastError")
  823.             if $lastError;
  824.  
  825.         while ( ! $RecSet->{EOF} ) {
  826.             my $AdoType    = $RecSet->Fields('DATA_TYPE'   )->{Value};
  827.             my $ColFlags   = $RecSet->Fields('COLUMN_FLAGS')->{Value};
  828.             my $IsLong     = ( $ColFlags & $ado_consts->{FieldAttributeEnum}{adFldLong } ) ? 1 : 0;
  829.             my $IsFixed    = ( $ColFlags & $ado_consts->{FieldAttributeEnum}{adFldFixed} ) ? 1 : 0;
  830.             my @SqlType    = DBD::ADO::TypeInfo::ado2dbi( $AdoType, $IsFixed, $IsLong );
  831.             my $IsNullable = $RecSet->Fields('IS_NULLABLE')->{Value} ? 'YES' : 'NO';
  832.             my $ColSize    = $RecSet->Fields('NUMERIC_PRECISION'       )->{Value}
  833.                           || $RecSet->Fields('CHARACTER_MAXIMUM_LENGTH')->{Value}
  834.                                         || 0;  # Default value to stop warnings ???
  835.             my $TypeName;
  836.             my $ado_tis    = DBD::ADO::db::_ado_get_type_info_for( $dbh, $AdoType, $IsFixed, $IsLong );
  837.             $dbh->trace_msg('  *** ' . $RecSet->Fields('COLUMN_NAME')->{Value} . "($ColSize): $AdoType, $IsFixed, $IsLong\n", 3 );
  838.             # find the first type which has a large enough COLUMN_SIZE:
  839.             for my $ti ( sort { $a->{COLUMN_SIZE} <=> $b->{COLUMN_SIZE} } @$ado_tis ) {
  840.                 $dbh->trace_msg("    * => $ti->{TYPE_NAME}($ti->{COLUMN_SIZE})\n", 3 );
  841.                 if ( $ti->{COLUMN_SIZE} >= $ColSize ) {
  842.                     $TypeName = $ti->{TYPE_NAME};
  843.                     last ;
  844.                 }
  845.             }
  846.             # unless $TypeName: Standard SQL type name???
  847.  
  848.             my @Fields;
  849.             $Fields[ 0] = $RecSet->Fields('TABLE_CATALOG'           )->{Value}; # TABLE_CAT
  850.             $Fields[ 1] = $RecSet->Fields('TABLE_SCHEMA'            )->{Value}; # TABLE_SCHEM
  851.             $Fields[ 2] = $RecSet->Fields('TABLE_NAME'              )->{Value}; # TABLE_NAME
  852.             $Fields[ 3] = $RecSet->Fields('COLUMN_NAME'             )->{Value}; # COLUMN_NAME
  853.             $Fields[ 4] = $SqlType[0]                                         ; # DATA_TYPE !!!
  854.             $Fields[ 5] = $TypeName                                           ; # TYPE_NAME !!!
  855.             $Fields[ 6] = $ColSize                                            ; # COLUMN_SIZE !!! MAX for *LONG*
  856.             $Fields[ 7] = $RecSet->Fields('CHARACTER_OCTET_LENGTH'  )->{Value}; # BUFFER_LENGTH !!! MAX for *LONG*, ... (e.g. num)
  857.             $Fields[ 8] = $RecSet->Fields('NUMERIC_SCALE'           )->{Value}; # DECIMAL_DIGITS ???
  858.             $Fields[ 9] = undef                                               ; # NUM_PREC_RADIX !!!
  859.             $Fields[10] = $RecSet->Fields('IS_NULLABLE'             )->{Value}; # NULLABLE !!!
  860.             $Fields[11] = $RecSet->Fields('DESCRIPTION'             )->{Value}; # REMARKS
  861.             $Fields[12] = $RecSet->Fields('COLUMN_DEFAULT'          )->{Value}; # COLUMN_DEF
  862.             $Fields[13] = $SqlType[1]                                         ; # SQL_DATA_TYPE !!!
  863.             $Fields[14] = $SqlType[2]                                         ; # SQL_DATETIME_SUB !!!
  864.             $Fields[15] = $RecSet->Fields('CHARACTER_OCTET_LENGTH'  )->{Value}; # CHAR_OCTET_LENGTH !!! MAX for *LONG*
  865.             $Fields[16] = $RecSet->Fields('ORDINAL_POSITION'        )->{Value}; # ORDINAL_POSITION
  866.             $Fields[17] = $IsNullable                                         ; # IS_NULLABLE !!!
  867.  
  868.             push( @Rows, \@Fields );
  869.             $RecSet->MoveNext;
  870.         }
  871.         $RecSet->Close; undef $RecSet;
  872.         $conn->{CursorLocation} = $tmpCursorLocation;
  873.  
  874.         DBI->connect('dbi:Sponge:','','', { RaiseError => 1 })->prepare(
  875.             $QueryType, { rows => \@Rows
  876.             , NAME => [ qw( TABLE_CAT TABLE_SCHEM TABLE_NAME COLUMN_NAME DATA_TYPE TYPE_NAME COLUMN_SIZE BUFFER_LENGTH DECIMAL_DIGITS NUM_PREC_RADIX NULLABLE REMARKS COLUMN_DEF SQL_DATA_TYPE SQL_DATETIME_SUB CHAR_OCTET_LENGTH ORDINAL_POSITION IS_NULLABLE ) ]
  877.             , TYPE => [            12,         12,        12,         12,        5,       12,          4,            4,             5,             5,       5,     12,        12,            5,               5,                4,               4,         12   ]
  878.         });
  879.     }
  880.  
  881.     sub primary_key_info {
  882.         my( $dbh, @Criteria ) = @_;
  883.         my $QueryType = 'adSchemaPrimaryKeys';
  884.         my @Rows;
  885.         my $conn = $dbh->{ado_conn};
  886.         my $tmpCursorLocation = $conn->{CursorLocation};
  887.         $conn->{CursorLocation} = $ado_consts->{CursorLocationEnum}{adUseClient};
  888.  
  889.         my $RecSet = $conn->OpenSchema( $ado_consts->{SchemaEnum}{$QueryType}, \@Criteria );
  890.         my $lastError = DBD::ADO::errors($conn);
  891.         return $dbh->set_err( $DBD::ADO::err || -1,
  892.             "Error occurred with call to OpenSchema ($QueryType): $lastError")
  893.         if $lastError;
  894.  
  895.         $RecSet->{Sort} = 'TABLE_CATALOG, TABLE_SCHEMA, TABLE_NAME, ORDINAL';
  896.         $lastError = DBD::ADO::errors($conn);
  897.         return $dbh->set_err( $DBD::ADO::err || -1,
  898.             "Error occurred defining sort order : $lastError")
  899.         if $lastError;
  900.  
  901.         while ( ! $RecSet->{EOF} ) {
  902.             my $ado_fields = [ Win32::OLE::in($RecSet->Fields) ];
  903.             my @Fields = (map { $_->{Value} } Win32::OLE::in($RecSet->Fields) ) [ 0,1,2,3,6,7 ];
  904.             push( @Rows, \@Fields );
  905.             $RecSet->MoveNext;
  906.         }
  907.  
  908.             $RecSet->Close; undef $RecSet;
  909.             $conn->{CursorLocation} = $tmpCursorLocation;
  910.  
  911.             DBI->connect('dbi:Sponge:','','', { RaiseError => 1 })->prepare(
  912.                 $QueryType, { rows => \@Rows
  913.                 , NAME => [ qw( TABLE_CAT TABLE_SCHEM TABLE_NAME COLUMN_NAME KEY_SEQ PK_NAME ) ]
  914.                 , TYPE => [            12,         12,        12,         12,      5,     12   ]
  915.             });
  916.     }
  917.  
  918.  
  919.     sub foreign_key_info {
  920.         my( $dbh, @Criteria ) = @_;
  921.         my $Criteria = \@Criteria if @Criteria;
  922.         my $QueryType = 'adSchemaForeignKeys';
  923.         my $RefActions = {
  924.             'CASCADE'     => 0,
  925.             'RESTRICT'    => 1,
  926.             'SET NULL'    => 2,
  927.             'NO ACTION'   => 3,
  928.             'SET DEFAULT' => 4,
  929.         };
  930.         my @Rows;
  931.         my $conn = $dbh->{ado_conn};
  932.         my $tmpCursorLocation = $conn->{CursorLocation};
  933.         $conn->{CursorLocation} = $ado_consts->{CursorLocationEnum}{adUseClient};
  934.  
  935.         my $RecSet = $conn->OpenSchema( $ado_consts->{SchemaEnum}{$QueryType}, $Criteria );
  936.         my $lastError = DBD::ADO::errors($conn);
  937.         return $dbh->set_err( $DBD::ADO::err || -1,
  938.             "Error occurred with call to OpenSchema ($QueryType): $lastError")
  939.             if $lastError;
  940.  
  941.         $RecSet->{Sort} = 'PK_TABLE_CATALOG, PK_TABLE_SCHEMA, PK_TABLE_NAME, FK_TABLE_CATALOG, FK_TABLE_SCHEMA, FK_TABLE_NAME';
  942.         $lastError = DBD::ADO::errors($conn);
  943.         return $dbh->set_err( $DBD::ADO::err || -1,
  944.             "Error occurred defining sort order : $lastError")
  945.             if $lastError;
  946.  
  947.         while ( ! $RecSet->{EOF} ) {
  948.             my @Fields = (map { $_->{Value} } Win32::OLE::in($RecSet->Fields) ) [ 0..3,6..9,12..14,16,15,17 ];
  949.             $Fields[ 9]  = $RefActions->{$Fields[ 9]};
  950.             $Fields[10]  = $RefActions->{$Fields[10]};
  951.             $Fields[13] += 4 if $Fields[13];
  952.             push( @Rows, \@Fields );
  953.             $RecSet->MoveNext;
  954.         }
  955.         $RecSet->Close; undef $RecSet;
  956.         $conn->{CursorLocation} = $tmpCursorLocation;
  957.  
  958.         DBI->connect('dbi:Sponge:','','', { RaiseError => 1 })->prepare(
  959.             $QueryType, { rows => \@Rows
  960.             , NAME => [ qw( PKTABLE_CAT PKTABLE_SCHEM PKTABLE_NAME PKCOLUMN_NAME FKTABLE_CAT FKTABLE_SCHEM FKTABLE_NAME FKCOLUMN_NAME KEY_SEQ UPDATE_RULE DELETE_RULE FK_NAME PK_NAME DEFERRABILITY ) ]
  961.             , TYPE => [              12,           12,          12,           12,         12,           12,          12,           12,      5,          5,          5,     12,     12,            5   ]
  962.         });
  963.     }
  964.  
  965.         sub type_info_all {
  966.         my ($dbh) = @_;
  967.         my $names = {
  968.       TYPE_NAME        => 0,
  969.       DATA_TYPE        => 1,
  970.       COLUMN_SIZE        => 2,
  971.       LITERAL_PREFIX    => 3,
  972.       LITERAL_SUFFIX    => 4,
  973.       CREATE_PARAMS        => 5,
  974.       NULLABLE        => 6,
  975.       CASE_SENSITIVE    => 7,
  976.       SEARCHABLE        => 8,
  977.       UNSIGNED_ATTRIBUTE    => 9,
  978.       FIXED_PREC_SCALE    =>10,
  979.       AUTO_UNIQUE_VALUE    =>11,
  980.       LOCAL_TYPE_NAME    =>12,
  981.       MINIMUM_SCALE        =>13,
  982.       MAXIMUM_SCALE        =>14,
  983.     };
  984.         # Based on the values from the current provider.
  985.         my @myti;
  986.         # my $sth = $dbh->func('adSchemaProviderTypes','OpenSchema');
  987.  
  988.         # If the type information is previously obtained, use it.
  989.         unless( $dbh->{ado_all_types_supported} ) {
  990.             &_determine_type_support or
  991.                 Carp::croak "_determine_type_support failed: ", $dbh->{errstr};
  992.         }
  993.  
  994.         my $ops = ado_open_schema( $dbh,'adSchemaProviderTypes');
  995.         Carp::croak "ops undefined!" unless defined $ops;
  996.  
  997.         my $ado_info        = [ @{$ops->{NAME}} ];
  998.         $ops->finish; $ops = undef;
  999.  
  1000.         my $sponge = DBI->connect("dbi:Sponge:","","",{ PrintError => 1, RaiseError => 1 });
  1001.         Carp::croak "sponge return undefined: $DBI::errstr" unless defined $sponge;
  1002.  
  1003.         my $sth = $sponge->prepare("adSchemaProviderTypes", {
  1004.             rows=>   [ @{$dbh->{ado_all_types_supported}} ] , NAME=> $ado_info,
  1005.         });
  1006.  
  1007.         while(my $row = $sth->fetchrow_hashref) {
  1008.             my @tyinfo;
  1009.             # Only add items from the above names list.  When
  1010.             # this list explans, the code 'should' still work.
  1011.             for my $n (keys %{$names}){
  1012.                 $tyinfo[ $names->{$n} ] = $row->{$n} || '';
  1013.             }
  1014.             push( @myti, \@tyinfo );
  1015.         }
  1016.  
  1017.         $sth->finish; $sth = undef;
  1018.         $sponge->disconnect; $sponge = undef;
  1019.  
  1020.         my $ti = [ $names, @myti ];
  1021.  
  1022.         return $ti;
  1023.     }
  1024.  
  1025.  
  1026.     # This is a function, not a method.
  1027.     sub _determine_type_support {
  1028.         my ($dbh) = @_;
  1029.         die 'dbh undefined' unless $dbh;
  1030.  
  1031.         $dbh->trace_msg("    -> _determine_type_support\n");
  1032.  
  1033.         my $conn = $dbh->{ado_conn};
  1034.         my $Enums = DBD::ADO::Const->Enums;
  1035.         my $Dt = $Enums->{DataTypeEnum};
  1036.  
  1037.     # Attempt to convert data types from ODBC to ADO.
  1038.     my %local_types = (
  1039.       DBI::SQL_BINARY()        => [
  1040.         $Dt->{adBinary}
  1041.       , $Dt->{adVarBinary}
  1042.       ]
  1043.     , DBI::SQL_BIT()           => [ $Dt->{adBoolean}]
  1044.     , DBI::SQL_CHAR()          => [
  1045.         $Dt->{adChar}
  1046.       , $Dt->{adVarChar}
  1047.       , $Dt->{adWChar}
  1048.       , $Dt->{adVarWChar}
  1049.       ]
  1050.     , DBI::SQL_DATE()          => [
  1051.         $Dt->{adDBTimeStamp}
  1052.       , $Dt->{adDate}
  1053.       ]
  1054.     , DBI::SQL_DECIMAL()       => [ $Dt->{adNumeric} ]
  1055.     , DBI::SQL_DOUBLE()        => [ $Dt->{adDouble} ]
  1056.     , DBI::SQL_FLOAT()         => [ $Dt->{adSingle} ]
  1057.     , DBI::SQL_INTEGER()       => [ $Dt->{adInteger} ]
  1058.     , DBI::SQL_LONGVARBINARY() => [
  1059.         $Dt->{adLongVarBinary}
  1060.       , $Dt->{adVarBinary}
  1061.       , $Dt->{adBinary}
  1062.       ]
  1063.     , DBI::SQL_LONGVARCHAR()   => [
  1064.         $Dt->{adLongVarChar}
  1065.       , $Dt->{adVarChar}
  1066.       , $Dt->{adChar}
  1067.       , $Dt->{adLongVarWChar}
  1068.       , $Dt->{adVarWChar}
  1069.       , $Dt->{adWChar}
  1070.       ]
  1071.     , DBI::SQL_NUMERIC()       => [ $Dt->{adNumeric} ]
  1072.     , DBI::SQL_REAL()          => [ $Dt->{adSingle} ]
  1073.     , DBI::SQL_SMALLINT()      => [ $Dt->{adSmallInt} ]
  1074.     , DBI::SQL_TIMESTAMP()     => [
  1075.         $Dt->{adDBTime}
  1076.       , $Dt->{adDBTimeStamp}
  1077.       , $Dt->{adDate}
  1078.       ]
  1079.     , DBI::SQL_TINYINT()       => [ $Dt->{adUnsignedTinyInt} ]
  1080.     , DBI::SQL_VARBINARY()     => [
  1081.         $Dt->{adVarBinary}
  1082.       , $Dt->{adLongVarBinary}
  1083.       , $Dt->{adBinary}
  1084.       ]
  1085.     , DBI::SQL_VARCHAR()       => [
  1086.         $Dt->{adVarChar}
  1087.       , $Dt->{adChar}
  1088.       , $Dt->{adVarWChar}
  1089.       , $Dt->{adWChar}
  1090.       ]
  1091.     , DBI::SQL_WCHAR()         => [
  1092.         $Dt->{adWChar}
  1093.       , $Dt->{adVarWChar}
  1094.       , $Dt->{adLongVarWChar}
  1095.       ]
  1096.     , DBI::SQL_WVARCHAR()      => [
  1097.         $Dt->{adVarWChar}
  1098.       , $Dt->{adLongVarWChar}
  1099.       , $Dt->{adWChar}
  1100.       ]
  1101.     , DBI::SQL_WLONGVARCHAR()  => [
  1102.         $Dt->{adLongVarWChar}
  1103.       , $Dt->{adVarWChar}
  1104.       , $Dt->{adWChar}
  1105.       , $Dt->{adLongVarChar}
  1106.       , $Dt->{adVarChar}
  1107.       , $Dt->{adChar}
  1108.       ]
  1109.     );
  1110.  
  1111.     my @sql_types = (
  1112.       DBI::SQL_BINARY()
  1113.     , DBI::SQL_BIT()
  1114.     , DBI::SQL_CHAR()
  1115.     , DBI::SQL_DATE()
  1116.     , DBI::SQL_DECIMAL()
  1117.     , DBI::SQL_DOUBLE()
  1118.     , DBI::SQL_FLOAT()
  1119.     , DBI::SQL_INTEGER()
  1120.     , DBI::SQL_LONGVARBINARY()
  1121.     , DBI::SQL_LONGVARCHAR()
  1122.     , DBI::SQL_NUMERIC()
  1123.     , DBI::SQL_REAL()
  1124.     , DBI::SQL_SMALLINT()
  1125.     , DBI::SQL_TIMESTAMP()
  1126.     , DBI::SQL_TINYINT()
  1127.     , DBI::SQL_VARBINARY()
  1128.     , DBI::SQL_VARCHAR()
  1129.     , DBI::SQL_WCHAR()
  1130.     , DBI::SQL_WVARCHAR()
  1131.     , DBI::SQL_WLONGVARCHAR()
  1132.     );
  1133.  
  1134.         # Get the Provider Types attributes.
  1135.         my @sort_rows;
  1136.         my %ct;
  1137.         my $rs = $conn->OpenSchema( $ado_consts->{SchemaEnum}{adSchemaProviderTypes} );
  1138.         my $lastError = DBD::ADO::errors($conn);
  1139.         return $dbh->set_err( $DBD::ADO::err || -1,
  1140.             "OpenSchema error: $lastError")
  1141.             if $lastError;
  1142.  
  1143.         my $ado_fields = [ Win32::OLE::in( $rs->Fields ) ];
  1144.         my $ado_info   = [ map { $_->Name } @$ado_fields ];
  1145.  
  1146.         while ( !$rs->{EOF} ) {
  1147.             # Sort by row
  1148.             my $type_name = $rs->{TYPE_NAME}->{Value};
  1149.             my $def;
  1150.             push ( @sort_rows,  $def = join(' '
  1151.             , $rs->{DATA_TYPE}->Value
  1152.             , $rs->{BEST_MATCH}->Value || 0
  1153.             , $rs->{IS_LONG}->Value || 0
  1154.             , $rs->{IS_FIXEDLENGTH}->Value || 0
  1155.             , $rs->{COLUMN_SIZE}->Value
  1156.             , $rs->{TYPE_NAME}->Value
  1157.             ));
  1158.             $dbh->trace_msg("    -- data type $type_name: $def\n");
  1159.             @{$ct{$type_name}} = map { $rs->{$_}->Value || '' } @$ado_info;
  1160.             $rs->MoveNext;
  1161.         }
  1162.         $rs->Close if $rs &&
  1163.             $rs->State & $ado_consts->{ObjectStateEnum}{adStateOpen};
  1164.         $rs = undef;
  1165.         for my $t ( @sql_types ) {
  1166.             # Attempt to work with LONG text fields.
  1167.             # However for a LONG field, the order by ... isn't always the best pick.
  1168.             # Loop through the rows looking for something with a IS LONG mark.
  1169.             my $alt = join('|', @{$local_types{$t}} );
  1170.             my $re;
  1171.             if    ( $t == DBI::SQL_LONGVARCHAR()   ) { $re = qr{^($alt)\s\d\s1\s0\s}  }
  1172.             elsif ( $t == DBI::SQL_LONGVARBINARY() ) { $re = qr{^($alt)\s\d\s1\s0\s}  }
  1173.             elsif ( $t == DBI::SQL_VARBINARY()     ) { $re = qr{^($alt)\s1\s\d\s0\s}  }
  1174.             elsif ( $t == DBI::SQL_VARCHAR()       ) { $re = qr{^($alt)\s[01]\s0\s0\s}}
  1175.             elsif ( $t == DBI::SQL_WVARCHAR()      ) { $re = qr{^($alt)\s[01]\s0\s0\s}}
  1176.             elsif ( $t == DBI::SQL_WLONGVARCHAR()  ) { $re = qr{^($alt)\s\d\s1\s0\s}  }
  1177.             elsif ( $t == DBI::SQL_CHAR()          ) { $re = qr{^($alt)\s\d\s0\s1\s}  }
  1178.             elsif ( $t == DBI::SQL_WCHAR()         ) { $re = qr{^($alt)\s\d\s0\s1\s}  }
  1179.             else                                     { $re = qr{^($alt)\s\d\s\d\s}    }
  1180.  
  1181.             for ( sort { $b cmp $a } grep { /$re/ } @sort_rows ) {
  1182.                 my ($cc) = m/\d+\s+(\D\w?.*)$/;
  1183.                 Carp::carp "$cc does not exist in hash\n" unless exists $ct{$cc};
  1184.                 my @rec = @{$ct{$cc}};
  1185.                 $dbh->trace_msg("Changing type $rec[1] -> $t : @rec\n");
  1186.                 $rec[1] = $t;
  1187.                 push @{$dbh->{ado_all_types_supported}}, \@rec;
  1188.             }
  1189.         }
  1190.         $dbh->trace_msg("    <- _determine_type_support\n");
  1191.         return \@{$dbh->{ado_all_types_supported}};
  1192.     }
  1193.  
  1194.     sub _ado_get_type_info_for {
  1195.         my ($dbh, $AdoType, $IsFixed, $IsLong ) = @_;
  1196.  
  1197.         unless( $dbh->{ado_type_info_hash} ) {
  1198.             my $sth = $dbh->func('adSchemaProviderTypes','OpenSchema');
  1199.             while ( my $r = $sth->fetchrow_hashref ) {
  1200.                 push @{$dbh->{ado_type_info_hash}{$r->{DATA_TYPE}}{$r->{IS_FIXEDLENGTH}}{$r->{IS_LONG}}}, $r;
  1201.             }
  1202.         }
  1203.         $dbh->{ado_type_info_hash}{$AdoType}{$IsFixed}{$IsLong} || [];
  1204.     }
  1205.  
  1206.  
  1207.   sub ado_open_schema {
  1208.     my ($dbh, $var, @crit) = @_;
  1209.  
  1210.     unless ( exists $ado_consts->{SchemaEnum}{$var} ) {
  1211.       return $dbh->set_err( $DBD::ADO::err || -1,
  1212.         "OpenSchema called with unknown parameter: $var");
  1213.     }
  1214.     my $crit = \@crit if @crit;  # XXX: o.k.?
  1215.     my $conn = $dbh->{ado_conn};
  1216.     my $rs   = $conn->OpenSchema( $ado_consts->{SchemaEnum}{$var}, $crit );
  1217.     my $lastError = DBD::ADO::errors($conn);
  1218.     return $dbh->set_err( $DBD::ADO::err || -1,
  1219.       "OpenSchema error: $lastError")
  1220.     if $lastError;
  1221.  
  1222.     return _rs_sth_prepare( $dbh, $rs );
  1223.   }
  1224.  
  1225.   *OpenSchema = \&ado_open_schema;
  1226.  
  1227.  
  1228.     sub FETCH {
  1229.         my ($dbh, $attrib) = @_;
  1230.         # If the attribute contains ado_, return the value.
  1231.         $dbh->trace_msg( "->Fetch: $attrib\n", 3);
  1232.         my $value;
  1233.         if ( exists $dbh->{$attrib} ) {
  1234.             return $dbh->{$attrib};
  1235.         } else {
  1236.             eval {
  1237.                 $attrib =~ s/^ado_//;
  1238.                 local $Win32::OLE::Warn = 0;
  1239.                 $value = $dbh->{ado_conn}->{$attrib};
  1240.                 my $lastError = DBD::ADO::errors($dbh->{ado_conn});
  1241.                 $lastError = undef if $lastError =~ m/0x80020007/;
  1242.                 die "Died on:\n$lastError" if $lastError;
  1243.             };
  1244.         }
  1245.         return $value unless $@;
  1246.         # else pass up to DBI to handle
  1247.         return $dbh->SUPER::FETCH($attrib);
  1248.         # return $dbh->DBD::_::db::FETCH($attrib);
  1249.     }
  1250.  
  1251.     sub STORE {
  1252.         my ($dbh, $attrib, $value) = @_;
  1253.         # Patch from Simon Oliver
  1254.         $dbh->trace_msg( "-> Store: " . ($attrib||'undef') .
  1255.             " " . ($value||'undef') . "\n", 3);
  1256.         # Handle a request to change the AutoCommit value.
  1257.         # If the service provider supports Transaction,
  1258.         # then allow AutoCommit off.
  1259.         if ($attrib eq 'Warn' ) {
  1260.             $Win32::OLE::Warn = $value;
  1261.         }
  1262.         if ($attrib eq 'AutoCommit') {
  1263.             # Return the value is auto commit is not support and
  1264.             # value is not zero.  Handles defaults.
  1265.             return $value if $value
  1266.                 and not $dbh->{ado_provider_support_auto_commit};
  1267.             # Cause the application to die, user attempting to
  1268.             # change the auto commit value.
  1269.             Carp::croak
  1270.                 qq{Provider does not support auto commit: },
  1271.                 $dbh->{ado_provider_auto_commit_comments},
  1272.                 qq{\n}
  1273.             unless $dbh->{ado_provider_support_auto_commit};
  1274.             return $dbh->{AutoCommit} = _auto_commit($dbh, $value);
  1275.         }
  1276.         # If the attribute contains ado_, return the value.
  1277.         # Determine if this is one our expected parameters.
  1278.         # If the attribute is all lower case, then it is a driver
  1279.         # defined value.  If mixed case, then it is a ADO defined value.
  1280.         if ($attrib =~ m/^ado_/ || exists $dbh->{$attrib}) {
  1281.             return $dbh->{$attrib} = $value;
  1282.         } else {
  1283.             unless( $attrib =~ /PrintError|RaiseError/) {
  1284.             eval {
  1285.                 local $Win32::OLE::Warn = 0;
  1286.                 $dbh->{ado_conn}->{$attrib} = $value;
  1287.                 my $lastError = DBD::ADO::errors($dbh->{ado_conn});
  1288.                 die $lastError if $lastError;
  1289.             };
  1290.             Carp::carp $@ if $@ and $dbh->FETCH('Warn');
  1291.             return $value unless $@;
  1292.             }
  1293.         }
  1294.         return $dbh->SUPER::STORE($attrib, $value);
  1295.         # return $dbh->DBD::_::db::STORE($attrib, $value);
  1296.     }
  1297.  
  1298.   sub _auto_commit {
  1299.     my ( $dbh, $value ) = @_;
  1300.  
  1301.     my $cv = $dbh->FETCH('AutoCommit') || 0;
  1302.  
  1303.     if ( !$cv && $value ) { # Current off, turn on
  1304.       my $conn = $dbh->{ado_conn};
  1305.       $conn->{Attributes} = 0;
  1306.       my $lastError = DBD::ADO::errors($conn);
  1307.       return $dbh->set_err( $DBD::ADO::err || -1,
  1308.         "Failed setting CommitRetaining: $lastError")
  1309.       if $lastError;
  1310.       $dbh->commit;
  1311.       return 1;
  1312.     } elsif ( $cv && !$value ) {
  1313.       my $conn = $dbh->{ado_conn};
  1314.       $conn->{Attributes} = $ado_consts->{XactAttributeEnum}{adXactCommitRetaining}
  1315.                           | $ado_consts->{XactAttributeEnum}{adXactAbortRetaining};
  1316.       my $lastError = DBD::ADO::errors($conn);
  1317.       return $dbh->set_err( $DBD::ADO::err || -1,
  1318.         "Failed setting CommitRetaining: $lastError")
  1319.       if $lastError;
  1320.       $conn->BeginTrans;
  1321.       $lastError = DBD::ADO::errors($conn);
  1322.       return $dbh->set_err( $DBD::ADO::err || -1,
  1323.         "Begin Transaction Failed: $lastError")
  1324.         if $lastError;
  1325.       return 0;
  1326.     }
  1327.     return $cv;  # Didn't change the value.
  1328.   }
  1329.  
  1330.   sub DESTROY {
  1331.     my ($dbh) = @_;
  1332.     $dbh->disconnect if $dbh->FETCH('Active');
  1333.     return;
  1334.   }
  1335.  
  1336. } # ======= Database Handle ========
  1337.  
  1338. { package DBD::ADO::st; # ====== STATEMENT ======
  1339.  
  1340.   use strict;
  1341.   use Win32::OLE();
  1342.   use Win32::OLE::Variant();
  1343.   use DBD::ADO::TypeInfo();
  1344.   use DBD::ADO::Const();
  1345.  
  1346.   $DBD::ADO::st::imp_data_size = 0;
  1347.  
  1348.     use constant NOT_SUPPORTED => '-2147217839';
  1349.     use constant EXCEPTION_OCC => '-2147352567';
  1350.  
  1351.   my $ado_consts = DBD::ADO::Const->Enums;
  1352.  
  1353.   my $VT_I4_BYREF = Win32::OLE::Variant::VT_I4() | Win32::OLE::Variant::VT_BYREF();
  1354.  
  1355.     sub blob_read {
  1356.         my ($sth, $cnum, $offset, $lng, $attr) = @_;
  1357.         my $fld = @{$sth->{ado_fields}}[$cnum];
  1358.         my $str = "";
  1359.         if ($fld->Attributes & $ado_consts->{FieldAttributeEnum}{adFldLong}) {
  1360.             $str = $fld->GetChunk( $lng );
  1361.         } else {
  1362.             my $s = $fld->Value;
  1363.             $str = substr($s, $offset, $lng);
  1364.         }
  1365.         return( (defined($str) and length($str))? $str: "" );
  1366.     }
  1367.  
  1368.   # Determine the number of parameters, if Refresh fails.
  1369.   sub _params
  1370.   {
  1371.     my $sql = shift;
  1372.     use Text::ParseWords;
  1373.     $^W = 0;
  1374.     $sql =~ s/\n/ /;
  1375.     my $rtn = join( " ", grep { m/\?/ }
  1376.       grep { ! m/^['"].*\?/ } "ewords('\s+', 1, $sql));
  1377.     my $cnt = ($rtn =~ tr /?//) || 0;
  1378.     return $cnt;
  1379.   }
  1380.  
  1381.   sub _refresh {
  1382.     my ( $sth ) = @_;
  1383.     $sth->trace_msg("    -> _refresh\n", 5 );
  1384.     my $conn = $sth->{ado_conn};
  1385.     my $comm = $sth->{ado_comm};
  1386.  
  1387.     my $Cnt = _params( $sth->FETCH('Statement') );
  1388.  
  1389.     for ( 0 .. $Cnt - 1 ) {
  1390.       my $Parameter = $comm->CreateParameter("$_",
  1391.         $ado_consts->{DataTypeEnum}{adVarChar},
  1392.         $ado_consts->{ParameterDirectionEnum}{adParamInput},
  1393.         1,
  1394.         "");
  1395.       my $lastError = DBD::ADO::errors( $conn );
  1396.       return $sth->set_err( $DBD::ADO::err || -1,
  1397.         "Unable to CreateParameter: $lastError") if $lastError;
  1398.  
  1399.       $comm->Parameters->Append( $Parameter );
  1400.       $lastError = DBD::ADO::errors( $conn );
  1401.       return $sth->set_err( $DBD::ADO::err || -1,
  1402.         "Append parameter failed : $lastError") if $lastError;
  1403.     }
  1404.     $sth->STORE('NUM_OF_PARAMS', $Cnt );
  1405.     $sth->trace_msg("    <- _refresh\n", 5 );
  1406.     return $Cnt;
  1407.   }
  1408.  
  1409.   sub bind_param {
  1410.     my ($sth, $pNum, $val, $attr) = @_;
  1411.     my $conn = $sth->{ado_conn};
  1412.     my $comm = $sth->{ado_comm};
  1413.  
  1414.     my $param_cnt = $sth->FETCH('NUM_OF_PARAMS') || _refresh( $sth );
  1415.  
  1416.     return $sth->set_err( $DBD::ADO::err || -1,
  1417.       "Bind Parameter $pNum outside current range of $param_cnt.")
  1418.     if $pNum > $param_cnt || $pNum < 1;
  1419.  
  1420.     $sth->{ado_params}->[$pNum-1] = $val;
  1421.  
  1422.     my $i = $comm->Parameters->Item( $pNum - 1 );
  1423.  
  1424.     if ( defined $attr ) {
  1425.       if ( ref $attr ) {
  1426.         if ( exists $attr->{ado_type} ) {
  1427.           $i->{Type} = $attr->{ado_type};
  1428.         } elsif ( exists $attr->{TYPE} ) {
  1429.           $i->{Type} = $DBD::ADO::TypeInfo::dbi2ado->{$attr->{TYPE}};
  1430.         }
  1431.       } else {
  1432.         $i->{Type} = $DBD::ADO::TypeInfo::dbi2ado->{$attr};
  1433.       }
  1434.     }
  1435.     if ( defined $val ) {
  1436.       if ( $i->{Type} == $ado_consts->{DataTypeEnum}{adVarBinary} or
  1437.            $i->{Type} == $ado_consts->{DataTypeEnum}{adLongVarBinary}
  1438.       ) {
  1439.         # Deal with an image request.
  1440.         my $pic = Win32::OLE::Variant->new( Win32::OLE::Variant::VT_UI1() | Win32::OLE::Variant::VT_ARRAY(), 10 + length $val );  # $i->{Size}
  1441.         $pic->Put( $val );
  1442.         $i->{Value} = $pic;
  1443.         $sth->trace_msg("    -- Binary: $i->{Type} $i->{Size}\n");
  1444.       } else {
  1445.         $i->{Size}  = length $val;  # $val? length $val: $ado_type->[2];
  1446.         $i->{Value} = $val;         # $val if $val;
  1447.         $sth->trace_msg("    -- Type  : $i->{Type} $i->{Size}\n");
  1448.       }
  1449.     } else {
  1450.       $i->{Value} = Win32::OLE::Variant->new( Win32::OLE::Variant::VT_NULL() );
  1451.     }
  1452.     return 1;
  1453.   }
  1454.  
  1455.     sub execute {
  1456.         my ($sth, @bind_values) = @_;
  1457.         my $conn = $sth->{ado_conn};
  1458.         my $comm = $sth->{ado_comm};
  1459.         my $sql  = $sth->FETCH('Statement');
  1460.  
  1461.         # If a record set is currently defined, release the set.
  1462.         my $ors = $sth->{ado_rowset};
  1463.         if ( defined $ors ) {
  1464.             $ors->Close if $ors and
  1465.                 $ors->State & $ado_consts->{ObjectStateEnum}{adStateOpen};
  1466.             $sth->{ado_rowset} = undef;
  1467.             $ors = undef;
  1468.         }
  1469.  
  1470.     # If the application is excepting arguments, then process them here.
  1471.     for ( 1 .. @bind_values ) {
  1472.       $sth->bind_param( $_, $bind_values[$_-1] ) or return;
  1473.     }
  1474.  
  1475.         my $lastError;
  1476.  
  1477.         my $rs;
  1478.         my $p = $comm->Parameters;
  1479.         $lastError = DBD::ADO::errors($conn);
  1480.         return $sth->set_err( $DBD::ADO::err || -1,
  1481.             "Execute Parameters failed 'ADODB.Command': $lastError")
  1482.         if $lastError and $DBD::ADO::err ne NOT_SUPPORTED;
  1483.  
  1484.         my $not_supported = ( $DBD::ADO::err eq NOT_SUPPORTED ) || 0;
  1485.  
  1486.         $sth->trace_msg("    -- Not Supported flag: $not_supported\n", 5 );
  1487.  
  1488.         my $parm_cnt = 0;
  1489.         # Need to test if we can access the parameter attributes.
  1490.         {
  1491.             # Turn the OLE Warning Off for this test.
  1492.             local $Win32::OLE::Warn = 0;
  1493.             $parm_cnt = $p->{Count};
  1494.             $lastError = DBD::ADO::errors($conn);
  1495.             $not_supported = ( $DBD::ADO::err eq EXCEPTION_OCC ) || 0;
  1496.         }
  1497.  
  1498.         $sth->trace_msg("    -- Is the Parameter Object Supported? " . ($not_supported ? 'No' : 'Yes') . "\n", 5 );
  1499.  
  1500.         # Remember if the provider errored with a "not supported" message.
  1501.  
  1502.         # If the provider errored with not_supported above in the Parameters
  1503.         # methods, do not attempt to display anything about the object.  If we
  1504.         # it triggers warning message.
  1505.         unless ( $not_supported ) {
  1506.             $sth->trace_msg("    -- Parameter count: " . $p->{Count} . "\n", 5 );
  1507.             my $x = 0;
  1508.             while ( $x < $p->{Count} ) {
  1509.                 my $params = $sth->{ado_params};
  1510.                 $sth->trace_msg("    -- Parameter $x: " . ($p->Item($x)->{Value}||'undef') . "\n", 5 );
  1511.                 $sth->trace_msg("    -- Parameter $x: " . ($params->[$x]||'undef') . "\n", 5 );
  1512.                 $x++;
  1513.             }
  1514.         }
  1515.  
  1516.         # Return the affected number to rows.
  1517.         my $rows = Win32::OLE::Variant->new( $VT_I4_BYREF, 0 );
  1518.  
  1519.         # At this point a command is ready to execute.  To allow for different
  1520.         # type of cursors, I need to create a recordset object.
  1521.         # However, a RecordSet Open does not return affected rows.  So I need to
  1522.         # determine if a recordset open is needed, or a command execute.
  1523.  
  1524.         # print "usecmd "    , exists $sth->{ado_usecmd}               , defined $sth->{ado_usecmd}               , "\n";
  1525.         # print "CursorType ", exists $sth->{ado_attribs}->{CursorType}, defined $sth->{ado_attribs}->{CursorType}, "\n";
  1526.         # print "cursortype ", exists $sth->{ado_cursortype}           , defined $sth->{ado_cursortype}           , "\n";
  1527.         # print "users "     , exists $sth->{ado_users}                , defined $sth->{ado_users}                , "\n";
  1528.  
  1529.         my $UseRecordSet = (
  1530.             not  ( exists $sth->{ado_usecmd}                and defined $sth->{ado_usecmd} )
  1531.             && ( ( exists $sth->{ado_attribs}->{CursorType} and defined $sth->{ado_attribs}->{CursorType} )
  1532.               || ( exists $sth->{ado_cursortype}            and defined $sth->{ado_cursortype} )
  1533.               || ( exists $sth->{ado_users}                 and defined $sth->{ado_users} ) )
  1534.         );
  1535.  
  1536.         if ( $UseRecordSet ) {
  1537.             $rs = Win32::OLE->new('ADODB.RecordSet');
  1538.             $lastError = DBD::ADO::errors($conn);
  1539.             return $sth->set_err( $DBD::ADO::err || -1,
  1540.                 "Can't create 'object ADODB.RecordSet': $lastError")
  1541.             if $lastError;
  1542.  
  1543.             # Determine the the CursorType to use.  The default is adOpenForwardOnly.
  1544.             my $cursortype = $ado_consts->{CursorTypeEnum}{adOpenForwardOnly};
  1545.             if ( exists $sth->{ado_attribs}->{CursorType} ) {
  1546.                 my $type = $sth->{ado_attribs}->{CursorType};
  1547.                 if ( exists $ado_consts->{CursorTypeEnum}{$type} ) {
  1548.                     $sth->trace_msg("    -- Changing the cursor type to $type\n", 5 );
  1549.                     $cursortype = $ado_consts->{CursorTypeEnum}{$type};
  1550.                 } else {
  1551.                     warn "Attempting to use an invalid CursorType: $type : using default adOpenForwardOnly";
  1552.                 }
  1553.             }
  1554.  
  1555.             # Call to clear any previous error messages.
  1556.             $lastError = DBD::ADO::errors($conn);
  1557.  
  1558.             $sth->trace_msg("  -- Open record set using cursor type: $cursortype\n", 5 );
  1559.             $rs->Open( $comm, undef, $cursortype );
  1560.             $lastError = DBD::ADO::errors($conn);
  1561.             return $sth->set_err( $DBD::ADO::err || -1,
  1562.                     "Can't execute statement '$sql': $lastError")
  1563.             if $lastError;
  1564.         } else {
  1565.             # Execute the statement, get a recordset in return.
  1566.             $rs = $comm->Execute( $rows );
  1567.             $lastError = DBD::ADO::errors($conn);
  1568.             return $sth->set_err( $DBD::ADO::err || -1,
  1569.                     "Can't execute statement '$sql': $lastError")
  1570.             if $lastError;
  1571.         }
  1572.     $rows = $rows->Value;  # to make a DBD::Proxy client w/o Win32::OLE happy
  1573.     my $ado_fields = [];
  1574.     # some providers close the rs, e.g. after DROP TABLE
  1575.     if ( defined $rs and $rs->State ) {
  1576.           $ado_fields = [ Win32::OLE::in($rs->Fields) ];
  1577.           $lastError = DBD::ADO::errors($conn);
  1578.           return $sth->set_err( $DBD::ADO::err || -1,
  1579.                 "Can't enumerate fields: $lastError")
  1580.           if $lastError;
  1581.     }
  1582.     $sth->{ado_fields} = $ado_fields;
  1583.         my $num_of_fields = @$ado_fields;
  1584.  
  1585.         if ( $num_of_fields == 0 ) {  # assume non-select statement
  1586.             $sth->trace_msg("    -- no fields (non-select statement?)\n", 5 );
  1587.             # Clean up the record set that isn't used.
  1588.             if ( defined $rs and (ref $rs) =~ /Win32::OLE/) {
  1589.                 $rs->Close if $rs and
  1590.                     $rs->State & $ado_consts->{ObjectStateEnum}{adStateOpen};
  1591.             }
  1592.             $rs = undef;
  1593.             $sth->{ado_rows} = $rows;
  1594.             return $rows || '0E0';
  1595.         }
  1596.  
  1597.         # Current setting of RowsInCache?
  1598.         my $rowcache = $sth->FETCH('RowCacheSize');
  1599.         if ( defined $rowcache && $rowcache > 0 ) {
  1600.             my $currowcache = $rs->CacheSize;
  1601.             $sth->trace_msg("    -- changing the CacheSize using RowCacheSize: $rowcache\n", 5 );
  1602.             $rs->CacheSize( $rowcache ) unless $rowcache == $currowcache;
  1603.             $lastError = DBD::ADO::errors($conn);
  1604.             return $sth->set_err( $DBD::ADO::err || -1,
  1605.                 "Unable to change CacheSize to RowCacheSize : $rowcache : $lastError")
  1606.             if $lastError;
  1607.             warn "Changed CacheSize\n";
  1608.         }
  1609.  
  1610.         $sth->STORE('Active'        , 1 );
  1611.         $sth->STORE('CursorName'    , undef );
  1612.         $sth->STORE('Statement'     , $rs->Source );
  1613.         $sth->STORE('RowsInCache'   , $rs->CacheSize );
  1614.         $sth->STORE('NUM_OF_FIELDS' , $num_of_fields ) unless $num_of_fields == $sth->FETCH('NUM_OF_FIELDS');
  1615.         $sth->STORE('NAME'          , [ map { $_->Name } @$ado_fields ] );
  1616.         $sth->STORE('TYPE'          , [ map { scalar DBD::ADO::TypeInfo::ado2dbi( $_->Type ) } @$ado_fields ] );
  1617.         $sth->STORE('PRECISION'     , [ map { $_->Precision } @$ado_fields ] );
  1618.         $sth->STORE('SCALE'         , [ map { $_->NumericScale } @$ado_fields ] );
  1619.         $sth->STORE('NULLABLE'      , [ map { $_->Attributes & $ado_consts->{FieldAttributeEnum}{adFldMayBeNull}? 1 : 0 } @$ado_fields ] );
  1620.         $sth->STORE('ado_type'      , [ map { $_->Type } @$ado_fields ] );
  1621.  
  1622.         # print 'May Defer', join(', ', map { $_->Attributes & $ado_consts->{FieldAttributeEnum}{adFldMayDefer} ? 1 : 0 } @$ado_fields ), "\n";
  1623.         # print 'Is Long  ', join(', ', map { $_->Attributes & $ado_consts->{FieldAttributeEnum}{adFldLong}     ? 1 : 0 } @$ado_fields ), "\n";
  1624.  
  1625.         $sth->{ado_rowset} = $rs;
  1626.         $sth->{ado_rownum} = 0;
  1627.         $sth->{ado_rows}   = $rows;  # $rs->RecordCount
  1628.  
  1629.         # We need to return a true value for a successful select
  1630.         # -1 means total row count unavailable
  1631.         return $rows || '0E0';  # seems more reliable than $rs->RecordCount
  1632.   }
  1633.  
  1634.     sub rows {
  1635.         my ($sth) = @_;
  1636.         return unless defined $sth;
  1637.         my $rc = $sth->{ado_rows};
  1638.         return defined $rc ? $rc : -1;
  1639.     }
  1640.  
  1641.     sub fetchrow_arrayref {
  1642.         my ($sth) = @_;
  1643.         my $rs = $sth->{ado_rowset};
  1644.  
  1645.         # return undef unless $sth->FETCH('Active');
  1646.         return $sth->set_err( -900,
  1647.             "statement handle not marked as Active.") unless $sth->FETCH('Active');
  1648.  
  1649.         return $sth->set_err( -905,
  1650.             "Recordset Undefined, execute statement not called?") unless $rs;
  1651.  
  1652.         return undef if $rs->EOF;
  1653.  
  1654.         # required to not move from the current row
  1655.         # until the next fetch is called.  blob_read
  1656.         # reads the next record without this check.
  1657.         if ($sth->{ado_rownum} > 0) {
  1658.             $rs->MoveNext;    # to check for errors and record for next itteration
  1659.         }
  1660.         return undef if $rs->{EOF};
  1661.  
  1662.         my $lastError = DBD::ADO::errors($sth->{ado_conn});
  1663.         return $sth->set_err( $DBD::ADO::err || -1,
  1664.             "Fetch failed: $lastError")
  1665.         if $lastError;
  1666.  
  1667.         my $ado_fields = $sth->{ado_fields};
  1668.  
  1669.         my $row =
  1670.             [ map { $rs->Fields($_->{Name})->{Value} } @$ado_fields ];
  1671.         # Jan Dubois jand@activestate.com addition to handle changes
  1672.         # in Win32::OLE return of Variant types of data.
  1673.         foreach (@$row) {
  1674.             $_ = $_->As( Win32::OLE::Variant::VT_BSTR() )
  1675.                 if UNIVERSAL::isa($_, 'Win32::OLE::Variant');
  1676.         }
  1677.         if ($sth->FETCH('ChopBlanks')) {
  1678.             map { $_ =~ s/\s+$//; } @$row;
  1679.         }
  1680.  
  1681.         # Display the attributes for each row selected:
  1682.         if(0) {
  1683.             foreach my $field (map { $rs->Fields($_->{Name}) } @$ado_fields) {
  1684.                 print "Name        : ", $field->Name, "\n";
  1685.                 print "--------------", "\n";
  1686.                 print "ActualSize  : ", $field->ActualSize, "\n";
  1687.                 print "Attributes  : ", $field->Attributes, "\n";
  1688.                 print "        Long: ", $field->Attributes & $ado_consts->{FieldAttributeEnum}{adFldLong}? 1 : 0 , "\n";
  1689.                 print "        Null: ", $field->Attributes & $ado_consts->{FieldAttributeEnum}{adFldMayBeNull}? 1 : 0 , "\n";
  1690.                 print "       Defer: ", $field->Attributes & $ado_consts->{FieldAttributeEnum}{adFldMayDefer}? 1 : 0 , "\n";
  1691.                 print "       Fixed: ", $field->Attributes & $ado_consts->{FieldAttributeEnum}{adFldFixed}? 1 : 0 , "\n";
  1692.                 print "         Key: ", $field->Attributes & $ado_consts->{FieldAttributeEnum}{adFldKeyColumn}? 1 : 0 , "\n";
  1693.                 # print "DataFormat  : ", $field->DataFormat, "\n";
  1694.                 print "DefinedSize : ", $field->DefinedSize, "\n";
  1695.                 print "NumericScale: ", $field->NumericScale, "\n";
  1696.                 print "Precision   : ", $field->Precision, "\n";
  1697.                 print "Status      : ", $field->Status, "\n";
  1698.                 print "Type        : ", $field->Type, "\n";
  1699.                 print "\n";
  1700.             }
  1701.         }
  1702.         $sth->{ado_rownum}++;
  1703.         $sth->{ado_rows} = $sth->{ado_rownum};
  1704.         return $sth->_set_fbav($row);
  1705.   }
  1706.  
  1707.   *fetch = \&fetchrow_arrayref;
  1708.  
  1709.     sub finish {
  1710.         my ($sth) = @_;
  1711.         my $rs = $sth->{ado_rowset};
  1712.         $rs->Close () if $rs and
  1713.             $rs->State & $ado_consts->{ObjectStateEnum}{adStateOpen};
  1714.         $sth->{ado_rowset} = undef;
  1715.         return $sth->STORE(Active => 0);
  1716.     }
  1717.  
  1718.     sub FETCH {
  1719.     my ($sth, $attrib) = @_;
  1720.     # would normally validate and only fetch known attributes
  1721.     # else pass up to DBI to handle
  1722.         if ( exists $sth->{$attrib} ) {
  1723.             return $sth->{$attrib};
  1724.         }
  1725.     return $sth->SUPER::FETCH($attrib);
  1726.     # return $sth->DBD::_::dr::FETCH($attrib);
  1727.   }
  1728.  
  1729.     # Allows adjusting different parameters in the command and connect objects.
  1730.  
  1731.     my $change_affect = {
  1732.         ado_commandtimeout    => 'CommandTimeout'
  1733.     };
  1734.  
  1735.   sub STORE {
  1736.     my ($sth, $attrib, $value) = @_;
  1737.     # would normally validate and only store known attributes
  1738.         if ( exists $sth->{$attrib} ) {
  1739.             if ( exists $change_affect->{$attrib} ) {
  1740.                 # Only attempt to change the command if present.
  1741.                 if (defined $sth->{ado_comm}) {
  1742.                     $sth->{ado_comm}->{$change_affect->{$attrib}} = $value;
  1743.                     my $lastError = DBD::ADO::errors($sth->{ado_conn});
  1744.                     return $sth->set_err( $DBD::ADO::err || -1,
  1745.                         "Store change $attrib: $value: $lastError")
  1746.                     if $lastError;
  1747.                 }
  1748.             }
  1749.             return $sth->{$attrib} = $value;
  1750.         }
  1751.     # else pass up to DBI to handle
  1752.     return $sth->SUPER::STORE($attrib, $value);
  1753.     # return $sth->DBD::_::dr::STORE($attrib, $value);
  1754.   }
  1755.  
  1756.    sub DESTROY { # Statement handle
  1757.     my ($sth) = @_;
  1758.         $sth->trace_msg("<- destroy statement handler\n", 1 );
  1759.  
  1760.     # XXX: Necessary? Call finish()? Or is it called already?
  1761.     my $rs = $sth->{ado_rowset};
  1762. #   Carp::carp "Statement handle has active recordset" if defined $rs;
  1763.         $rs->Close ()
  1764.             if (defined $rs
  1765.                 and UNIVERSAL::isa($rs, 'Win32::OLE')
  1766.                 and ($rs->State != $ado_consts->{ObjectStateEnum}{adStateClosed}));
  1767.         $rs = undef;
  1768.         $sth->{ado_rowset} = undef;
  1769.     $sth->STORE(Active => 0);
  1770.         $sth->trace_msg("-> destroy statement handler\n", 1 );
  1771.  
  1772.         $sth = undef;
  1773.         return;
  1774.     } # Statement handle
  1775.  
  1776. }
  1777.  
  1778. 1;
  1779.  
  1780. =head1 NAME
  1781.  
  1782. DBD::ADO - A DBI driver for Microsoft ADO (Active Data Objects)
  1783.  
  1784. =head1 SYNOPSIS
  1785.  
  1786.   use DBI;
  1787.  
  1788.   $dbh = DBI->connect("dbi:ADO:dsn", $user, $passwd);
  1789.  
  1790.     Options in the connect string:
  1791.     dbi:ADO:dsn;CommandTimeout=60 (your number)
  1792.     dbi:ADO:dsn;ConnectTimeout=60 (your number)
  1793.     or include both ConnectTimeout and CommandTimeout.
  1794.  
  1795.     The dsn may be a standard ODBC dsn or a dsn-less.
  1796.     See the ADO documentation for more information on
  1797.     the dsn-less connection.
  1798.  
  1799.   # See the DBI module documentation for full details
  1800.  
  1801. =head1 DESCRIPTION
  1802.  
  1803. The DBD::ADO module supports ADO access on a Win32 machine.
  1804. DBD::ADO is written to support the standard DBI interface to
  1805. data sources.
  1806.  
  1807. =head1 Connection
  1808.  
  1809.   $dbh = DBI->connect("dbi:ADO:$dsn", $user, $passwd, $attribs );
  1810.  
  1811. Connection supports dsn and dsn-less calls.
  1812.  
  1813.   $dbh = DBI->connect('dbi:ADO:File Name=oracle.udl', $user, $passwd,
  1814.     { RaiseError => [0|1], PrintError => [0|1], AutoCommit => [0|1]} );
  1815.  
  1816. In addition the following attributes may be set in the connect string:
  1817.  
  1818.   Attributes
  1819.   CommandTimeout
  1820.   ConnectionString
  1821.   ConnectionTimeout
  1822.   CursorLocation
  1823.   DefaultDatabase
  1824.   IsolationLevel
  1825.   Mode
  1826.   Provider
  1827.  
  1828. B<Warning:> The application is responsible for passing the correct
  1829. information when setting any of these attributes.
  1830.  
  1831.  
  1832. =head1 ADO-specific methods
  1833.  
  1834. =head2 ado_open_schema
  1835.  
  1836.   $sth = $dbh->ado_open_schema( $QueryType, @Criteria ) or die ...;
  1837.  
  1838. This method can be used to obtain database schema information from the
  1839. provider.
  1840. It returns a valid statement handle upon success.
  1841.  
  1842. C<$QueryType> may be any valid ADO SchemaEnum name such as
  1843.  
  1844.   adSchemaTables
  1845.   adSchemaIndexes
  1846.   adSchemaProviderTypes
  1847.  
  1848. C<@Criteria> (optional) is a list of query constraints depending on each
  1849. C<$QueryType>.
  1850.  
  1851. Example:
  1852.  
  1853.   my $sth = $dbh->ado_open_schema('adSchemaCheckConstraints','Catalog1');
  1854.  
  1855. B<Note:> With DBI version 1.36 and earlier, the func() method has to be used
  1856. to call private methods implemented by the driver:
  1857.  
  1858.   $h->func( @func_arguments, $func_name ) or die ...;
  1859.  
  1860. where C<$func_name> is 'ado_open_schema'.
  1861. You can use 'OpenSchema' for backward compatibility.
  1862.  
  1863. Example:
  1864.  
  1865.   my $sth = $dbh->func('adSchemaCheckConstraints','Catalog1','OpenSchema');
  1866.  
  1867. See ex/OpenSchema.pl for a working example.
  1868.  
  1869.  
  1870. =head1 DBI Methods
  1871.  
  1872. =head2 data_sources
  1873.  
  1874. Because ADO doesn't provide a data source repository, DBD::ADO uses it's
  1875. own. It tries to load Local::DBD::ADO::DSN and expects an array of hashes
  1876. describing the data sources. See ex/Local/DBD/ADO/DSN.pm for an example.
  1877.  
  1878. B<Warning:> This is experimental and may change.
  1879.  
  1880. B<Warning:> Check for the unlikly case that a file Local/DBD/ADO/DSN.pm
  1881. exists in your module search path which causes unwanted side effects when
  1882. loaded.
  1883.  
  1884. =head1 Enhanced DBI Methods
  1885.  
  1886. =head2 prepare
  1887.  
  1888. The B<prepare> methods allows attributes (see DBI):
  1889.  
  1890.   $sth = $dbh->prepare( $statement )          or die $dbh->errstr;
  1891.   $sth = $dbh->prepare( $statement, \%attr )  or die $dbh->errstr;
  1892.  
  1893. DBD::ADO's prepare() supports setting the CursorType, e.g.:
  1894.  
  1895.   $sth = $dbh->prepare( $statement, { CursorType => 'adOpenForwardOnly' } ) ...
  1896.  
  1897. Possible cursortypes are:
  1898.  
  1899.   adOpenForwardOnly (default)
  1900.   adOpenKeyset
  1901.   adOpenDynamic
  1902.   adOpenStatic
  1903.  
  1904. It may be necessary to prepare the statement using cursortype 'adOpenStatic'
  1905. when using a statement handle within a statement handle:
  1906.  
  1907.   while( my $table = $sth1->fetchrow_hashref ) {
  1908.     ...
  1909.     my $col = $sth2->fetchrow_hashref;
  1910.     ...
  1911.   }
  1912.  
  1913. Changing the CursorType is a solution to the following problem:
  1914.  
  1915.   Can't execute statement 'select * from authors':
  1916.   Lasterror : -2147467259
  1917.   OLE exception from "Microsoft OLE DB Provider for SQL Server":
  1918.  
  1919.   Cannot create new connection because in manual or distributed transaction
  1920.   mode.
  1921.  
  1922.   Win32::OLE(0.1403) error 0x80004005: "Unspecified error"
  1923.       in METHOD/PROPERTYGET "Open"
  1924.  
  1925.           Description : Cannot create new connection because in manual or distributed transaction mode.
  1926.           HelpContext : 0
  1927.           HelpFile    :
  1928.           NativeError : 0
  1929.           Number      : -2147467259
  1930.           Source      : Microsoft OLE DB Provider for SQL Server
  1931.           SQLState    :
  1932.  
  1933.  
  1934. =head2 bind_param
  1935.  
  1936. Normally, the datatypes of placeholders are known after the statement is
  1937. prepared. In this case, you don't need to provide any type information:
  1938.  
  1939.   $sth->bind_param( 1, $value );
  1940.  
  1941. Sometimes, you need to specify a type for the parameter, e.g.:
  1942.  
  1943.   $sth->bind_param( 1, $value, SQL_NUMERIC );
  1944.  
  1945. As a last resort, you can provide an ADO-specific type, e.g.:
  1946.  
  1947.   $sth->bind_param( 1, $value, { ado_type => 6 } );  # adCurrency
  1948.  
  1949. If no type is given (neither by the provider nor by you), the datatype
  1950. defaults to SQL_VARCHAR (adVarChar).
  1951.  
  1952.  
  1953. =head2 table_info
  1954.  
  1955. B<Warning:> This method is experimental and may change or disappear.
  1956.  
  1957.   $sth = $dbh->table_info(\%attr);
  1958.  
  1959.   $sth = $dbh->table_info({
  1960.     TABLE_TYPE => 'VIEW',
  1961.     ADO_Columns => 1,
  1962.     Trim_Catalog => 0,
  1963.     Filter => q{TABLE_NAME LIKE 'C%'},
  1964.   });
  1965.  
  1966. Returns an active statement handle that can be used to fetch
  1967. information about tables and views that exist in the database.
  1968. By default the handle contains the columns described in the DBI documentation:
  1969.  
  1970.   TABLE_CAT, TABLE_SCHEM, TABLE_NAME, TABLE_TYPE, REMARKS
  1971.  
  1972. =over
  1973.  
  1974. =item B<ADO_Columns>
  1975.  
  1976. Additional ADO-only fields will be included if the ADO_Columns attribute
  1977. is set to true:
  1978.  
  1979.   %attr = (ADO_Columns => 1);
  1980.  
  1981. =item B<Trim_Catalog>
  1982.  
  1983. Some ADO providers include path info in the TABLE_CAT column.
  1984. This information will be trimmed if the Trim_Catalog attribute is set to true:
  1985.  
  1986.   %attr = (Trim_Catalog => 1);
  1987.  
  1988. =item B<Criteria>
  1989.  
  1990. The ADO driver allows column criteria to be specified.  In this way the
  1991. record set can be restricted, for example, to only include tables of type 'VIEW':
  1992.  
  1993.   %attr = (TABLE_TYPE => 'VIEW')
  1994.  
  1995. You can add criteria for any of the following columns:
  1996.  
  1997.   TABLE_CAT, TABLE_SCHEM, TABLE_NAME, TABLE_TYPE
  1998.  
  1999. =item B<Filter>
  2000.  
  2001. =back
  2002.  
  2003. The ADO driver also allows the recordset to be filtered on a Criteria string:
  2004. a string made up of one or more individual clauses concatenated with AND or OR operators.
  2005.  
  2006.   %attr = (Filter => q{TABLE_TYPE LIKE 'SYSTEM%'})
  2007.  
  2008. The criteria string is made up of clauses in the form FieldName-Operator-Value.
  2009. This is more flexible than using column criteria in that the filter allows a number of operators:
  2010.  
  2011.   <, >, <=, >=, <>, =, or LIKE
  2012.  
  2013. The Fieldname must be one of the ADO 'TABLES Rowset' column names:
  2014.  
  2015.   TABLE_CATALOG, TABLE_SCHEMA, TABLE_NAME, TABLE_TYPE, DESCRIPTION,
  2016.   TABLE_GUID, TABLE_PROPID, DATE_CREATED, DATE_MODIFIED
  2017.  
  2018. Value is the value with which you will compare the field values
  2019. (for example, 'Smith', #8/24/95#, 12.345, or $50.00).
  2020. Use single quotes with strings and pound signs (#) with dates.
  2021. For numbers, you can use decimal points, dollar signs, and scientific notation.
  2022. If Operator is LIKE, Value can use wildcards.
  2023. Only the asterisk (*) and percent sign (%) wild cards are allowed,
  2024. and they must be the last character in the string. Value cannot be null.
  2025.  
  2026.  
  2027. =head2 tables
  2028.  
  2029. B<Warning:> This method is experimental and may change or disappear.
  2030.  
  2031.   @names = $dbh->tables(\%attr);
  2032.  
  2033. Returns a list of table and view names.
  2034. Accepts any of the attributes described in the L<table_info> method:
  2035.  
  2036.   @names = $dbh->tables({ TABLE_TYPE => 'VIEW' });
  2037.  
  2038.  
  2039. =head1 CAVEATS
  2040.  
  2041. =head2 Character set
  2042.  
  2043. Proper Unicode support depends on all components involved in your
  2044. application: the DBMS, the ADO provider, Perl and some perl modules.
  2045.  
  2046. In short: Perl 5.8 and Win32::OLE 0.16 (or later) are strongly
  2047. recommended and Win32::OLE has to be prepared to use the correct
  2048. codepage:
  2049.  
  2050.   Win32::OLE->Option( CP => Win32::OLE::CP_UTF8 );
  2051.  
  2052. More detailed notes can be found at
  2053.  
  2054.   http://purl.net/stefan_ram/pub/perl_unicode_en
  2055.  
  2056. =head2 Type info
  2057.  
  2058. Support for type_info_all is supported, however, you're not using
  2059. a true OLE DB provider (using the MS OLE DB -> ODBC), the first
  2060. hash may not be the "best" solution for the data type.
  2061. adSchemaProviderTypes does provide for a "best match" column, however
  2062. the MS OLE DB -> ODBC provider does not support the best match.
  2063. Currently the types are sorted by DATA_TYPE BEST_MATCH IS_LONG ...
  2064.  
  2065. =head1 ADO
  2066.  
  2067. It is strongly recommended that you use the latest version of ADO
  2068. (2.1 at the time this was written). You can download it from:
  2069.  
  2070.   http://www.microsoft.com/Data/download.htm
  2071.  
  2072. =head1 AUTHORS
  2073.  
  2074. Tim Bunce and Phlip. With many thanks to Jan Dubois and Jochen Wiedmann
  2075. for additions, debuggery and general help.
  2076. Special thanks to Thomas Lowery, who maintained this module 2001-2003.
  2077. Current maintainer is Steffen Goeldner.
  2078.  
  2079. =head1 SUPPORT
  2080.  
  2081. This software is supported via the dbi-users mailing list.
  2082. For more information and to keep informed about progress you can join the
  2083. mailing list by sending a message to dbi-users-help@perl.org
  2084.  
  2085. Please post details of any problems (or changes you needed to make) to
  2086. dbi-users@perl.org and CC them to me (sgoeldner@cpan.org).
  2087.  
  2088. =head1 COPYRIGHT
  2089.  
  2090.   Copyright (c) 1998, Tim Bunce
  2091.   Copyright (c) 1999, Tim Bunce, Phlip, Thomas Lowery
  2092.   Copyright (c) 2000, Tim Bunce, Thomas Lowery
  2093.   Copyright (c) 2001, Tim Bunce, Thomas Lowery, Steffen Goeldner
  2094.   Copyright (c) 2002, Thomas Lowery, Steffen Goeldner
  2095.   Copyright (c) 2003, Thomas Lowery, Steffen Goeldner
  2096.   Copyright (c) 2004, Steffen Goeldner
  2097.  
  2098.   All rights reserved.
  2099.  
  2100.   You may distribute under the terms of either the GNU General Public
  2101.   License or the Artistic License, as specified in the Perl README file.
  2102.  
  2103. =head1 SEE ALSO
  2104.  
  2105. ADO Reference book:  ADO 2.0 Programmer's Reference, David Sussman and
  2106. Alex Homer, Wrox, ISBN 1-861001-83-5. If there's anything better please
  2107. let me know.
  2108.  
  2109. http://www.able-consulting.com/tech.htm
  2110.  
  2111. =cut
  2112.