projects / OpenSPARC-T2-DV / blame
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Initial commit of OpenSPARC T2 design and verification files.
[OpenSPARC-T2-DV] / tools / perl-5.8.0 / lib / site_perl / 5.8.0 / sun4-solaris / DBD / ADO.pm
CommitLineData
86530b38
AT		 1
2# vim:ts=2:sw=2:ai:aw:nu
3{
4 package DBD::ADO;
5
6 require DBI;
7 require Carp;
8 use strict;
9 use vars qw($err $errstr $state $drh $VERSION @EXPORT);
10
11 @EXPORT = ();
12 $VERSION = substr(q!Revision: 2.0 !, 9,-1) +0;
13
14# $Id: ADO.pm,v 1.20 2001/05/29 23:25:55 timbo Exp $
15#
16# Copyright (c) 1999, Phlip & Tim Bunce
17# Copyright (c) 2001, Thomas "A." Lowery
18#
19# You may distribute under the terms of either the GNU General Public
20# License or the Artistic License, as specified in the Perl README file.
21
22 $drh = undef; # holds driver handle once initialised
23 $err = 0; # The $DBI::err value
24 $errstr = "";
25 $state = "";
26
27 sub driver{
28 return $drh if $drh;
29 my($class, $attr) = @_;
30 $class .= "::dr";
31 ($drh) = DBI::_new_drh($class, {
32 'Name' => 'ADO',
33 'Version' => $VERSION,
34 'Attribution' => 'DBD ADO for Win32 by Phlip & Tim Bunce',
35 'Err' => \$DBD::ADO::err,
36 'Errstr' => \$DBD::ADO::errstr,
37 'State' => \$DBD::ADO::state,
38 });
39 return $drh;
40 }
41
42
43 sub errors {
44 my $Conn = shift;
45 my $err_ary = [];
46
47 my $lastError = Win32::OLE->LastError;
48 push @$err_ary, "\nLasterror:\t " . ($lastError+0) . ": $lastError"
49 if $lastError;
50
51 return unless ref $Conn;
52 my $Errors = $Conn->Errors();
53 # return unless defined $Errors;
54 if($Errors && $Errors->{Count}) {
55 my $err;
56 foreach $err (Win32::OLE::in($Errors)) {
57 next if $err->{Number} == 0; # Skip warnings
58 push(@$err_ary,
59 "\tDescription:\t$err->{Description}",
60 "\tHelpContext:\t$err->{HelpContext}",
61 "\tHelpFile: \t$err->{HelpFile}",
62 "\tNativeError:\t$err->{NativeError}",
63 "\tNumber: \t$err->{Number}",
64 "\tSource: \t$err->{Source}",
65 "\tSQLState: \t$err->{SQLState}");
66 }
67 #return join "\n", @$err_ary;
68 }
69 $Errors->Clear if $Errors;
70 $Conn->Errors->Clear();
71 return ($err_ary? join "\n", @$err_ary : undef);
72 }
73
74}
75
76
77# ADO.pm lexically scoped constants
78my $ado_consts;
79my $VT_I4_BYREF;
80my $ado_sptype;
81my %connect_options;
82
83
84
85{ package DBD::ADO::dr; # ====== DRIVER ======
86
87 use strict;
88 use vars qw($imp_data_size);
89 $imp_data_size = 0;
90
91 sub DBPROPVAL_TC_ALL { return 8 };
92 sub DBPROPVAL_TC_DDL_IGNORE { return 4 };
93 sub DBPROPVAL_TC_DDL_COMMIT { return 2 };
94 sub DBPROPVAL_TC_DML{ return 1 };
95 sub DBPROPVAL_TC_NONE{ return 0 };
96
97 sub connect {
98 my ($drh, $dsn, $user, $auth) = @_;
99
100 require Win32::OLE;
101
102 unless ($ado_consts) {
103 require Win32::OLE::Const;
104 my $name = "Microsoft ActiveX Data Objects 2\\.\\d+ Library";
105 $ado_consts = Win32::OLE::Const->Load($name)
106 or die "Unable to load Win32::OLE::Const ``$name'' ".Win32::OLE->LastError;
107 require Win32::OLE::Variant;
108 $VT_I4_BYREF = Win32::OLE::Variant::VT_I4()
109 | Win32::OLE::Variant::VT_BYREF();
110
111 }
112
113 local $Win32::OLE::Warn = 0;
114 my $conn = Win32::OLE->new('ADODB.Connection');
115 my $lastError = Win32::OLE->LastError;
116 return DBI::set_err($drh, 1,
117 "Can't create 'ADODB.Connection': $lastError")
118 if $lastError;
119
120 my $this = DBI::_new_dbh($drh, {
121 Name => $dsn,
122 User => $user,
123 AutoCommit => 1,
124 Warn => 0,
125 LongReadLen => 0,
126 LongTruncOk => 0,
127 },
128 {
129 ado_conn => undef,
130 Attributes => undef,
131 CommandTimeout => undef,
132 ConnectionString => undef,
133 ConnectionTimeout => undef,
134 CursorLocation => undef,
135 DefaultDatabase => undef,
136 IsolationLevel => undef,
137 Mode => undef,
138 Provider => undef,
139 State => undef,
140 Version => undef,
141 });
142
143 $this->STORE( ado_conn => $conn );
144 $drh->trace_msg( "->ADO Connection: " . ref $this->FETCH('ado_conn') .
145 " Connection: " . ref $conn . "\n", 1);
146 ## ODBC rule - Null is not the same as an empty password...
147 $auth = '' if !defined $auth;
148
149 my (@cdsn,$cdsn);
150 # Run thru the dsn extracting connection options.
151 if( $dsn =~ /;/ ) {
152 for my $s (split( /;/, $dsn)) {
153 if ($s =~ m/^(.*?)=(.*)$/s){
154 my ($c, $v) = ($1, $2);
155 # Only include the options defined.
156 if( $conn->{$c} ) {
157 $this->STORE($c, $v);
158 $drh->trace_msg("->> Storing $c $v\n", 1);
159 next;
160 }
161 }
162 push(@cdsn, $s );
163 }
164 } else {
165 if($dsn =~ m/^(.*?)=(.*)$/s) {
166 $this->STORE( "ConnectionString", $dsn );
167 } else {
168 $this->STORE( "ConnectionString", "DSN=$dsn" );
169 push(@cdsn, $dsn);
170 }
171 }
172
173 $cdsn = join( ";", @cdsn );
174 $drh->trace_msg("->> Open ADO connection using $cdsn\n", 1);
175 $conn->Open ($cdsn, $user, $auth);
176 $lastError = DBD::ADO::errors($conn);
177 return DBI::set_err( $drh, 1,
178 "Can't connect to '$dsn': $lastError")
179 if $lastError;
180
181 # Remember, Tom, or-ing them works much better.
182 my $att =
183 $ado_consts->{adXactCommitRetaining} |
184 $ado_consts->{adXactAbortRetaining};
185
186 $conn->{Attributes} = $att;
187 $lastError = DBD::ADO::errors($conn);
188 return DBI::set_err( $conn, 1,
189 "Failed setting CommitRetaining: $lastError")
190 if $lastError;
191
192 # Determine if the provider supports transaction.
193 my $auto = 0;
194 eval {
195 $auto = $conn->Properties->{qq{Transaction DDL}}->{Value};
196 if ( $auto eq &DBPROPVAL_TC_ALL ) {
197 $this->{ado_provider_support_auto_commit} = $auto;
198 $this->{ado_provider_auto_commit_comments} =
199 qq{Transactions can contain DDL and DML statements in any order.};
200 } elsif ( $auto eq &DBPROPVAL_TC_DDL_COMMIT ) {
201 $this->{ado_provider_support_auto_commit} = $auto;
202 $this->{ado_provider_auto_commit_comments} =
203 qq{Transactions can contain DML statements. DDL statements within a transaction cause the transaction to be committed.};
204 } elsif ( $auto eq &DBPROPVAL_TC_DDL_IGNORE ) {
205 $this->{ado_provider_support_auto_commit} = $auto;
206 $this->{ado_provider_auto_commit_comments} =
207 qq{Transactions can only contain DML statements. DDL statements within a transaction are ignored.};
208 } elsif ( $auto eq &DBPROPVAL_TC_DML ) {
209 $this->{ado_provider_support_auto_commit} = $auto;
210 $this->{ado_provider_auto_commit_comments} =
211 qq{Transactions can only contain Data Manipulation (DML) statements. DDL statements within a trnsaction cause an error.};
212 } else {
213 $this->{ado_provider_support_auto_commit} = $auto;
214 $this->{ado_provider_auto_commit_comments} =
215 qq{Transactions are not supported.};
216 }
217 };
218 if ($@) {
219 warn "No transactions";
220 $this->{ado_provider_support_auto_commit} = 0;
221 $this->{ado_provider_auto_commit_comments} =
222 qq{Transactions are not supported.};
223 $auto = 0;
224 $lastError = DBD::ADO::errors($conn);
225 }
226
227 $drh->trace_msg( "->> Transaction support: $auto " .
228 $this->{ado_provider_auto_commit_comments} . "\n",1);
229 # If transaction are not supported, why execute.
230 if ($auto) {
231 $conn->BeginTrans;
232 $lastError = DBD::ADO::errors($conn);
233 return DBI::set_err( $this, 1,
234 "Begin Transaction Failed: $lastError")
235 if $lastError;
236 }
237
238 return $this;
239 }
240
241 sub disconnect_all { }
242 sub DESTROY {
243 my $self = shift;
244 my $conn = $self->{ado_conn};
245 my $auto = $self->{AutoCommit};
246 if (defined $conn) {
247 $conn->CommitTrans if $auto
248 and $self->{ado_provider_support_auto_commit};
249 $conn->RollbackTrans unless $auto
250 and not $self->{ado_provider_support_auto_commit};
251 my $lastError = DBD::ADO::errors($conn);
252 return DBI::set_err( $self, 1, "Failed to Destory: $lastError")
253 if $lastError;
254 }
255 }
256} # ====== DRIVER ======
257
258
259# names of adSchemaProviderTypes fields
260my $ado_info = [qw{
261 TYPE_NAME DATA_TYPE COLUMN_SIZE LITERAL_PREFIX
262 LITERAL_SUFFIX CREATE_PARAMS IS_NULLABLE CASE_SENSITIVE
263 SEARCHABLE UNSIGNED_ATTRIBUTE FIXED_PREC_SCALE AUTO_UNIQUE_VALUE
264 LOCAL_TYPE_NAME MINIMUM_SCALE MAXIMUM_SCALE GUID TYPELIB
265 VERSION IS_LONG BEST_MATCH IS_FIXEDLENGTH
266}];
267# check IS_NULLABLE => NULLABLE (only difference with DBI/ISO field names)
268# Information returned from the provider about the schema. The column names
269# are different then the DBI spec.
270my $ado_schematables = [
271 qw{ TABLE_CAT TABLE_SCHEM TABLE_NAME TABLE_TYPE REMARKS
272 TABLE_GUID TABLE_PROPID DATE_CREATED DATE_MODIFIED
273 } ];
274
275my $ado_dbi_schematables = [
276 qw{ TABLE_CAT TABLE_SCHEM TABLE_NAME TABLE_TYPE REMARKS }
277 ];
278
279my $sch_dbi_to_ado = {
280 TABLE_CAT => 'TABLE_CATALOG',
281 TABLE_SCHEM => 'TABLE_SCHEMA',
282 TABLE_NAME => 'TABLE_NAME',
283 TABLE_TYPE => 'TABLE_TYPE',
284 REMARKS => 'DESCRIPTION',
285 TABLE_GUID => 'TABLE_GUID',
286 TABLE_PROPID => 'TABLE_PROPID',
287 DATE_CREATED => 'DATE_CREATED',
288 DATE_MODIFIED => 'DATE_MODIFIED',
289 };
290
291my @myType;
292my $ado_type;
293
294{ package DBD::ADO::db; # ====== DATABASE ======
295 $imp_data_size = 0;
296
297 use Carp;
298 use strict;
299
300 # Rollback to the database.
301 sub rollback {
302 my($dbh) = @_;
303
304 return carp "Rollback ineffective when AutoCommit is on\n"
305 if $dbh->{AutoCommit} and $dbh->FETCH('Warn');
306 return carp $dbh->{ado_provider_auto_commit_comments}
307 unless $dbh->{ado_provider_support_auto_commit};
308 if (exists $dbh->{ado_conn} and defined $dbh->{ado_conn} and
309 $dbh->{ado_conn}->{State} & $ado_consts->{adStateOpen}) {
310 $dbh->{ado_conn}->RollbackTrans;
311 my $lastError = DBD::ADO::errors($dbh->{ado_conn});
312 return DBI::set_err( $dbh, 1,
313 "Failed to Rollback Trans: $lastError")
314 if $lastError;
315 }
316 }
317
318 sub disconnect {
319 my ($dbh) = @_;
320 my $conn = $dbh->{ado_conn};
321 local $Win32::OLE::Warn = 0;
322 $dbh->trace_msg( "<- State: (" . $conn->State . ")\n");
323 if ($conn->State & $ado_consts->{adStateOpen}) {
324 my $auto = $dbh->{AutoCommit};
325 # Change the connection attribute so Commit/Rollback
326 # does not start another transaction.
327 $conn->{Attributes} = 0;
328 my $lastError = DBD::ADO::errors($conn);
329 return DBI::set_err( $conn, 1,
330 "Failed setting CommitRetaining: $lastError") #-2147168242
331 if $lastError and $lastError !~ m/-2147168242/;
332
333 $dbh->trace_msg( "<- modified connection Attributes " . $conn->{Attributes} . "\n");
334 $dbh->trace_msg( "<- AutoCommit -> $auto Provider Support -> $dbh->{ado_provider_support_auto_commit} Comments -> $dbh->{ado_provider_auto_commit_comments}\n");
335 $dbh->{ado_provider_auto_commit_comments} =
336 $conn->CommitTrans if $auto and
337 $dbh->{ado_provider_support_auto_commit};
338
339 $conn->RollbackTrans unless $auto and
340 not $dbh->{ado_provider_support_auto_commit};
341
342 $lastError = DBD::ADO::errors($conn);
343 return DBI::set_err( $dbh, 1, "Failed to disconnect: $lastError")
344 if $lastError and $lastError !~ m/-2147168242/;
345
346 $conn->Close;
347 $conn = undef;
348 $dbh->{ado_conn} = undef;
349 }
350
351 $dbh->STORE( ado_conn => undef );
352 }
353
354 # Commit to the database.
355 sub commit {
356 my($dbh) = @_;
357
358 return warn "Commit ineffective when AutoCommit is on\n"
359 if $dbh->{AutoCommit} and $dbh->FETCH('Warn');
360 return carp $dbh->{ado_provider_auto_commit_comments}
361 unless $dbh->{ado_provider_support_auto_commit};
362 if (exists $dbh->{ado_conn} and defined $dbh->{ado_conn} and
363 $dbh->{ado_conn}->{State} == $ado_consts->{adStateOpen}) {
364
365 $dbh->{ado_conn}->CommitTrans;
366 my $lastError = DBD::ADO::errors($dbh->{ado_conn});
367 return DBI::set_err( $dbh, 1, "Failed to CommitTrans: $lastError")
368 if $lastError;
369 }
370 }
371
372 sub prepare {
373 my($dbh, $statement, $attribs) = @_;
374 my $conn = $dbh->FETCH("ado_conn");
375
376
377 $dbh->trace_msg( "-> create a new statement handler\n");
378
379 my $comm = Win32::OLE->new('ADODB.Command');
380 my $lastError = Win32::OLE->LastError;
381 return DBI::set_err($dbh, 1,
382 "Can't create 'object ADODB.Command': $lastError")
383 if $lastError;
384
385 $comm->{ActiveConnection} = $conn;
386 $lastError = DBD::ADO::errors($conn);
387 return DBI::set_err($dbh, 1,
388 "Unable to set ActiveConnection 'ADODB.Command': $lastError")
389 if $lastError;
390
391 $comm->{CommandText} = $statement;
392 $lastError = DBD::ADO::errors($conn);
393 return DBI::set_err($dbh, 1,
394 "Unable to set CommandText 'ADODB.Command': $lastError")
395 if $lastError;
396
397 my $ct = $attribs->{CommandType}? $attribs->{CommandType}: "adCmdText";
398 $comm->{CommandType} = $ado_consts->{$ct};
399 $lastError = DBD::ADO::errors($conn);
400 return DBI::set_err($dbh, 1,
401 "Unable to set command type 'ADODB.Command': $lastError")
402 if $lastError;
403
404
405
406 my ($outer, $sth) = DBI::_new_sth($dbh, {
407 'Statement' => $statement,
408 LongReadLen => 0,
409 LongTruncOk => 0,
410 CursorName => undef,
411 RowsInCache => 0,
412 ado_comm => undef,
413 ado_conn => undef,
414 ado_dbh => undef,
415 ado_params => [],
416 ado_rowset => undef,
417 ado_refresh => 1,
418 ado_current_row_count => 0,
419 });
420
421# Determine if Refresh is supported. If the call returns
422# an error, then Parameters->Refresh is not supported.
423 $comm->Parameters->Refresh() if $sth->FETCH(q{ado_refresh});
424 $lastError = DBD::ADO::errors($conn);
425 if (!$sth->FETCH(q{ado_refresh}) or $lastError) {
426 $sth->STORE( 'NUM_OF_PARAMS', _params($statement));
427 $sth->STORE( 'ado_refresh' => 0 );
428 my $params = $sth->FETCH( 'NUM_OF_PARAMS');
429 if ($params > 0) {
430 for ( 0 .. ($params - 1)) {
431 my $parm =
432 $comm->CreateParameter("$_",
433 $ado_consts->{adVarChar},
434 $ado_consts->{adParamInput},
435 1,
436 "");
437 my $lastError = DBD::ADO::errors($conn);
438 return DBI::set_err( $sth, 1,
439 "Unable to CreateParameter: $lastError")
440 if $lastError;
441
442 $comm->Parameters->Append($parm);
443 $lastError = DBD::ADO::errors($conn);
444 return DBI::set_err( $sth, 1,
445 "Append parameter failed : $lastError")
446 if $lastError;
447 }
448 }
449 } else {
450 $sth->STORE( 'NUM_OF_PARAMS' => $comm->Parameters->Count );
451 $sth->STORE( 'ado_refresh' => 1 );
452# Describe the Parameters.
453 if ($comm->Parameters->Count) {
454 my $cnt = 0;
455 while ($cnt < $comm->Parameters->Count) {
456 my $x = $comm->Parameters->Item($cnt);
457 $dbh->trace_msg( "-> prepare: Name: " .
458 $x->{Name} .
459 " Type: " .
460 $x->{Type} .
461 " Direction: " .
462 $x->{Direction} .
463 " Size: " .
464 $x->{Size} .
465 "\n");
466 $cnt++;
467 }
468 } else {
469 $sth->trace_msg("-> prepare: statement contains no parameters\n");
470 }
471# Only preparing a statement if it contains parameters.
472 $comm->{Prepared} = 1;
473 $lastError = DBD::ADO::errors($conn);
474 return DBI::set_err($dbh, 1,
475 "Unable to set prepared 'ADODB.Command': $lastError")
476 if $lastError;
477 }
478
479 $sth->STORE( 'CursorName' => undef );
480 $sth->STORE( 'RowsInCache' => 0 );
481
482 $sth->STORE( 'ado_params', [] );
483 $sth->STORE( ado_conn => $conn );
484 $sth->STORE( ado_comm => $comm );
485 $sth->STORE( ado_dbh => $dbh );
486
487 return $outer;
488 }
489 #
490 # Creates a Statement handle from a row set.
491 #
492 sub _rs_sth_prepare {
493 my($dbh, $rs, $attribs) = @_;
494
495 my $conn = $dbh->FETCH("ado_conn");
496 my $rows;
497
498 my ($outer, $sth) = DBI::_new_sth($dbh, {
499 'Statement' => $attribs,
500 LongReadLen => 0,
501 LongTruncOk => 0,
502 CursorName => undef,
503 RowsInCache => 0,
504 ado_comm => undef,
505 ado_conn => undef,
506 ado_rowset => $rs,
507 ado_fields => undef,
508 ado_dbh => undef,
509 ado_params => [],
510 });
511
512 my $ado_fields = [ Win32::OLE::in($rs->Fields) ];
513 $sth->STORE(ado_fields => $ado_fields);
514 my $NUM_OF_FIELDS = @$ado_fields;
515
516 $sth->STORE(Active => 1);
517 $sth->STORE(NUM_OF_FIELDS => $NUM_OF_FIELDS);
518 $sth->STORE( 'ado_params' => [] );
519 $sth->STORE(NAME => [ map { $_->Name } @$ado_fields ]);
520 $sth->STORE(ado_dbh => $dbh);
521 $sth->STORE(ado_conn => $conn);
522 $sth->STORE(ado_comm => $conn);
523
524 return $outer;
525 }
526
527
528# Determine the number of parameters, if Refresh fails.
529sub _params
530{
531 my $sql = shift;
532 use Text::ParseWords;
533 $^W = 0;
534 $sql =~ s/\n/ /;
535 my $rtn = join( " ", grep { m/\?/ }
536 grep { ! m/^['"].*\?/ } &quotewords('\s+', 1, $sql));
537 return ($rtn =~ tr /?//);
538}
539
540 # Get information from the current provider.
541 sub GetTypeInfo {
542 my($dbh, $attribs) = @_;
543 my $sth;
544 my $lastError;
545
546 # If the type information is previously obtained, use it.
547 unless (defined $ado_type) {
548 $ado_type = &_determine_type_support;
549 }
550
551 my $sponge = DBI->connect("dbi:Sponge:","","",{ RaiseError => 1 });
552 $sth = $sponge->prepare("adSchemaProviderTypes", {
553 rows=> [ @$ado_type ] , NAME=> $ado_info,
554 });
555 $sth;
556 }
557
558use Win32::OLE::Variant;
559
560 sub table_info {
561 my($dbh, $attribs) = @_;
562 my @tp;
563
564 my @criteria = (undef); # ADO needs at least one element in the criteria array!
565 for (my $i=0; $i<@$ado_dbi_schematables; $i++) {
566 my $field = $ado_dbi_schematables->[$i];
567 if (exists $attribs->{$field}) {
568 $criteria[$i] = $attribs->{$field};
569 }
570 }
571
572 my $field_names = $attribs->{ADO_Columns} ?
573 $ado_schematables : $ado_dbi_schematables;
574
575 my $oRec = $dbh->{ado_conn}->OpenSchema($ado_consts->{adSchemaTables}, \@criteria);
576 if (exists $attribs->{Filter}) {
577 $oRec->{Filter} = $attribs->{Filter};
578 }
579
580 while(! $oRec->{EOF}) {
581 my @out = map { $oRec->Fields($_)->{Value} }
582 map { $sch_dbi_to_ado->{$_} } @$field_names;
583 # Jan Dubois jand@activestate.com addition to handle changes
584 # in Win32::OLE return of Variant types of data.
585 foreach ( @out ) {
586 $_ = $_->As(VT_BSTR)
587 if (defined $_) && (UNIVERSAL::isa($_, 'Win32::OLE::Variant'));
588 }
589 if ($attribs->{Trim_Catalog}) {
590 $out[0] =~ s/^(.*\\)//; # removes leading
591 $out[0] =~ s/(\..*)$//; # removes file extension
592 }
593 push( @tp, \@out );
594 $oRec->MoveNext;
595 }
596 $oRec->Close;
597 $oRec = undef;
598
599 my $statement = "adSchemaTables";
600 my $sponge = DBI->connect("dbi:Sponge:","","",{ RaiseError => 1 });
601 my $sth = $sponge->prepare($statement,
602 { rows=> \@tp, NAME=> $field_names });
603 $sth;
604 }
605
606 sub type_info_all {
607 my ($dbh) = @_;
608 my $names = {
609 TYPE_NAME => 0,
610 DATA_TYPE => 1,
611 COLUMN_SIZE => 2,
612 LITERAL_PREFIX => 3,
613 LITERAL_SUFFIX => 4,
614 CREATE_PARAMS => 5,
615 NULLABLE => 6,
616 CASE_SENSITIVE => 7,
617 SEARCHABLE => 8,
618 UNSIGNED_ATTRIBUTE => 9,
619 FIXED_PREC_SCALE =>10,
620 AUTO_UNIQUE_VALUE =>11,
621 LOCAL_TYPE_NAME =>12,
622 MINIMUM_SCALE =>13,
623 MAXIMUM_SCALE =>14,
624 };
625 # Based on the values from the current provider.
626 my @myti;
627 my $sth = $dbh->func( DBI::SQL_ALL_TYPES(), 'GetTypeInfo' );
628 while(my $row = $sth->fetchrow_hashref) {
629 my @tyinfo;
630 # Only add items from the above names list. When
631 # this list explans, the code 'should' still work.
632 for my $n (keys %{$names}){
633 $tyinfo[ $names->{$n} ] = $row->{$n} || '';
634 }
635 push( @myti, \@tyinfo );
636 }
637 $sth->finish;
638 my $ti = [ $names, @myti ];
639 return $ti;
640 }
641
642 # This is a function, not a method.
643 sub _determine_type_support {
644 my ($dbh) = @_;
645 die qq{dbh undefined} unless $dbh;
646 my @prov_type_return;
647 undef(@prov_type_return);
648 my $conn = $dbh->{ado_conn};
649
650 $dbh->trace_msg( "-> _determine_type_support\n" );
651 # This my attempt to convert data types from ODBC to ADO.
652 my %local_types = (
653 DBI::SQL_BINARY() => [$ado_consts->{adBinary}, $ado_consts->{adVarBinary} ],
654 DBI::SQL_BIT() => [$ado_consts->{adBoolean}],
655 DBI::SQL_CHAR() => [$ado_consts->{adChar}, $ado_consts->{adVarChar}, $ado_consts->{adWChar}, $ado_consts->{adVarWChar}],
656 DBI::SQL_DATE() => [$ado_consts->{adDBTimeStamp}, $ado_consts->{adDate}],
657 DBI::SQL_DECIMAL() => [$ado_consts->{adNumeric}],
658 DBI::SQL_DOUBLE() => [$ado_consts->{adDouble}],
659 DBI::SQL_FLOAT() => [$ado_consts->{adSingle}],
660 DBI::SQL_INTEGER() => [$ado_consts->{adInteger}],
661 DBI::SQL_LONGVARBINARY() => [$ado_consts->{adLongVarBinary}, $ado_consts->{adVarBinary}, $ado_consts->{adBinary}],
662 DBI::SQL_LONGVARCHAR() => [$ado_consts->{adLongVarChar}, $ado_consts->{adVarChar}, $ado_consts->{adChar}, $ado_consts->{adLongVarWChar}, $ado_consts->{adVarWChar}, $ado_consts->{adWChar}],
663 DBI::SQL_NUMERIC() => [$ado_consts->{adNumeric}],
664 DBI::SQL_REAL() => [$ado_consts->{adSingle}],
665 DBI::SQL_SMALLINT() => [$ado_consts->{adSmallInt}],
666 DBI::SQL_TIMESTAMP() => [$ado_consts->{adDBTime}, $ado_consts->{adDBTimeStamp}, $ado_consts->{adDate}],
667 DBI::SQL_TINYINT() => [$ado_consts->{adUnsignedTinyInt}],
668 DBI::SQL_VARBINARY() => [$ado_consts->{adVarBinary}, $ado_consts->{adLongVarBinary}, $ado_consts->{adBinary}],
669 DBI::SQL_VARCHAR() => [$ado_consts->{adVarChar}, $ado_consts->{adChar}, $ado_consts->{adVarWChar}, $ado_consts->{adWChar}],
670 DBI::SQL_WCHAR() => [$ado_consts->{adWChar}, $ado_consts->{adVarWChar}, $ado_consts->{adLongVarWChar}],
671 DBI::SQL_WVARCHAR() => [$ado_consts->{adVarWChar}, $ado_consts->{adLongVarWChar}, $ado_consts->{adWChar}],
672 DBI::SQL_WLONGVARCHAR() => [$ado_consts->{adLongVarWChar}, $ado_consts->{adVarWChar}, $ado_consts->{adWChar}],
673 );
674
675 my @sql_type = (
676 DBI::SQL_BINARY(),
677 DBI::SQL_BIT(),
678 DBI::SQL_CHAR(),
679 DBI::SQL_DATE(),
680 DBI::SQL_DECIMAL(),
681 DBI::SQL_DOUBLE(),
682 DBI::SQL_FLOAT(),
683 DBI::SQL_INTEGER(),
684 DBI::SQL_LONGVARBINARY(),
685 DBI::SQL_LONGVARCHAR(),
686 DBI::SQL_NUMERIC(),
687 DBI::SQL_REAL(),
688 DBI::SQL_SMALLINT(),
689 DBI::SQL_TIMESTAMP(),
690 DBI::SQL_TINYINT(),
691 DBI::SQL_VARBINARY(),
692 DBI::SQL_VARCHAR(),
693 DBI::SQL_WCHAR(),
694 DBI::SQL_WVARCHAR(),
695 DBI::SQL_WLONGVARCHAR(),
696 );
697
698 # Get the Provider Types attributes.
699 my @sort_rows;
700 my %ct;
701 my $oLRec =
702 $conn->OpenSchema($ado_consts->{adSchemaProviderTypes});
703 my $lastError = DBD::ADO::errors($conn);
704 die $lastError if $lastError;
705 while(! $oLRec->{EOF}) {
706 # Sort by row
707 my $type_name = $oLRec->{TYPE_NAME}->{Value};
708 my $def;
709 push ( @sort_rows, $def = join( " ",
710 $oLRec->{DATA_TYPE}->Value,
711 $oLRec->{BEST_MATCH}->Value || 0,
712 $oLRec->{IS_LONG}->Value || 0,
713 $oLRec->{IS_FIXEDLENGTH}->Value || 0,
714 $oLRec->{COLUMN_SIZE}->Value,
715 $oLRec->{TYPE_NAME}->Value, ));
716
717 $dbh->trace_msg( "-> data type $def\n");
718 my @out = map { $oLRec->{$_}->Value || '' } @$ado_info;
719 $ct{$type_name} = \@out;
720 $oLRec->MoveNext unless $oLRec->{EOF};
721 }
722 $oLRec->Close () if $oLRec and
723 $oLRec->State & $ado_consts->{adStateOpen};
724 $oLRec = undef;
725 my ($g_ref);
726 for my $x (@sql_type) {
727 # Attempt to work with Long text fields.
728 # However for a Long field, the order by
729 # isn't always the best pick. Loop through
730 # the rows looking for something with a Is Long
731 # mark.
732 my $loc_t =join( "|", @{$local_types{$x}});
733 if ($x == DBI::SQL_LONGVARCHAR()) {
734 $g_ref = qr{^($loc_t)\s\d\s1\s0\s};
735 } elsif ( $x == DBI::SQL_LONGVARBINARY() ) {
736 $g_ref = qr{^($loc_t)\s\d\s1\s0\s};
737 } elsif ( $x == DBI::SQL_VARBINARY()) {
738 $g_ref = qr{^($loc_t)\s1\s\d\s0\s};
739 } elsif ( $x == DBI::SQL_VARCHAR()) {
740 $g_ref = qr{^($loc_t)\s[01]\s0\s0\s};
741 } elsif ( $x == DBI::SQL_WVARCHAR()) {
742 $g_ref = qr{^($loc_t)\s[01]\s0\s0\s};
743 } elsif ( $x == DBI::SQL_WLONGVARCHAR()) {
744 $g_ref = qr{^($loc_t)\s\d\s1\s0\s};
745 } elsif ( $x == DBI::SQL_CHAR()) {
746 $g_ref = qr{^($loc_t)\s\d\s0\s1\s};
747 } elsif ( $x == DBI::SQL_WCHAR()) {
748 $g_ref = qr{^($loc_t)\s\d\s0\s1\s};
749 } else {
750 $g_ref = qr{^($loc_t)\s\d\s\d\s};
751 }
752
753 my @tm =
754 sort { $b cmp $a }
755 grep { /$g_ref/ } @sort_rows;
756 next unless @tm;
757 foreach (@tm) {
758 my ($cc) = m/\d+\s+(\D\w.*)$/;
759 # Look for the record.
760 carp "$cc does not exist in hash\n" unless exists $ct{$cc};
761 my @rec = @{$ct{$cc}};
762 my @mrec = @rec;
763 push( @myType, $x, \@mrec);
764 $dbh->trace_msg( "Changing type " . join( " ", @{$ct{$cc}}) . "$cc $rec[1] -> $x\n");
765 $rec[1] = $x;
766 push(@prov_type_return, \@rec);
767 }
768 }
769
770 return \@prov_type_return;
771 }
772
773 sub OpenSchema {
774 my ($dbh) = @_;
775 return &_open_schema;
776 }
777
778 sub _open_schema {
779 my ($dbh, $var) = @_;
780
781 croak qq{_open_schema called with dbh defined} unless $dbh;
782 return undef unless $ado_consts->{$var};
783
784 my $conn = $dbh->{ado_conn};
785 my $oLRec =
786 $conn->OpenSchema($ado_consts->{$var});
787 my $lastError = DBD::ADO::errors($conn);
788 die $lastError if $lastError;
789 return _rs_sth_prepare( $dbh, $oLRec );
790 }
791
792
793
794 sub FETCH {
795 my ($dbh, $attrib) = @_;
796 # If the attribute contains ado_, return the value.
797 $dbh->trace_msg( "->Fetch: $attrib\n", 3);
798 my $value;
799 if ( exists $dbh->{$attrib} ) {
800 return $dbh->{$attrib};
801 } else {
802 eval {
803 $attrib =~ s/^ado_//;
804 local $Win32::OLE::Warn = 0;
805 $value = $dbh->{ado_conn}->{$attrib};
806 my $lastError = DBD::ADO::errors($dbh->{ado_conn});
807 $lastError = undef if $lastError =~ m/0x80020007/;
808 die "Died on:\n$lastError" if $lastError;
809 };
810 }
811 return $value unless $@;
812 # else pass up to DBI to handle
813 return $dbh->DBD::_::db::FETCH($attrib);
814 }
815
816 sub STORE {
817 my ($dbh, $attrib, $value) = @_;
818 $dbh->trace_msg( "-> Store: $attrib $value\n", 3);
819 # Handle a request to change the AutoCommit value.
820 # If the service provider supports Transaction,
821 # then allow AutoCommit off.
822 if ($attrib eq 'Warn' ) {
823 $Win32::OLE::Warn = $value;
824 }
825 if ($attrib eq 'AutoCommit') {
826 # Return the value is auto commit is not support and
827 # value is not zero. Handles defaults.
828 return $value if $value
829 and not $dbh->{ado_provider_support_auto_commit};
830 # Cause the application to die, user attempting to
831 # change the auto commit value.
832 Carp::croak
833 qq{Provider does not support auto commit: },
834 $dbh->{ado_provider_auto_commit_comments},
835 qq{\n}
836 unless $dbh->{ado_provider_support_auto_commit};
837 return $dbh->{AutoCommit} = _auto_commit($dbh, $value);
838 }
839 # If the attribute contains ado_, return the value.
840 # Determine if this is one our expected parameters.
841 # If the attribute is all lower case, then it is a driver
842 # defined value. If mixed case, then it is a ADO defined value.
843 if ($attrib =~ m/^ado_/ || exists $dbh->{$attrib}) {
844 return $dbh->{$attrib} = $value;
845 } else {
846 unless( $attrib =~ /PrintError|RaiseError/) {
847 eval {
848 local $Win32::OLE::Warn = 0;
849 $dbh->{ado_conn}->{$attrib} = $value;
850 my $lastError = DBD::ADO::errors($dbh->{ado_conn});
851 die $lastError if $lastError;
852 };
853 Carp::carp $@ if $@ and $dbh->FETCH('Warn');
854 return $value unless $@;
855 }
856 }
857 return $dbh->DBD::_::db::STORE($attrib, $value);
858 }
859
860 # Rules for auto commit, if here, the provider supports.
861 # If auto commit is off and new value is on, commit the
862 # current transaction and start a new.
863 # If auto commit is on and new value is off, no immediate effect
864 # is needed.
865 sub _auto_commit {
866 my ($dbh, $value) = @_;
867
868 my $cv = $dbh->FETCH('AutoCommit') || 0;
869 if ($cv eq 0 and $value eq 1) { # Current off, turn on
870 $dbh->commit;
871 return 1;
872 } elsif ($cv eq 1 and $value eq 0) {
873 return 0;
874 }
875 # Didn't change the value.
876 return $cv;
877 }
878 sub DESTROY { }
879
880} # ======= Database Handle ========
881
882
883{ package DBD::ADO::st; # ====== STATEMENT ======
884 $imp_data_size = 0;
885
886 use Win32::OLE::Variant;
887 use Win32::OLE::NLS qw(:DATE);
888 use strict;
889 use vars qw($VT_VAR $VT_DAT $VT_STR $VT_BIN);
890
891 $VT_VAR = VT_VARIANT() | VT_BYREF();
892 $VT_DAT = VT_DATE();
893 $VT_STR = VT_BSTR() | VT_BYREF();
894 $VT_BIN = VT_UI1() | VT_ARRAY();
895
896
897 #$Comm->CreateParameter( "PubID", adVarChar, adParamInput, 4, "0736");
898 # Read a chuck of data from a "long" field.
899 sub blob_read {
900 my ($sth, $cnum, $offset, $lng, $attr) = @_;
901 my $fld = @{$sth->{ado_fields}}[$cnum];
902 my $str = "";
903 if ($fld->Attributes & $ado_consts->{adFldLong}) {
904 $str = $fld->GetChunk( $lng );
905 } else {
906 my $s = $fld->Value;
907 $str = substr($s, $offset, $lng);
908 }
909 return( (defined($str) and length($str))? $str: "" );
910 }
911
912 sub bind_param {
913 my ($sth, $pNum, $val, $attr) = @_;
914 my $conn = $sth->FETCH("ado_conn");
915 my $comm = $sth->FETCH("ado_comm");
916
917 my $param_cnt = $sth->FETCH( 'NUM_OF_PARAMS' );
918 return DBI::set_err($sth, 1,
919 "Bind Parameters called with no parameters defined!")
920 unless $param_cnt;
921
922 return DBI::set_err($sth, 1,
923 "Bind Parameter $pNum outside current range of $param_cnt.")
924 if ($pNum > $param_cnt or $pNum < 1);
925
926 # Get the data type
927 my $type = (ref $attr) ? $attr->{TYPE}: $attr;
928
929 # Convert from ODBC to ADO type
930 my $aType = &_convert_type($type);
931 my $pd;
932
933 my $params = $sth->{ado_params};
934 $params->[$pNum-1] = $val;
935 my $p = $comm->Parameters;
936# Determine if the Parameter is defined.
937 my $i = $p->Item( $pNum -1 );
938 if ($i->{Type} == $ado_consts->{adVarBinary} or
939 $i->{Type} == $ado_consts->{adLongVarBinary}
940 ) {
941# Deal with an image request.
942 my $sz = length $val;
943 #my $pic2 = Variant(VT_UI1|VT_ARRAY,$i->{Size});
944 my $pic = Variant(VT_UI1|VT_ARRAY,$sz + 10);
945 $pic->Put($val);
946 $i->{Value} = $pic;
947 $sth->trace_msg( "->(VarBinary) : ". $i->Size. " ". $i->Type. "\n");
948 } else {
949 $i->{Size} = $val? length $val: $aType->[2];
950 $i->{Value} = $val if $val;
951 $sth->trace_msg( "->(default) : ". $i->Size. " ". $i->Type. "\n");
952 }
953 return 1;
954 }
955
956 sub _convert_type {
957 my $t = shift;
958 for (my $x = 0; $x <= $#myType; $x += 2) {
959 return $myType[$x+1]
960 if ($myType[$x] == $t);
961 }
962 return $ado_consts->{adUnknown};
963 }
964
965 sub execute {
966 my ($sth, @bind_values) = @_;
967 my $comm = $sth->FETCH("ado_comm");
968 my $conn = $sth->FETCH("ado_conn");
969 my $sql = $sth->FETCH("Statement");
970
971 # If a record set is currently defined,
972 # release the set.
973 my $ors = $sth->FETCH("ado_rowset");
974 if (defined $ors) {
975 $ors->Close () if $ors and
976 $ors->State & $ado_consts->{adStateOpen};
977 $sth->STORE(ado_rowset => undef);
978 $ors = undef;
979 }
980
981 my $rows = Variant->new($VT_I4_BYREF, 0);
982 #
983 # If the application is excepting arguments, then
984 # process them here.
985 #
986
987 my $lastError;
988
989 my $rs;
990 my $p = $comm->Parameters;
991 $lastError = DBD::ADO::errors($conn);
992 return DBI::set_err($sth, 1,
993 "Execute Parameters failed 'ADODB.Command': $lastError")
994 if $lastError;
995
996 return DBI::set_err( $sth, 1,
997 "Bind params passed without place holders")
998 if (@bind_values and $p->{Count} == 0);
999
1000 my $x = 0;
1001 for (@bind_values) {
1002 my $i = $p->Item($x);
1003 if ($i->{Type} == $ado_consts->{adVarBinary} and
1004 $i->{Type} == $ado_consts->{adLongVarBinary}
1005 ) {
1006# Deal with an image request.
1007 my $sz = length $_;
1008 #my $pic = Variant(VT_UI1|VT_ARRAY,$i->{Size});
1009 my $pic = Variant(VT_UI1|VT_ARRAY,$sz + 10);
1010 $pic->Put($_);
1011 $i->{Value} = $pic;
1012 } else {
1013 $i->{Size} = length $_;
1014 $i->{Value} = $_;
1015 }
1016 $sth->trace_msg("-> Bind parameter (execute): " . $i->Type . "\n");
1017 $x++;
1018 }
1019
1020 $x = 0;
1021 $sth->trace_msg( "-> Parameter count: " . $p->{Count} . "\n");
1022 while( $x < $p->{Count} ) {
1023 my $params = $sth->{ado_params};
1024 $sth->trace_msg( "->> Parameter $x: " . $p->Item($x)->{Value} . "\n");
1025 $sth->trace_msg( "->> Parameter $x: " . $params->[$x] . "\n");
1026 $x++;
1027 }
1028 $rs = $comm->Execute($rows);
1029
1030 $lastError = DBD::ADO::errors($conn);
1031 return DBI::set_err( $sth, 1,
1032 "Can't execute statement '$sql': $lastError")
1033 if $lastError;
1034
1035 $sth->{ado_rowset} = $rs;
1036 $sth->{ado_fields} = my $ado_fields = [ Win32::OLE::in($rs->Fields) ];
1037 my $num_of_fields = @$ado_fields;
1038
1039 if ($num_of_fields == 0) { # assume non-select statement
1040 # If the AutoCommit is on, Commit current transaction.
1041 $conn->CommitTrans
1042 if $sth->{ado_dbh}->{AutoCommit}
1043 and $sth->{ado_dbh}->{ado_provider_support_auto_commit};
1044 $lastError = DBD::ADO::errors($conn);
1045 return DBI::set_err( $sth, 1,
1046 "Execute: Commit failed: $lastError")
1047 if $lastError;
1048 my $c = ($rows->Value == 0 ? qq{0E0} : $rows->Value);
1049 $sth->STORE('rows', $c);
1050 return ( $c );
1051 }
1052
1053 my $nof = $sth->FETCH('NUM_OF_FIELDS');
1054 $sth->STORE(Active => 1);
1055 $sth->STORE('NUM_OF_FIELDS' => $num_of_fields)
1056 unless ($nof == $num_of_fields);
1057 $sth->{NAME} = [ map { $_->Name } @$ado_fields ];
1058 $sth->{TYPE} = [ map { $_->Type } @$ado_fields ];
1059 $sth->{PRECISION} = [ map { $_->Precision } @$ado_fields ];
1060 $sth->{SCALE} = [ map { $_->NumericScale } @$ado_fields ];
1061 $sth->{NULLABLE} = [ map { 1 } @$ado_fields ];
1062 $sth->{CursorName} = undef;
1063 #$sth->{Statement} = $sql;
1064 $sth->{Statement} = $rs->Source;
1065 $sth->{RowsInCache} = undef;
1066 $sth->STORE( 'rows', $rows->Value );
1067
1068 # We need to return a true value for a successful select
1069 # -1 means total row count unavailable
1070 return $rows->Value;
1071 }
1072
1073
1074
1075 sub fetchrow_arrayref {
1076 my ($sth) = @_;
1077 my $rs = $sth->FETCH('ado_rowset');
1078
1079 return undef unless $sth->FETCH('Active');
1080 return undef unless $rs;
1081 return undef if $rs->EOF;
1082
1083 # required to not move from the current row
1084 # until the next fetch is called. blob_read
1085 # reads the next record without this check.
1086 if ($sth->{ado_current_row_count} > 0) {
1087 $rs->MoveNext; # to check for errors and record for next itteration
1088 }
1089 return undef if $rs->{EOF};
1090
1091 my $lastError = DBD::ADO::errors($sth->{ado_conn});
1092 return DBI::set_err( $sth, 1,
1093 "Fetch failed: $lastError")
1094 if $lastError;
1095
1096
1097 my $ado_fields = $sth->{ado_fields};
1098
1099 my $row =
1100 [ map { $rs->Fields($_->{Name})->{Value} } @$ado_fields ];
1101 # Jan Dubois jand@activestate.com addition to handle changes
1102 # in Win32::OLE return of Variant types of data.
1103 foreach (@$row) {
1104 $_ = $_->As(VT_BSTR)
1105 if UNIVERSAL::isa($_, 'Win32::OLE::Variant');
1106 }
1107 if ($sth->FETCH('ChopBlanks')) {
1108 map { $_ =~ s/\s+$//; } @$row;
1109 }
1110
1111
1112 $sth->{ado_current_row_count}++;
1113 return $sth->_set_fbav($row);
1114 }
1115 *fetch = \&fetchrow_arrayref;
1116
1117
1118 sub finish {
1119 my ($sth) = @_;
1120 my $rs = $sth->FETCH('ado_rowset');
1121 $rs->Close () if $rs and
1122 $rs->State & $ado_consts->{adStateOpen};
1123 $sth->STORE(ado_rowset => undef);
1124 return $sth->STORE(Active => 0);
1125 }
1126
1127 sub FETCH {
1128 my ($sth, $attrib) = @_;
1129 # would normally validate and only fetch known attributes
1130 # else pass up to DBI to handle
1131 if ( exists $sth->{$attrib} ) {
1132 return $sth->{$attrib};
1133 }
1134 return $sth->DBD::_::dr::FETCH($attrib);
1135 }
1136
1137 sub STORE {
1138 my ($sth, $attrib, $value) = @_;
1139 # would normally validate and only store known attributes
1140 if ( exists $sth->{$attrib} ) {
1141 return $sth->{$attrib} = $value;
1142 }
1143 # else pass up to DBI to handle
1144 return $sth->DBD::_::dr::STORE($attrib, $value);
1145 }
1146
1147 sub ColAttributes { # maps to SQLColAttributes
1148 my ($sth, $colno, $desctype) = @_;
1149 }
1150
1151
1152 sub DESTROY {
1153 my ($sth) = @_;
1154 my $rs = $sth->{ado_rowset};
1155 $sth->trace_msg( "<- destroy statement handler\n", 1 );
1156 $rs->Close ()
1157 if ($rs
1158 and UNIVERSAL::isa($rs, 'Win32::OLE')
1159 and ($rs->State != $ado_consts->{adStateClosed}));
1160 $rs = undef;
1161 $sth->{ado_rowset} = undef;
1162 $sth->STORE(ado_rowset => undef);
1163 $sth->STORE(Active => 0);
1164 undef($sth);
1165 }
1166}
1167
11681;
1169__END__
1170
1171=head1 NAME
1172
1173DBD::ADO - A DBI driver for Microsoft ADO (Active Data Objects)
1174
1175=head1 SYNOPSIS
1176
1177 use DBI;
1178
1179 $dbh = DBI->connect("dbi:ADO:dsn", $user, $passwd);
1180
1181 Options in the connect string:
1182 dbi:ADO:dsn;CommandTimeout=60 (your number)
1183 dbi:ADO:dsn;ConnectTimeout=60 (your number)
1184 or include both ConnectTimeout and CommandTimeout.
1185
1186 The dsn may be a standard ODBC dsn or a dsn-less.
1187 See the ADO documentation for more information on
1188 the dsn-less connection.
1189
1190 # See the DBI module documentation for full details
1191
1192=head1 DESCRIPTION
1193
1194The DBD::ADO module supports ADO access on a Win32 machine.
1195DBD::ADO is written to support the standard DBI interface to
1196data sources.
1197
1198=head1 Connection
1199
1200 $dbh = DBI->connect("dbi:ADO:dsn", $user, $passwd, $attribs);
1201
1202 Connection supports dsn and dsn-less calls.
1203
1204 $dbh = DBI->connect( "dbi:ADO:File Name=oracle.udl",
1205 $user, $passwd, {RaiseError => [0|1], PrintError => [0|1],
1206 AutoCommit => [0|1]});
1207
1208 In addition the following attributes may be set in the connect string:
1209 Attributes
1210 CommandTimeout
1211 ConnectionString
1212 ConnectionTimeout
1213 CursorLocation
1214 DefaultDatabase
1215 IsolationLevel
1216 Mode
1217 Provider
1218
1219 WARNING: The application is responsible for passing the correct
1220 information when setting any of these attributes.
1221
1222
1223=head1 Functions support
1224
1225 Using the standard DBI function call
1226 $dbh->func( arguments, 'function name')
1227
1228 You may access the following functions: (case sensitave)
1229 OpenSchema
1230
1231 All functions return a valid statement handle upon success.
1232
1233 OpenSchema supports the following arguments:
1234 Any valid ADO Schema name such as
1235 adSchemaCatalogs
1236 adSchemaIndexes
1237 adSchemaProviderTypes
1238
1239 example:
1240 my $sth = $dbh->func( 'adSchemaProviderTypes', 'OpenSchema' );
1241
1242=head1 Enhanced DBI Methods
1243
1244
1245=head2 table_info
1246
1247B<Warning:> This method is experimental and may change or disappear.
1248
1249 $sth = $dbh->table_info(\%attr);
1250
1251 $sth = $dbh->table_info({
1252 TABLE_TYPE => 'VIEW',
1253 ADO_Columns => 1,
1254 Trim_Catalog => 0,
1255 Filter => q{TABLE_NAME LIKE 'C%'},
1256 });
1257
1258Returns an active statement handle that can be used to fetch
1259information about tables and views that exist in the database.
1260By default the handle contains the columns described in the DBI documentation:
1261
1262 TABLE_CAT, TABLE_SCHEM, TABLE_NAME, TABLE_TYPE, REMARKS
1263
1264=item B<ADO_Columns>
1265
1266Additional ADO-only fields will be included if the ADO_Columns attribute
1267is set to true:
1268
1269 %attr = (ADO_Columns => 1);
1270
1271=item B<Trim_Catalog>
1272
1273Some ADO providers include path info in the TABLE_CAT column.
1274This information will be trimmed if the Trim_Catalog attribute is set to true:
1275
1276 %attr = (Trim_Catalog => 1);
1277
1278=item B<Criteria>
1279
1280The ADO driver allows column criteria to be specified. In this way the
1281record set can be restricted, for example, to only include tables of type 'VIEW':
1282
1283 %attr = (TABLE_TYPE => 'VIEW')
1284
1285You can add criteria for any of the following columns:
1286
1287 TABLE_CAT, TABLE_SCHEM, TABLE_NAME, TABLE_TYPE
1288
1289=item B<Filter>
1290
1291The ADO driver also allows the recordset to be filtered on a Criteria string:
1292a string made up of one or more individual clauses concatenated with AND or OR operators.
1293
1294 %attr = (Filter => q{TABLE_TYPE LIKE 'SYSTEM%'})
1295
1296The criteria string is made up of clauses in the form FieldName-Operator-Value.
1297This is more flexible than using column criteria in that the filter allows a number of operators:
1298
1299 <, >, <=, >=, <>, =, or LIKE
1300
1301The Fieldname must be one of the ADO 'TABLES Rowset' column names:
1302
1303 TABLE_CATALOG, TABLE_SCHEMA, TABLE_NAME, TABLE_TYPE, DESCRIPTION,
1304 TABLE_GUID, TABLE_PROPID, DATE_CREATED, DATE_MODIFIED
1305
1306Value is the value with which you will compare the field values
1307(for example, 'Smith', #8/24/95#, 12.345, or $50.00).
1308Use single quotes with strings and pound signs (#) with dates.
1309For numbers, you can use decimal points, dollar signs, and scientific notation.
1310If Operator is LIKE, Value can use wildcards.
1311Only the asterisk (*) and percent sign (%) wild cards are allowed,
1312and they must be the last character in the string. Value cannot be null.
1313
1314=back
1315
1316=head2 tables
1317
1318B<Warning:> This method is experimental and may change or disappear.
1319
1320 @names = $dbh->tables(\%attr);
1321
1322Returns a list of table and view names.
1323Accepts any of the attributes described in the L<table_info> method:
1324
1325 @names = $dbh->tables({ TABLE_TYPE => 'VIEW' });
1326
1327=back
1328
1329=head1 Warnings
1330
1331 Support for type_info_all is supported, however, you're not using
1332 a true OLE DB provider (using the MS OLE DB -> ODBC), the first
1333 hash may not be the "best" solution for the data type.
1334 adSchemaProviderTypes does provide for a "best match" column, however
1335 the MS OLE DB -> ODBC provider does not support the best match.
1336 Currently the types are sorted by DATA_TYPE BEST_MATCH IS_LONG ...
1337
1338=head1 ADO
1339
1340It is strongly recommended that you use the latest version of ADO
1341(2.1 at the time this was written). You can download it from:
1342
1343 http://www.microsoft.com/Data/download.htm
1344
1345=head1 AUTHORS
1346
1347Phlip and Tim Bunce. With many thanks to Jan Dubois, Jochen Wiedmann
1348and Thomas Lowery for additions, debuggery and general help.
1349
1350=head1 SEE ALSO
1351
1352ADO Reference book: ADO 2.0 Programmer's Reference, David Sussman and
1353Alex Homer, Wrox, ISBN 1-861001-83-5. If there's anything better please
1354let me know.
1355
1356http://www.able-consulting.com/tech.htm
1357
1358=cut
Full OpenSPARC design & verification tarball including full HDL.