| [ Index ] |
PHP Cross Reference of Unnamed Project |
[Summary view] [Print] [Text view]
1 ######################################################################## 2 package # hide from PAUSE 3 DBI; 4 # vim: ts=8:sw=4 5 ######################################################################## 6 # 7 # Copyright (c) 2002,2003 Tim Bunce Ireland. 8 # 9 # See COPYRIGHT section in DBI.pm for usage and distribution rights. 10 # 11 ######################################################################## 12 # 13 # Please send patches and bug reports to 14 # 15 # Jeff Zucker <jeff@vpservices.com> with cc to <dbi-dev@perl.org> 16 # 17 ######################################################################## 18 19 use strict; 20 use Carp; 21 require Symbol; 22 23 require utf8; 24 *utf8::is_utf8 = sub { # hack for perl 5.6 25 require bytes; 26 return unless defined $_[0]; 27 return !(length($_[0]) == bytes::length($_[0])) 28 } unless defined &utf8::is_utf8; 29 30 $DBI::PurePerl = $ENV{DBI_PUREPERL} || 1; 31 $DBI::PurePerl::VERSION = sprintf("2.%06d", q$Revision: 11372 $ =~ /(\d+)/o); 32 33 $DBI::neat_maxlen ||= 400; 34 35 $DBI::tfh = Symbol::gensym(); 36 open $DBI::tfh, ">&STDERR" or warn "Can't dup STDERR: $!"; 37 select( (select($DBI::tfh), $| = 1)[0] ); # autoflush 38 39 # check for weaken support, used by ChildHandles 40 my $HAS_WEAKEN = eval { 41 require Scalar::Util; 42 # this will croak() if this Scalar::Util doesn't have a working weaken(). 43 Scalar::Util::weaken( my $test = [] ); 44 1; 45 }; 46 47 %DBI::last_method_except = map { $_=>1 } qw(DESTROY _set_fbav set_err); 48 49 use constant SQL_ALL_TYPES => 0; 50 use constant SQL_ARRAY => 50; 51 use constant SQL_ARRAY_LOCATOR => 51; 52 use constant SQL_BIGINT => (-5); 53 use constant SQL_BINARY => (-2); 54 use constant SQL_BIT => (-7); 55 use constant SQL_BLOB => 30; 56 use constant SQL_BLOB_LOCATOR => 31; 57 use constant SQL_BOOLEAN => 16; 58 use constant SQL_CHAR => 1; 59 use constant SQL_CLOB => 40; 60 use constant SQL_CLOB_LOCATOR => 41; 61 use constant SQL_DATE => 9; 62 use constant SQL_DATETIME => 9; 63 use constant SQL_DECIMAL => 3; 64 use constant SQL_DOUBLE => 8; 65 use constant SQL_FLOAT => 6; 66 use constant SQL_GUID => (-11); 67 use constant SQL_INTEGER => 4; 68 use constant SQL_INTERVAL => 10; 69 use constant SQL_INTERVAL_DAY => 103; 70 use constant SQL_INTERVAL_DAY_TO_HOUR => 108; 71 use constant SQL_INTERVAL_DAY_TO_MINUTE => 109; 72 use constant SQL_INTERVAL_DAY_TO_SECOND => 110; 73 use constant SQL_INTERVAL_HOUR => 104; 74 use constant SQL_INTERVAL_HOUR_TO_MINUTE => 111; 75 use constant SQL_INTERVAL_HOUR_TO_SECOND => 112; 76 use constant SQL_INTERVAL_MINUTE => 105; 77 use constant SQL_INTERVAL_MINUTE_TO_SECOND => 113; 78 use constant SQL_INTERVAL_MONTH => 102; 79 use constant SQL_INTERVAL_SECOND => 106; 80 use constant SQL_INTERVAL_YEAR => 101; 81 use constant SQL_INTERVAL_YEAR_TO_MONTH => 107; 82 use constant SQL_LONGVARBINARY => (-4); 83 use constant SQL_LONGVARCHAR => (-1); 84 use constant SQL_MULTISET => 55; 85 use constant SQL_MULTISET_LOCATOR => 56; 86 use constant SQL_NUMERIC => 2; 87 use constant SQL_REAL => 7; 88 use constant SQL_REF => 20; 89 use constant SQL_ROW => 19; 90 use constant SQL_SMALLINT => 5; 91 use constant SQL_TIME => 10; 92 use constant SQL_TIMESTAMP => 11; 93 use constant SQL_TINYINT => (-6); 94 use constant SQL_TYPE_DATE => 91; 95 use constant SQL_TYPE_TIME => 92; 96 use constant SQL_TYPE_TIMESTAMP => 93; 97 use constant SQL_TYPE_TIMESTAMP_WITH_TIMEZONE => 95; 98 use constant SQL_TYPE_TIME_WITH_TIMEZONE => 94; 99 use constant SQL_UDT => 17; 100 use constant SQL_UDT_LOCATOR => 18; 101 use constant SQL_UNKNOWN_TYPE => 0; 102 use constant SQL_VARBINARY => (-3); 103 use constant SQL_VARCHAR => 12; 104 use constant SQL_WCHAR => (-8); 105 use constant SQL_WLONGVARCHAR => (-10); 106 use constant SQL_WVARCHAR => (-9); 107 108 # for Cursor types 109 use constant SQL_CURSOR_FORWARD_ONLY => 0; 110 use constant SQL_CURSOR_KEYSET_DRIVEN => 1; 111 use constant SQL_CURSOR_DYNAMIC => 2; 112 use constant SQL_CURSOR_STATIC => 3; 113 use constant SQL_CURSOR_TYPE_DEFAULT => SQL_CURSOR_FORWARD_ONLY; 114 115 use constant IMA_HAS_USAGE => 0x0001; #/* check parameter usage */ 116 use constant IMA_FUNC_REDIRECT => 0x0002; #/* is $h->func(..., "method")*/ 117 use constant IMA_KEEP_ERR => 0x0004; #/* don't reset err & errstr */ 118 use constant IMA_KEEP_ERR_SUB => 0x0008; #/* '' if in nested call */ 119 use constant IMA_NO_TAINT_IN => 0x0010; #/* don't check for tainted args*/ 120 use constant IMA_NO_TAINT_OUT => 0x0020; #/* don't taint results */ 121 use constant IMA_COPY_UP_STMT => 0x0040; #/* copy sth Statement to dbh */ 122 use constant IMA_END_WORK => 0x0080; #/* set on commit & rollback */ 123 use constant IMA_STUB => 0x0100; #/* donothing eg $dbh->connected */ 124 use constant IMA_CLEAR_STMT => 0x0200; #/* clear Statement before call */ 125 use constant IMA_UNRELATED_TO_STMT=> 0x0400; #/* profile as empty Statement */ 126 use constant IMA_NOT_FOUND_OKAY => 0x0800; #/* not error if not found */ 127 use constant IMA_EXECUTE => 0x1000; #/* do/execute: DBIcf_Executed */ 128 use constant IMA_SHOW_ERR_STMT => 0x2000; #/* dbh meth relates to Statement*/ 129 use constant IMA_HIDE_ERR_PARAMVALUES => 0x4000; #/* ParamValues are not relevant */ 130 use constant IMA_IS_FACTORY => 0x8000; #/* new h ie connect & prepare */ 131 use constant IMA_CLEAR_CACHED_KIDS => 0x10000; #/* clear CachedKids before call */ 132 133 my %is_flag_attribute = map {$_ =>1 } qw( 134 Active 135 AutoCommit 136 ChopBlanks 137 CompatMode 138 Executed 139 Taint 140 TaintIn 141 TaintOut 142 InactiveDestroy 143 LongTruncOk 144 MultiThread 145 PrintError 146 PrintWarn 147 RaiseError 148 ShowErrorStatement 149 Warn 150 ); 151 my %is_valid_attribute = map {$_ =>1 } (keys %is_flag_attribute, qw( 152 ActiveKids 153 Attribution 154 BegunWork 155 CachedKids 156 Callbacks 157 ChildHandles 158 CursorName 159 Database 160 DebugDispatch 161 Driver 162 Err 163 Errstr 164 ErrCount 165 FetchHashKeyName 166 HandleError 167 HandleSetErr 168 ImplementorClass 169 Kids 170 LongReadLen 171 NAME NAME_uc NAME_lc NAME_uc_hash NAME_lc_hash 172 NULLABLE 173 NUM_OF_FIELDS 174 NUM_OF_PARAMS 175 Name 176 PRECISION 177 ParamValues 178 Profile 179 Provider 180 ReadOnly 181 RootClass 182 RowCacheSize 183 RowsInCache 184 SCALE 185 State 186 Statement 187 TYPE 188 Type 189 TraceLevel 190 Username 191 Version 192 )); 193 194 sub valid_attribute { 195 my $attr = shift; 196 return 1 if $is_valid_attribute{$attr}; 197 return 1 if $attr =~ m/^[a-z]/; # starts with lowercase letter 198 return 0 199 } 200 201 my $initial_setup; 202 sub initial_setup { 203 $initial_setup = 1; 204 print $DBI::tfh __FILE__ . " version " . $DBI::PurePerl::VERSION . "\n" 205 if $DBI::dbi_debug & 0xF; 206 untie $DBI::err; 207 untie $DBI::errstr; 208 untie $DBI::state; 209 untie $DBI::rows; 210 #tie $DBI::lasth, 'DBI::var', '!lasth'; # special case: return boolean 211 } 212 213 sub _install_method { 214 my ( $caller, $method, $from, $param_hash ) = @_; 215 initial_setup() unless $initial_setup; 216 217 my ($class, $method_name) = $method =~ /^[^:]+::(.+)::(.+)$/; 218 my $bitmask = $param_hash->{'O'} || 0; 219 my @pre_call_frag; 220 221 return if $method_name eq 'can'; 222 223 push @pre_call_frag, q{ 224 return if $h_inner; # ignore DESTROY for outer handle 225 # copy err/errstr/state up to driver so $DBI::err etc still work 226 if ($h->{err} and my $drh = $h->{Driver}) { 227 $drh->{$_} = $h->{$_} for ('err','errstr','state'); 228 } 229 } if $method_name eq 'DESTROY'; 230 231 push @pre_call_frag, q{ 232 return $h->{$_[0]} if exists $h->{$_[0]}; 233 } if $method_name eq 'FETCH' && !exists $ENV{DBI_TRACE}; # XXX ? 234 235 push @pre_call_frag, "return;" 236 if IMA_STUB & $bitmask; 237 238 push @pre_call_frag, q{ 239 $method_name = pop @_; 240 } if IMA_FUNC_REDIRECT & $bitmask; 241 242 push @pre_call_frag, q{ 243 my $parent_dbh = $h->{Database}; 244 } if (IMA_COPY_UP_STMT|IMA_EXECUTE) & $bitmask; 245 246 push @pre_call_frag, q{ 247 warn "No Database set for $h on $method_name!" unless $parent_dbh; # eg proxy problems 248 $parent_dbh->{Statement} = $h->{Statement} if $parent_dbh; 249 } if IMA_COPY_UP_STMT & $bitmask; 250 251 push @pre_call_frag, q{ 252 $h->{Executed} = 1; 253 $parent_dbh->{Executed} = 1 if $parent_dbh; 254 } if IMA_EXECUTE & $bitmask; 255 256 push @pre_call_frag, q{ 257 %{ $h->{CachedKids} } = () if $h->{CachedKids}; 258 } if IMA_CLEAR_CACHED_KIDS & $bitmask; 259 260 if (IMA_KEEP_ERR & $bitmask) { 261 push @pre_call_frag, q{ 262 my $keep_error = 1; 263 }; 264 } 265 else { 266 my $ke_init = (IMA_KEEP_ERR_SUB & $bitmask) 267 ? q{= $h->{dbi_pp_parent}->{dbi_pp_call_depth} } 268 : ""; 269 push @pre_call_frag, qq{ 270 my \$keep_error $ke_init; 271 }; 272 my $keep_error_code = q{ 273 #warn "$method_name cleared err"; 274 $h->{err} = $DBI::err = undef; 275 $h->{errstr} = $DBI::errstr = undef; 276 $h->{state} = $DBI::state = ''; 277 }; 278 $keep_error_code = q{ 279 printf $DBI::tfh " !! %s: %s CLEARED by call to }.$method_name.q{ method\n". 280 $h->{err}, $h->{err} 281 if defined $h->{err} && $DBI::dbi_debug & 0xF; 282 }. $keep_error_code 283 if exists $ENV{DBI_TRACE}; 284 push @pre_call_frag, ($ke_init) 285 ? qq{ unless (\$keep_error) { $keep_error_code }} 286 : $keep_error_code 287 unless $method_name eq 'set_err'; 288 } 289 290 push @pre_call_frag, q{ 291 my $ErrCount = $h->{ErrCount}; 292 }; 293 294 push @pre_call_frag, q{ 295 if (($DBI::dbi_debug & 0xF) >= 2) { 296 local $^W; 297 my $args = join " ", map { DBI::neat($_) } ($h, @_); 298 printf $DBI::tfh " > $method_name in $imp ($args) [$@]\n"; 299 } 300 } if exists $ENV{DBI_TRACE}; # note use of 'exists' 301 302 push @pre_call_frag, q{ 303 $h->{'dbi_pp_last_method'} = $method_name; 304 } unless exists $DBI::last_method_except{$method_name}; 305 306 # --- post method call code fragments --- 307 my @post_call_frag; 308 309 push @post_call_frag, q{ 310 if (my $trace_level = ($DBI::dbi_debug & 0xF)) { 311 if ($h->{err}) { 312 printf $DBI::tfh " !! ERROR: %s %s\n", $h->{err}, $h->{errstr}; 313 } 314 my $ret = join " ", map { DBI::neat($_) } @ret; 315 my $msg = " < $method_name= $ret"; 316 $msg = ($trace_level >= 2) ? Carp::shortmess($msg) : "$msg\n"; 317 print $DBI::tfh $msg; 318 } 319 } if exists $ENV{DBI_TRACE}; # note use of exists 320 321 push @post_call_frag, q{ 322 $h->{Executed} = 0; 323 if ($h->{BegunWork}) { 324 $h->{BegunWork} = 0; 325 $h->{AutoCommit} = 1; 326 } 327 } if IMA_END_WORK & $bitmask; 328 329 push @post_call_frag, q{ 330 if ( ref $ret[0] and 331 UNIVERSAL::isa($ret[0], 'DBI::_::common') and 332 defined( (my $h_new = tied(%{$ret[0]})||$ret[0])->{err} ) 333 ) { 334 # copy up info/warn to drh so PrintWarn on connect is triggered 335 $h->set_err($h_new->{err}, $h_new->{errstr}, $h_new->{state}) 336 } 337 } if IMA_IS_FACTORY & $bitmask; 338 339 push @post_call_frag, q{ 340 $keep_error = 0 if $keep_error && $h->{ErrCount} > $ErrCount; 341 342 $DBI::err = $h->{err}; 343 $DBI::errstr = $h->{errstr}; 344 $DBI::state = $h->{state}; 345 346 if ( !$keep_error 347 && defined(my $err = $h->{err}) 348 && ($call_depth <= 1 && !$h->{dbi_pp_parent}{dbi_pp_call_depth}) 349 ) { 350 351 my($pe,$pw,$re,$he) = @{$h}{qw(PrintError PrintWarn RaiseError HandleError)}; 352 my $msg; 353 354 if ($err && ($pe || $re || $he) # error 355 or (!$err && length($err) && $pw) # warning 356 ) { 357 my $last = ($DBI::last_method_except{$method_name}) 358 ? ($h->{'dbi_pp_last_method'}||$method_name) : $method_name; 359 my $errstr = $h->{errstr} || $DBI::errstr || $err || ''; 360 my $msg = sprintf "%s %s %s: %s", $imp, $last, 361 ($err eq "0") ? "warning" : "failed", $errstr; 362 363 if ($h->{'ShowErrorStatement'} and my $Statement = $h->{Statement}) { 364 $msg .= ' [for Statement "' . $Statement; 365 if (my $ParamValues = $h->FETCH('ParamValues')) { 366 $msg .= '" with ParamValues: '; 367 $msg .= DBI::_concat_hash_sorted($ParamValues, "=", ", ", 1, undef); 368 $msg .= "]"; 369 } 370 else { 371 $msg .= '"]'; 372 } 373 } 374 if ($err eq "0") { # is 'warning' (not info) 375 carp $msg if $pw; 376 } 377 else { 378 my $do_croak = 1; 379 if (my $subsub = $h->{'HandleError'}) { 380 $do_croak = 0 if &$subsub($msg,$h,$ret[0]); 381 } 382 if ($do_croak) { 383 printf $DBI::tfh " $method_name has failed ($h->{PrintError},$h->{RaiseError})\n" 384 if ($DBI::dbi_debug & 0xF) >= 4; 385 carp $msg if $pe; 386 die $msg if $h->{RaiseError}; 387 } 388 } 389 } 390 } 391 }; 392 393 394 my $method_code = q[ 395 sub { 396 my $h = shift; 397 my $h_inner = tied(%$h); 398 $h = $h_inner if $h_inner; 399 400 my $imp; 401 if ($method_name eq 'DESTROY') { 402 # during global destruction, $h->{...} can trigger "Can't call FETCH on an undef value" 403 # implying that tied() above lied to us, so we need to use eval 404 local $@; # protect $@ 405 $imp = eval { $h->{"ImplementorClass"} } or return; # probably global destruction 406 } 407 else { 408 $imp = $h->{"ImplementorClass"} or do { 409 warn "Can't call $method_name method on handle $h after take_imp_data()\n" 410 if not exists $h->{Active}; 411 return; # or, more likely, global destruction 412 }; 413 } 414 415 ] . join("\n", '', @pre_call_frag, '') . q[ 416 417 my $call_depth = $h->{'dbi_pp_call_depth'} + 1; 418 local ($h->{'dbi_pp_call_depth'}) = $call_depth; 419 420 my @ret; 421 my $sub = $imp->can($method_name); 422 if (!$sub and IMA_FUNC_REDIRECT & $bitmask and $sub = $imp->can('func')) { 423 push @_, $method_name; 424 } 425 if ($sub) { 426 (wantarray) ? (@ret = &$sub($h,@_)) : (@ret = scalar &$sub($h,@_)); 427 } 428 else { 429 # XXX could try explicit fallback to $imp->can('AUTOLOAD') etc 430 # which would then let Multiplex pass PurePerl tests, but some 431 # hook into install_method may be better. 432 croak "Can't locate DBI object method \"$method_name\" via package \"$imp\"" 433 if ] . ((IMA_NOT_FOUND_OKAY & $bitmask) ? 0 : 1) . q[; 434 } 435 436 ] . join("\n", '', @post_call_frag, '') . q[ 437 438 return (wantarray) ? @ret : $ret[0]; 439 } 440 ]; 441 no strict qw(refs); 442 my $code_ref = eval qq{#line 1 "DBI::PurePerl $method"\n$method_code}; 443 warn "$@\n$method_code\n" if $@; 444 die "$@\n$method_code\n" if $@; 445 *$method = $code_ref; 446 if (0 && $method =~ /\b(connect|FETCH)\b/) { # debuging tool 447 my $l=0; # show line-numbered code for method 448 warn "*$method code:\n".join("\n", map { ++$l.": $_" } split/\n/,$method_code); 449 } 450 } 451 452 453 sub _new_handle { 454 my ($class, $parent, $attr, $imp_data, $imp_class) = @_; 455 456 DBI->trace_msg(" New $class (for $imp_class, parent=$parent, id=".($imp_data||'').")\n") 457 if $DBI::dbi_debug >= 3; 458 459 $attr->{ImplementorClass} = $imp_class 460 or Carp::croak("_new_handle($class): 'ImplementorClass' attribute not given"); 461 462 # This is how we create a DBI style Object: 463 # %outer gets tied to %$attr (which becomes the 'inner' handle) 464 my (%outer, $i, $h); 465 $i = tie %outer, $class, $attr; # ref to inner hash (for driver) 466 $h = bless \%outer, $class; # ref to outer hash (for application) 467 # The above tie and bless may migrate down into _setup_handle()... 468 # Now add magic so DBI method dispatch works 469 DBI::_setup_handle($h, $imp_class, $parent, $imp_data); 470 return $h unless wantarray; 471 return ($h, $i); 472 } 473 474 sub _setup_handle { 475 my($h, $imp_class, $parent, $imp_data) = @_; 476 my $h_inner = tied(%$h) || $h; 477 if (($DBI::dbi_debug & 0xF) >= 4) { 478 local $^W; 479 print $DBI::tfh " _setup_handle(@_)\n"; 480 } 481 $h_inner->{"imp_data"} = $imp_data; 482 $h_inner->{"ImplementorClass"} = $imp_class; 483 $h_inner->{"Kids"} = $h_inner->{"ActiveKids"} = 0; # XXX not maintained 484 if ($parent) { 485 foreach (qw( 486 RaiseError PrintError PrintWarn HandleError HandleSetErr 487 Warn LongTruncOk ChopBlanks AutoCommit ReadOnly 488 ShowErrorStatement FetchHashKeyName LongReadLen CompatMode 489 )) { 490 $h_inner->{$_} = $parent->{$_} 491 if exists $parent->{$_} && !exists $h_inner->{$_}; 492 } 493 if (ref($parent) =~ /::db$/) { 494 $h_inner->{Database} = $parent; 495 $parent->{Statement} = $h_inner->{Statement}; 496 $h_inner->{NUM_OF_PARAMS} = 0; 497 } 498 elsif (ref($parent) =~ /::dr$/){ 499 $h_inner->{Driver} = $parent; 500 } 501 $h_inner->{dbi_pp_parent} = $parent; 502 503 # add to the parent's ChildHandles 504 if ($HAS_WEAKEN) { 505 my $handles = $parent->{ChildHandles} ||= []; 506 push @$handles, $h; 507 Scalar::Util::weaken($handles->[-1]); 508 # purge destroyed handles occasionally 509 if (@$handles % 120 == 0) { 510 @$handles = grep { defined } @$handles; 511 Scalar::Util::weaken($_) for @$handles; # re-weaken after grep 512 } 513 } 514 } 515 else { # setting up a driver handle 516 $h_inner->{Warn} = 1; 517 $h_inner->{PrintWarn} = $^W; 518 $h_inner->{AutoCommit} = 1; 519 $h_inner->{TraceLevel} = 0; 520 $h_inner->{CompatMode} = (1==0); 521 $h_inner->{FetchHashKeyName} ||= 'NAME'; 522 $h_inner->{LongReadLen} ||= 80; 523 $h_inner->{ChildHandles} ||= [] if $HAS_WEAKEN; 524 $h_inner->{Type} ||= 'dr'; 525 } 526 $h_inner->{"dbi_pp_call_depth"} = 0; 527 $h_inner->{ErrCount} = 0; 528 $h_inner->{Active} = 1; 529 } 530 531 sub constant { 532 warn "constant(@_) called unexpectedly"; return undef; 533 } 534 535 sub trace { 536 my ($h, $level, $file) = @_; 537 $level = $h->parse_trace_flags($level) 538 if defined $level and !DBI::looks_like_number($level); 539 my $old_level = $DBI::dbi_debug; 540 _set_trace_file($file) if $level; 541 if (defined $level) { 542 $DBI::dbi_debug = $level; 543 print $DBI::tfh " DBI $DBI::VERSION (PurePerl) " 544 . "dispatch trace level set to $DBI::dbi_debug\n" 545 if $DBI::dbi_debug & 0xF; 546 } 547 _set_trace_file($file) if !$level; 548 return $old_level; 549 } 550 551 sub _set_trace_file { 552 my ($file) = @_; 553 # 554 # DAA add support for filehandle inputs 555 # 556 # DAA required to avoid closing a prior fh trace() 557 $DBI::tfh = undef unless $DBI::tfh_needs_close; 558 559 if (ref $file eq 'GLOB') { 560 $DBI::tfh = $file; 561 select((select($DBI::tfh), $| = 1)[0]); 562 $DBI::tfh_needs_close = 0; 563 return 1; 564 } 565 $DBI::tfh_needs_close = 1; 566 if (!$file || $file eq 'STDERR') { 567 open $DBI::tfh, ">&STDERR" or carp "Can't dup STDERR: $!"; 568 } 569 elsif ($file eq 'STDOUT') { 570 open $DBI::tfh, ">&STDOUT" or carp "Can't dup STDOUT: $!"; 571 } 572 else { 573 open $DBI::tfh, ">>$file" or carp "Can't open $file: $!"; 574 } 575 select((select($DBI::tfh), $| = 1)[0]); 576 return 1; 577 } 578 sub _get_imp_data { shift->{"imp_data"}; } 579 sub _svdump { } 580 sub dump_handle { 581 my ($h,$msg,$level) = @_; 582 $msg||="dump_handle $h"; 583 print $DBI::tfh "$msg:\n"; 584 for my $attrib (sort keys %$h) { 585 print $DBI::tfh "\t$attrib => ".DBI::neat($h->{$attrib})."\n"; 586 } 587 } 588 589 sub _handles { 590 my $h = shift; 591 my $h_inner = tied %$h; 592 if ($h_inner) { # this is okay 593 return $h unless wantarray; 594 return ($h, $h_inner); 595 } 596 # XXX this isn't okay... we have an inner handle but 597 # currently have no way to get at its outer handle, 598 # so we just warn and return the inner one for both... 599 Carp::carp("Can't return outer handle from inner handle using DBI::PurePerl"); 600 return $h unless wantarray; 601 return ($h,$h); 602 } 603 604 sub hash { 605 my ($key, $type) = @_; 606 my ($hash); 607 if (!$type) { 608 $hash = 0; 609 # XXX The C version uses the "char" type, which could be either 610 # signed or unsigned. I use signed because so do the two 611 # compilers on my system. 612 for my $char (unpack ("c*", $key)) { 613 $hash = $hash * 33 + $char; 614 } 615 $hash &= 0x7FFFFFFF; # limit to 31 bits 616 $hash |= 0x40000000; # set bit 31 617 return -$hash; # return negative int 618 } 619 elsif ($type == 1) { # Fowler/Noll/Vo hash 620 # see http://www.isthe.com/chongo/tech/comp/fnv/ 621 require Math::BigInt; # feel free to reimplement w/o BigInt! 622 (my $version = $Math::BigInt::VERSION || 0) =~ s/_.*//; # eg "1.70_01" 623 if ($version >= 1.56) { 624 $hash = Math::BigInt->new(0x811c9dc5); 625 for my $uchar (unpack ("C*", $key)) { 626 # multiply by the 32 bit FNV magic prime mod 2^64 627 $hash = ($hash * 0x01000193) & 0xffffffff; 628 # xor the bottom with the current octet 629 $hash ^= $uchar; 630 } 631 # cast to int 632 return unpack "i", pack "i", $hash; 633 } 634 croak("DBI::PurePerl doesn't support hash type 1 without Math::BigInt >= 1.56 (available on CPAN)"); 635 } 636 else { 637 croak("bad hash type $type"); 638 } 639 } 640 641 sub looks_like_number { 642 my @new = (); 643 for my $thing(@_) { 644 if (!defined $thing or $thing eq '') { 645 push @new, undef; 646 } 647 else { 648 push @new, ($thing =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/) ? 1 : 0; 649 } 650 } 651 return (@_ >1) ? @new : $new[0]; 652 } 653 654 sub neat { 655 my $v = shift; 656 return "undef" unless defined $v; 657 my $quote = q{"}; 658 if (not utf8::is_utf8($v)) { 659 return $v if (($v & ~ $v) eq "0"); # is SvNIOK 660 $quote = q{'}; 661 } 662 my $maxlen = shift || $DBI::neat_maxlen; 663 if ($maxlen && $maxlen < length($v) + 2) { 664 $v = substr($v,0,$maxlen-5); 665 $v .= '...'; 666 } 667 $v =~ s/[^[:print:]]/./g; 668 return "$quote$v$quote"; 669 } 670 671 sub dbi_time { 672 return time(); 673 } 674 675 sub DBI::st::TIEHASH { bless $_[1] => $_[0] }; 676 677 sub _concat_hash_sorted { 678 my ( $hash_ref, $kv_separator, $pair_separator, $use_neat, $num_sort ) = @_; 679 # $num_sort: 0=lexical, 1=numeric, undef=try to guess 680 681 return undef unless defined $hash_ref; 682 die "hash is not a hash reference" unless ref $hash_ref eq 'HASH'; 683 my $keys = _get_sorted_hash_keys($hash_ref, $num_sort); 684 my $string = ''; 685 for my $key (@$keys) { 686 $string .= $pair_separator if length $string > 0; 687 my $value = $hash_ref->{$key}; 688 if ($use_neat) { 689 $value = DBI::neat($value, 0); 690 } 691 else { 692 $value = (defined $value) ? "'$value'" : 'undef'; 693 } 694 $string .= $key . $kv_separator . $value; 695 } 696 return $string; 697 } 698 699 sub _get_sorted_hash_keys { 700 my ($hash_ref, $num_sort) = @_; 701 if (not defined $num_sort) { 702 my $sort_guess = 1; 703 $sort_guess = (not looks_like_number($_)) ? 0 : $sort_guess 704 for keys %$hash_ref; 705 $num_sort = $sort_guess; 706 } 707 708 my @keys = keys %$hash_ref; 709 no warnings 'numeric'; 710 my @sorted = ($num_sort) 711 ? sort { $a <=> $b or $a cmp $b } @keys 712 : sort @keys; 713 return \@sorted; 714 } 715 716 717 718 package 719 DBI::var; 720 721 sub FETCH { 722 my($key)=shift; 723 return $DBI::err if $$key eq '*err'; 724 return $DBI::errstr if $$key eq '&errstr'; 725 Carp::confess("FETCH $key not supported when using DBI::PurePerl"); 726 } 727 728 package 729 DBD::_::common; 730 731 sub swap_inner_handle { 732 my ($h1, $h2) = @_; 733 # can't make this work till we can get the outer handle from the inner one 734 # probably via a WeakRef 735 return $h1->set_err($DBI::stderr, "swap_inner_handle not currently supported by DBI::PurePerl"); 736 } 737 738 sub trace { # XXX should set per-handle level, not global 739 my ($h, $level, $file) = @_; 740 $level = $h->parse_trace_flags($level) 741 if defined $level and !DBI::looks_like_number($level); 742 my $old_level = $DBI::dbi_debug; 743 DBI::_set_trace_file($file) if defined $file; 744 if (defined $level) { 745 $DBI::dbi_debug = $level; 746 if ($DBI::dbi_debug) { 747 printf $DBI::tfh 748 " %s trace level set to %d in DBI $DBI::VERSION (PurePerl)\n", 749 $h, $DBI::dbi_debug; 750 print $DBI::tfh " Full trace not available because DBI_TRACE is not in environment\n" 751 unless exists $ENV{DBI_TRACE}; 752 } 753 } 754 return $old_level; 755 } 756 *debug = \&trace; *debug = \&trace; # twice to avoid typo warning 757 758 sub FETCH { 759 my($h,$key)= @_; 760 my $v = $h->{$key}; 761 #warn ((exists $h->{$key}) ? "$key=$v\n" : "$key NONEXISTANT\n"); 762 return $v if defined $v; 763 if ($key =~ /^NAME_.c$/) { 764 my $cols = $h->FETCH('NAME'); 765 return undef unless $cols; 766 my @lcols = map { lc $_ } @$cols; 767 $h->{NAME_lc} = \@lcols; 768 my @ucols = map { uc $_ } @$cols; 769 $h->{NAME_uc} = \@ucols; 770 return $h->FETCH($key); 771 } 772 if ($key =~ /^NAME.*_hash$/) { 773 my $i=0; 774 for my $c(@{$h->FETCH('NAME')||[]}) { 775 $h->{'NAME_hash'}->{$c} = $i; 776 $h->{'NAME_lc_hash'}->{"\L$c"} = $i; 777 $h->{'NAME_uc_hash'}->{"\U$c"} = $i; 778 $i++; 779 } 780 return $h->{$key}; 781 } 782 if (!defined $v && !exists $h->{$key}) { 783 return ($h->FETCH('TaintIn') && $h->FETCH('TaintOut')) if $key eq'Taint'; 784 return (1==0) if $is_flag_attribute{$key}; # return perl-style sv_no, not undef 785 return $DBI::dbi_debug if $key eq 'TraceLevel'; 786 return [] if $key eq 'ChildHandles' && $HAS_WEAKEN; 787 if ($key eq 'Type') { 788 return "dr" if $h->isa('DBI::dr'); 789 return "db" if $h->isa('DBI::db'); 790 return "st" if $h->isa('DBI::st'); 791 Carp::carp( sprintf "Can't determine Type for %s",$h ); 792 } 793 if (!$is_valid_attribute{$key} and $key =~ m/^[A-Z]/) { 794 local $^W; # hide undef warnings 795 Carp::carp( sprintf "Can't get %s->{%s}: unrecognised attribute (@{[ %$h ]})",$h,$key ) 796 } 797 } 798 return $v; 799 } 800 sub STORE { 801 my ($h,$key,$value) = @_; 802 if ($key eq 'AutoCommit') { 803 Carp::croak("DBD driver has not implemented the AutoCommit attribute") 804 unless $value == -900 || $value == -901; 805 $value = ($value == -901); 806 } 807 elsif ($key =~ /^Taint/ ) { 808 Carp::croak(sprintf "Can't set %s->{%s}: Taint mode not supported by DBI::PurePerl",$h,$key) 809 if $value; 810 } 811 elsif ($key eq 'TraceLevel') { 812 $h->trace($value); 813 return 1; 814 } 815 elsif ($key eq 'NUM_OF_FIELDS') { 816 $h->{$key} = $value; 817 if ($value) { 818 my $fbav = DBD::_::st::dbih_setup_fbav($h); 819 @$fbav = (undef) x $value if @$fbav != $value; 820 } 821 return 1; 822 } 823 elsif (!$is_valid_attribute{$key} && $key =~ /^[A-Z]/ && !exists $h->{$key}) { 824 Carp::carp(sprintf "Can't set %s->{%s}: unrecognised attribute or invalid value %s", 825 $h,$key,$value); 826 } 827 $h->{$key} = $is_flag_attribute{$key} ? !!$value : $value; 828 return 1; 829 } 830 sub err { return shift->{err} } 831 sub errstr { return shift->{errstr} } 832 sub state { return shift->{state} } 833 sub set_err { 834 my ($h, $errnum,$msg,$state, $method, $rv) = @_; 835 $h = tied(%$h) || $h; 836 837 if (my $hss = $h->{HandleSetErr}) { 838 return if $hss->($h, $errnum, $msg, $state, $method); 839 } 840 841 if (!defined $errnum) { 842 $h->{err} = $DBI::err = undef; 843 $h->{errstr} = $DBI::errstr = undef; 844 $h->{state} = $DBI::state = ''; 845 return; 846 } 847 848 if ($h->{errstr}) { 849 $h->{errstr} .= sprintf " [err was %s now %s]", $h->{err}, $errnum 850 if $h->{err} && $errnum && $h->{err} ne $errnum; 851 $h->{errstr} .= sprintf " [state was %s now %s]", $h->{state}, $state 852 if $h->{state} and $h->{state} ne "S1000" && $state && $h->{state} ne $state; 853 $h->{errstr} .= "\n$msg" if $h->{errstr} ne $msg; 854 $DBI::errstr = $h->{errstr}; 855 } 856 else { 857 $h->{errstr} = $DBI::errstr = $msg; 858 } 859 860 # assign if higher priority: err > "0" > "" > undef 861 my $err_changed; 862 if ($errnum # new error: so assign 863 or !defined $h->{err} # no existing warn/info: so assign 864 # new warn ("0" len 1) > info ("" len 0): so assign 865 or defined $errnum && length($errnum) > length($h->{err}) 866 ) { 867 $h->{err} = $DBI::err = $errnum; 868 ++$h->{ErrCount} if $errnum; 869 ++$err_changed; 870 } 871 872 if ($err_changed) { 873 $state ||= "S1000" if $DBI::err; 874 $h->{state} = $DBI::state = ($state eq "00000") ? "" : $state 875 if $state; 876 } 877 878 if (my $p = $h->{Database}) { # just sth->dbh, not dbh->drh (see ::db::DESTROY) 879 $p->{err} = $DBI::err; 880 $p->{errstr} = $DBI::errstr; 881 $p->{state} = $DBI::state; 882 } 883 884 $h->{'dbi_pp_last_method'} = $method; 885 return $rv; # usually undef 886 } 887 sub trace_msg { 888 my ($h, $msg, $minlevel)=@_; 889 $minlevel = 1 unless defined $minlevel; 890 return unless $minlevel <= ($DBI::dbi_debug & 0xF); 891 print $DBI::tfh $msg; 892 return 1; 893 } 894 sub private_data { 895 warn "private_data @_"; 896 } 897 sub take_imp_data { 898 my $dbh = shift; 899 # A reasonable default implementation based on the one in DBI.xs. 900 # Typically a pure-perl driver would have their own take_imp_data method 901 # that would delete all but the essential items in the hash before einding with: 902 # return $dbh->SUPER::take_imp_data(); 903 # Of course it's useless if the driver doesn't also implement support for 904 # the dbi_imp_data attribute to the connect() method. 905 require Storable; 906 croak("Can't take_imp_data from handle that's not Active") 907 unless $dbh->{Active}; 908 for my $sth (@{ $dbh->{ChildHandles} || [] }) { 909 next unless $sth; 910 $sth->finish if $sth->{Active}; 911 bless $sth, 'DBI::zombie'; 912 } 913 delete $dbh->{$_} for (keys %is_valid_attribute); 914 delete $dbh->{$_} for grep { m/^dbi_/ } keys %$dbh; 915 # warn "@{[ %$dbh ]}"; 916 local $Storable::forgive_me = 1; # in case there are some CODE refs 917 my $imp_data = Storable::freeze($dbh); 918 # XXX um, should probably untie here - need to check dispatch behaviour 919 return $imp_data; 920 } 921 sub rows { 922 return -1; # always returns -1 here, see DBD::_::st::rows below 923 } 924 sub DESTROY { 925 } 926 927 package 928 DBD::_::dr; 929 930 sub dbixs_revision { 931 return 0; 932 } 933 934 package 935 DBD::_::db; 936 937 sub connected { 938 } 939 940 941 package 942 DBD::_::st; 943 944 sub fetchrow_arrayref { 945 my $h = shift; 946 # if we're here then driver hasn't implemented fetch/fetchrow_arrayref 947 # so we assume they've implemented fetchrow_array and call that instead 948 my @row = $h->fetchrow_array or return; 949 return $h->_set_fbav(\@row); 950 } 951 # twice to avoid typo warning 952 *fetch = \&fetchrow_arrayref; *fetch = \&fetchrow_arrayref; 953 954 sub fetchrow_array { 955 my $h = shift; 956 # if we're here then driver hasn't implemented fetchrow_array 957 # so we assume they've implemented fetch/fetchrow_arrayref 958 my $row = $h->fetch or return; 959 return @$row; 960 } 961 *fetchrow = \&fetchrow_array; *fetchrow = \&fetchrow_array; 962 963 sub fetchrow_hashref { 964 my $h = shift; 965 my $row = $h->fetch or return; 966 my $FetchCase = shift; 967 my $FetchHashKeyName = $FetchCase || $h->{'FetchHashKeyName'} || 'NAME'; 968 my $FetchHashKeys = $h->FETCH($FetchHashKeyName); 969 my %rowhash; 970 @rowhash{ @$FetchHashKeys } = @$row; 971 return \%rowhash; 972 } 973 sub dbih_setup_fbav { 974 my $h = shift; 975 return $h->{'_fbav'} || do { 976 $DBI::rows = $h->{'_rows'} = 0; 977 my $fields = $h->{'NUM_OF_FIELDS'} 978 or DBI::croak("NUM_OF_FIELDS not set"); 979 my @row = (undef) x $fields; 980 \@row; 981 }; 982 } 983 sub _get_fbav { 984 my $h = shift; 985 my $av = $h->{'_fbav'} ||= dbih_setup_fbav($h); 986 $DBI::rows = ++$h->{'_rows'}; 987 return $av; 988 } 989 sub _set_fbav { 990 my $h = shift; 991 my $fbav = $h->{'_fbav'}; 992 if ($fbav) { 993 $DBI::rows = ++$h->{'_rows'}; 994 } 995 else { 996 $fbav = $h->_get_fbav; 997 } 998 my $row = shift; 999 if (my $bc = $h->{'_bound_cols'}) { 1000 for my $i (0..@$row-1) { 1001 my $bound = $bc->[$i]; 1002 $fbav->[$i] = ($bound) ? ($$bound = $row->[$i]) : $row->[$i]; 1003 } 1004 } 1005 else { 1006 @$fbav = @$row; 1007 } 1008 return $fbav; 1009 } 1010 sub bind_col { 1011 my ($h, $col, $value_ref,$from_bind_columns) = @_; 1012 my $fbav = $h->{'_fbav'} ||= dbih_setup_fbav($h); # from _get_fbav() 1013 my $num_of_fields = @$fbav; 1014 DBI::croak("bind_col: column $col is not a valid column (1..$num_of_fields)") 1015 if $col < 1 or $col > $num_of_fields; 1016 return 1 if not defined $value_ref; # ie caller is just trying to set TYPE 1017 DBI::croak("bind_col($col,$value_ref) needs a reference to a scalar") 1018 unless ref $value_ref eq 'SCALAR'; 1019 $h->{'_bound_cols'}->[$col-1] = $value_ref; 1020 return 1; 1021 } 1022 sub finish { 1023 my $h = shift; 1024 $h->{'_fbav'} = undef; 1025 $h->{'Active'} = 0; 1026 return 1; 1027 } 1028 sub rows { 1029 my $h = shift; 1030 my $rows = $h->{'_rows'}; 1031 return -1 unless defined $rows; 1032 return $rows; 1033 } 1034 1035 1; 1036 __END__ 1037 1038 =pod 1039 1040 =head1 NAME 1041 1042 DBI::PurePerl -- a DBI emulation using pure perl (no C/XS compilation required) 1043 1044 =head1 SYNOPSIS 1045 1046 BEGIN { $ENV{DBI_PUREPERL} = 2 } 1047 use DBI; 1048 1049 =head1 DESCRIPTION 1050 1051 This is a pure perl emulation of the DBI internals. In almost all 1052 cases you will be better off using standard DBI since the portions 1053 of the standard version written in C make it *much* faster. 1054 1055 However, if you are in a situation where it isn't possible to install 1056 a compiled version of standard DBI, and you're using pure-perl DBD 1057 drivers, then this module allows you to use most common features 1058 of DBI without needing any changes in your scripts. 1059 1060 =head1 EXPERIMENTAL STATUS 1061 1062 DBI::PurePerl is new so please treat it as experimental pending 1063 more extensive testing. So far it has passed all tests with DBD::CSV, 1064 DBD::AnyData, DBD::XBase, DBD::Sprite, DBD::mysqlPP. Please send 1065 bug reports to Jeff Zucker at <jeff@vpservices.com> with a cc to 1066 <dbi-dev@perl.org>. 1067 1068 =head1 USAGE 1069 1070 The usage is the same as for standard DBI with the exception 1071 that you need to set the enviornment variable DBI_PUREPERL if 1072 you want to use the PurePerl version. 1073 1074 DBI_PUREPERL == 0 (the default) Always use compiled DBI, die 1075 if it isn't properly compiled & installed 1076 1077 DBI_PUREPERL == 1 Use compiled DBI if it is properly compiled 1078 & installed, otherwise use PurePerl 1079 1080 DBI_PUREPERL == 2 Always use PurePerl 1081 1082 You may set the enviornment variable in your shell (e.g. with 1083 set or setenv or export, etc) or else set it in your script like 1084 this: 1085 1086 BEGIN { $ENV{DBI_PUREPERL}=2 } 1087 1088 before you C<use DBI;>. 1089 1090 =head1 INSTALLATION 1091 1092 In most situations simply install DBI (see the DBI pod for details). 1093 1094 In the situation in which you can not install DBI itself, you 1095 may manually copy DBI.pm and PurePerl.pm into the appropriate 1096 directories. 1097 1098 For example: 1099 1100 cp DBI.pm /usr/jdoe/mylibs/. 1101 cp PurePerl.pm /usr/jdoe/mylibs/DBI/. 1102 1103 Then add this to the top of scripts: 1104 1105 BEGIN { 1106 $ENV{DBI_PUREPERL} = 1; # or =2 1107 unshift @INC, '/usr/jdoe/mylibs'; 1108 } 1109 1110 (Or should we perhaps patch Makefile.PL so that if DBI_PUREPERL 1111 is set to 2 prior to make, the normal compile process is skipped 1112 and the files are installed automatically?) 1113 1114 =head1 DIFFERENCES BETWEEN DBI AND DBI::PurePerl 1115 1116 =head2 Attributes 1117 1118 Boolean attributes still return boolean values but the actual values 1119 used may be different, i.e., 0 or undef instead of an empty string. 1120 1121 Some handle attributes are either not supported or have very limited 1122 functionality: 1123 1124 ActiveKids 1125 InactiveDestroy 1126 Kids 1127 Taint 1128 TaintIn 1129 TaintOut 1130 1131 (and probably others) 1132 1133 =head2 Tracing 1134 1135 Trace functionality is more limited and the code to handle tracing is 1136 only embeded into DBI:PurePerl if the DBI_TRACE environment variable 1137 is defined. To enable total tracing you can set the DBI_TRACE 1138 environment variable as usual. But to enable individual handle 1139 tracing using the trace() method you also need to set the DBI_TRACE 1140 environment variable, but set it to 0. 1141 1142 =head2 Parameter Usage Checking 1143 1144 The DBI does some basic parameter count checking on method calls. 1145 DBI::PurePerl doesn't. 1146 1147 =head2 Speed 1148 1149 DBI::PurePerl is slower. Although, with some drivers in some 1150 contexts this may not be very significant for you. 1151 1152 By way of example... the test.pl script in the DBI source 1153 distribution has a simple benchmark that just does: 1154 1155 my $null_dbh = DBI->connect('dbi:NullP:','',''); 1156 my $i = 10_000; 1157 $null_dbh->prepare('') while $i--; 1158 1159 In other words just prepares a statement, creating and destroying 1160 a statement handle, over and over again. Using the real DBI this 1161 runs at ~4550 handles per second whereas DBI::PurePerl manages 1162 ~2800 per second on the same machine (not too bad really). 1163 1164 =head2 May not fully support hash() 1165 1166 If you want to use type 1 hash, i.e., C<hash($string,1)> with 1167 DBI::PurePerl, you'll need version 1.56 or higher of Math::BigInt 1168 (available on CPAN). 1169 1170 =head2 Doesn't support preparse() 1171 1172 The DBI->preparse() method isn't supported in DBI::PurePerl. 1173 1174 =head2 Doesn't support DBD::Proxy 1175 1176 There's a subtle problem somewhere I've not been able to identify. 1177 DBI::ProxyServer seem to work fine with DBI::PurePerl but DBD::Proxy 1178 does not work 100% (which is sad because that would be far more useful :) 1179 Try re-enabling t/80proxy.t for DBI::PurePerl to see if the problem 1180 that remains will affect you're usage. 1181 1182 =head2 Others 1183 1184 can() - doesn't have any special behaviour 1185 1186 Please let us know if you find any other differences between DBI 1187 and DBI::PurePerl. 1188 1189 =head1 AUTHORS 1190 1191 Tim Bunce and Jeff Zucker. 1192 1193 Tim provided the direction and basis for the code. The original 1194 idea for the module and most of the brute force porting from C to 1195 Perl was by Jeff. Tim then reworked some core parts to boost the 1196 performance and accuracy of the emulation. Thanks also to Randal 1197 Schwartz and John Tobey for patches. 1198 1199 =head1 COPYRIGHT 1200 1201 Copyright (c) 2002 Tim Bunce Ireland. 1202 1203 See COPYRIGHT section in DBI.pm for usage and distribution rights. 1204 1205 =cut
title
Description
Body
title
Description
Body
title
Description
Body
title
Body
| Generated: Tue Mar 17 22:47:18 2015 | Cross-referenced by PHPXref 0.7.1 |