weaken results from the CPAN

DBI

########################################################################
package		# hide from PAUSE
	DBI;
# vim: ts=8:sw=4
########################################################################
#
# Copyright (c) 2002,2003  Tim Bunce  Ireland.
#
# See COPYRIGHT section in DBI.pm for usage and distribution rights.
#
########################################################################
#
# Please send patches and bug reports to
#
# Jeff Zucker <jeff@vpservices.com>  with cc to <dbi-dev@perl.org>
#
########################################################################

use strict;
use warnings;
use Carp;
require Symbol;

$DBI::PurePerl = $ENV{DBI_PUREPERL} || 1;
$DBI::PurePerl::VERSION = "2.014286";

$DBI::neat_maxlen ||= 400;

$DBI::tfh = Symbol::gensym();
open $DBI::tfh, ">&STDERR" or warn "Can't dup STDERR: $!";
select( (select($DBI::tfh), $| = 1)[0] );  # autoflush

# check for weaken support, used by ChildHandles
my $HAS_WEAKEN = eval {
    require Scalar::Util;
    # this will croak() if this Scalar::Util doesn't have a working weaken().
    Scalar::Util::weaken( my $test = [] );
    1;
};

%DBI::last_method_except = map { $_=>1 } qw(DESTROY _set_fbav set_err);

use constant SQL_ALL_TYPES => 0;
use constant SQL_ARRAY => 50;
use constant SQL_ARRAY_LOCATOR => 51;
use constant SQL_BIGINT => (-5);
use constant SQL_BINARY => (-2);
use constant SQL_BIT => (-7);
use constant SQL_BLOB => 30;
use constant SQL_BLOB_LOCATOR => 31;
use constant SQL_BOOLEAN => 16;
use constant SQL_CHAR => 1;
use constant SQL_CLOB => 40;
use constant SQL_CLOB_LOCATOR => 41;
use constant SQL_DATE => 9;
use constant SQL_DATETIME => 9;
use constant SQL_DECIMAL => 3;
use constant SQL_DOUBLE => 8;
use constant SQL_FLOAT => 6;
use constant SQL_GUID => (-11);
use constant SQL_INTEGER => 4;
use constant SQL_INTERVAL => 10;
use constant SQL_INTERVAL_DAY => 103;
use constant SQL_INTERVAL_DAY_TO_HOUR => 108;
use constant SQL_INTERVAL_DAY_TO_MINUTE => 109;
use constant SQL_INTERVAL_DAY_TO_SECOND => 110;
use constant SQL_INTERVAL_HOUR => 104;
use constant SQL_INTERVAL_HOUR_TO_MINUTE => 111;
use constant SQL_INTERVAL_HOUR_TO_SECOND => 112;
use constant SQL_INTERVAL_MINUTE => 105;
use constant SQL_INTERVAL_MINUTE_TO_SECOND => 113;
use constant SQL_INTERVAL_MONTH => 102;
use constant SQL_INTERVAL_SECOND => 106;
use constant SQL_INTERVAL_YEAR => 101;
use constant SQL_INTERVAL_YEAR_TO_MONTH => 107;
use constant SQL_LONGVARBINARY => (-4);
use constant SQL_LONGVARCHAR => (-1);
use constant SQL_MULTISET => 55;
use constant SQL_MULTISET_LOCATOR => 56;
use constant SQL_NUMERIC => 2;
use constant SQL_REAL => 7;
use constant SQL_REF => 20;
use constant SQL_ROW => 19;
use constant SQL_SMALLINT => 5;
use constant SQL_TIME => 10;
use constant SQL_TIMESTAMP => 11;
use constant SQL_TINYINT => (-6);
use constant SQL_TYPE_DATE => 91;
use constant SQL_TYPE_TIME => 92;
use constant SQL_TYPE_TIMESTAMP => 93;
use constant SQL_TYPE_TIMESTAMP_WITH_TIMEZONE => 95;
use constant SQL_TYPE_TIME_WITH_TIMEZONE => 94;
use constant SQL_UDT => 17;
use constant SQL_UDT_LOCATOR => 18;
use constant SQL_UNKNOWN_TYPE => 0;
use constant SQL_VARBINARY => (-3);
use constant SQL_VARCHAR => 12;

lib/DBI/PurePerl.pm view on Meta::CPAN


sub _new_handle {
    my ($class, $parent, $attr, $imp_data, $imp_class) = @_;

    DBI->trace_msg("    New $class (for $imp_class, parent=$parent, id=".($imp_data||'').")\n")
        if $DBI::dbi_debug >= 3;

    $attr->{ImplementorClass} = $imp_class
        or Carp::croak("_new_handle($class): 'ImplementorClass' attribute not given");

    # This is how we create a DBI style Object:
    # %outer gets tied to %$attr (which becomes the 'inner' handle)
    my (%outer, $i, $h);
    $i = tie    %outer, $class, $attr;  # ref to inner hash (for driver)
    $h = bless \%outer, $class;         # ref to outer hash (for application)
    # The above tie and bless may migrate down into _setup_handle()...
    # Now add magic so DBI method dispatch works
    DBI::_setup_handle($h, $imp_class, $parent, $imp_data);
    return $h unless wantarray;
    return ($h, $i);
}

sub _setup_handle {
    my($h, $imp_class, $parent, $imp_data) = @_;
    my $h_inner = tied(%$h) || $h;
    if (($DBI::dbi_debug & 0xF) >= 4) {
	no warnings;
	print $DBI::tfh "      _setup_handle(@_)\n";
    }
    $h_inner->{"imp_data"} = $imp_data;
    $h_inner->{"ImplementorClass"} = $imp_class;
    $h_inner->{"Kids"} = $h_inner->{"ActiveKids"} = 0;	# XXX not maintained
    if ($parent) {
	foreach (qw(
	    RaiseError PrintError RaiseWarn PrintWarn HandleError HandleSetErr
	    Warn LongTruncOk ChopBlanks AutoCommit ReadOnly
	    ShowErrorStatement FetchHashKeyName LongReadLen CompatMode
	)) {
	    $h_inner->{$_} = $parent->{$_}
		if exists $parent->{$_} && !exists $h_inner->{$_};
	}
	if (ref($parent) =~ /::db$/) { # is sth
	    $h_inner->{Database} = $parent;
	    $parent->{Statement} = $h_inner->{Statement};
	    $h_inner->{NUM_OF_PARAMS} = 0;
            $h_inner->{Active} = 0; # driver sets true when there's data to fetch
	}
	elsif (ref($parent) =~ /::dr$/){ # is dbh
	    $h_inner->{Driver} = $parent;
            $h_inner->{Active} = 0;
	}
        else {
            warn "panic: ".ref($parent); # should never happen
        }
	$h_inner->{dbi_pp_parent} = $parent;

	# add to the parent's ChildHandles
	if ($HAS_WEAKEN) {
	    my $handles = $parent->{ChildHandles} ||= [];
	    push @$handles, $h;
	    Scalar::Util::weaken($handles->[-1]);
	    # purge destroyed handles occasionally
	    if (@$handles % 120 == 0) {
		@$handles = grep { defined } @$handles;
		Scalar::Util::weaken($_) for @$handles; # re-weaken after grep
	    }
	}
    }
    else {	# setting up a driver handle
        $h_inner->{Warn}		= 1;
        $h_inner->{PrintWarn}		= 1;
        $h_inner->{AutoCommit}		= 1;
        $h_inner->{TraceLevel}		= 0;
        $h_inner->{CompatMode}		= (1==0);
	$h_inner->{FetchHashKeyName}	||= 'NAME';
	$h_inner->{LongReadLen}		||= 80;
	$h_inner->{ChildHandles}        ||= [] if $HAS_WEAKEN;
	$h_inner->{Type}                ||= 'dr';
        $h_inner->{Active}              = 1;
    }
    $h_inner->{"dbi_pp_call_depth"} = 0;
    $h_inner->{"dbi_pp_pid"} = $$;
    $h_inner->{ErrCount} = 0;
}

sub constant {
    warn "constant(@_) called unexpectedly"; return undef;
}

sub trace {
    my ($h, $level, $file) = @_;
    $level = $h->parse_trace_flags($level)
	if defined $level and !DBI::looks_like_number($level);
    my $old_level = $DBI::dbi_debug;
    _set_trace_file($file) if $level;
    if (defined $level) {
	$DBI::dbi_debug = $level;
	print $DBI::tfh "    DBI $DBI::VERSION (PurePerl) "
                . "dispatch trace level set to $DBI::dbi_debug\n"
		if $DBI::dbi_debug & 0xF;
    }
    _set_trace_file($file) if !$level;
    return $old_level;
}

sub _set_trace_file {
    my ($file) = @_;
    #
    #   DAA add support for filehandle inputs
    #
    # DAA required to avoid closing a prior fh trace()
    $DBI::tfh = undef unless $DBI::tfh_needs_close;

    if (ref $file eq 'GLOB') {
	$DBI::tfh = $file;
        select((select($DBI::tfh), $| = 1)[0]);
        $DBI::tfh_needs_close = 0;
        return 1;
    }
    if ($file && ref \$file eq 'GLOB') {
	$DBI::tfh = *{$file}{IO};
        select((select($DBI::tfh), $| = 1)[0]);
        $DBI::tfh_needs_close = 0;
        return 1;
    }

lib/DBI/PurePerl.pm view on Meta::CPAN

        my @ucols = map { uc $_ } @$cols;
        $h->{NAME_uc} = \@ucols;
        return $h->FETCH($key);
    }
    if ($key =~ /^NAME.*_hash$/) {
        my $i=0;
        for my $c(@{$h->FETCH('NAME')||[]}) {
            $h->{'NAME_hash'}->{$c}    = $i;
            $h->{'NAME_lc_hash'}->{"\L$c"} = $i;
            $h->{'NAME_uc_hash'}->{"\U$c"} = $i;
            $i++;
        }
        return $h->{$key};
    }
    if (!defined $v && !exists $h->{$key}) {
	return ($h->FETCH('TaintIn') && $h->FETCH('TaintOut')) if $key eq'Taint';
	return (1==0) if $is_flag_attribute{$key}; # return perl-style sv_no, not undef
	return $DBI::dbi_debug if $key eq 'TraceLevel';
        return [] if $key eq 'ChildHandles' && $HAS_WEAKEN;
        if ($key eq 'Type') {
            return "dr" if $h->isa('DBI::dr');
            return "db" if $h->isa('DBI::db');
            return "st" if $h->isa('DBI::st');
            Carp::carp( sprintf "Can't determine Type for %s",$h );
        }
	if (!$is_valid_attribute{$key} and $key =~ m/^[A-Z]/) {
	    no warnings; # hide undef warnings
	    Carp::carp( sprintf "Can't get %s->{%s}: unrecognised attribute (@{[ %$h ]})",$h,$key )
	}
    }
    return $v;
}
sub STORE {
    my ($h,$key,$value) = @_;
    if ($key eq 'AutoCommit') {
        Carp::croak("DBD driver has not implemented the AutoCommit attribute")
	    unless $value == -900 || $value == -901;
	$value = ($value == -901);
    }
    elsif ($key =~ /^Taint/ ) {
	Carp::croak(sprintf "Can't set %s->{%s}: Taint mode not supported by DBI::PurePerl",$h,$key)
		if $value;
    }
    elsif ($key eq 'TraceLevel') {
	$h->trace($value);
	return 1;
    }
    elsif ($key eq 'NUM_OF_FIELDS') {
        $h->{$key} = $value;
        if ($value) {
            my $fbav = DBD::_::st::dbih_setup_fbav($h);
            @$fbav = (undef) x $value if @$fbav != $value;
        }
	return 1;
    }
    elsif (!$is_valid_attribute{$key} && $key =~ /^[A-Z]/ && !exists $h->{$key}) {
       Carp::carp(sprintf "Can't set %s->{%s}: unrecognised attribute or invalid value %s",
	    $h,$key,$value);
    }
    $h->{$key} = $is_flag_attribute{$key} ? !!$value : $value;
    Scalar::Util::weaken($h->{$key}) if $key eq 'CachedKids';
    return 1;
}
sub DELETE {
    my ($h, $key) = @_;
    return $h->FETCH($key) unless $key =~ /^private_/;
    return delete $h->{$key};
}
sub err    { return shift->{err}    }
sub errstr { return shift->{errstr} }
sub state  { return shift->{state}  }
sub set_err {
    my ($h, $errnum,$msg,$state, $method, $rv) = @_;
    $h = tied(%$h) || $h;

    if (my $hss = $h->{HandleSetErr}) {
	return if $hss->($h, $errnum, $msg, $state, $method);
    }

    if (!defined $errnum) {
	$h->{err}    = $DBI::err    = undef;
	$h->{errstr} = $DBI::errstr = undef;
	$h->{state}  = $DBI::state  = '';
        return;
    }

    if ($h->{errstr}) {
	$h->{errstr} .= sprintf " [err was %s now %s]", $h->{err}, $errnum
		if $h->{err} && $errnum && $h->{err} ne $errnum;
	$h->{errstr} .= sprintf " [state was %s now %s]", $h->{state}, $state
		if $h->{state} and $h->{state} ne "S1000" && $state && $h->{state} ne $state;
	$h->{errstr} .= "\n$msg" if $h->{errstr} ne $msg;
	$DBI::errstr = $h->{errstr};
    }
    else {
	$h->{errstr} = $DBI::errstr = $msg;
    }

    # assign if higher priority: err > "0" > "" > undef
    my $err_changed;
    if ($errnum			# new error: so assign
	or !defined $h->{err}	# no existing warn/info: so assign
           # new warn ("0" len 1) > info ("" len 0): so assign
	or defined $errnum && length($errnum) > length($h->{err})
    ) {
        $h->{err} = $DBI::err = $errnum;
	++$h->{ErrCount} if $errnum;
	++$err_changed;
    }

    if ($err_changed) {
	$state ||= "S1000" if $DBI::err;
	$h->{state} = $DBI::state = ($state eq "00000") ? "" : $state
	    if $state;
    }

    if (my $p = $h->{Database}) { # just sth->dbh, not dbh->drh (see ::db::DESTROY)
	$p->{err}    = $DBI::err;
	$p->{errstr} = $DBI::errstr;
	$p->{state}  = $DBI::state;
    }

( run in 1.593 second using v1.01-cache-2.11-cpan-98e64b0badf )