pureperl.pm

视频监控网络部分的协议ddns,的模块的实现代码,请大家大胆指正.

########################################################################
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 <[e-mail]>  with cc to <[e-mail]>
#
########################################################################

use strict;
use Carp;
require Symbol;

require utf8;
*utf8::is_utf8 = sub { # hack for perl 5.6
    require bytes;
    return unless defined $_[0];
    return !(length($_[0]) == bytes::length($_[0]))
} unless defined &utf8::is_utf8;

$DBI::PurePerl = $ENV{DBI_PUREPERL} || 1;
$DBI::PurePerl::VERSION = sprintf("2.%06d", q$Revision: 10002 $ =~ /(\d+)/o);

$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;
use constant SQL_WCHAR => (-8);
use constant SQL_WLONGVARCHAR => (-10);
use constant SQL_WVARCHAR => (-9);

# for Cursor types
use constant SQL_CURSOR_FORWARD_ONLY  => 0;
use constant SQL_CURSOR_KEYSET_DRIVEN => 1;
use constant SQL_CURSOR_DYNAMIC       => 2;
use constant SQL_CURSOR_STATIC        => 3;
use constant SQL_CURSOR_TYPE_DEFAULT  => SQL_CURSOR_FORWARD_ONLY;

use constant IMA_HAS_USAGE	=> 0x0001; #/* check parameter usage	*/
use constant IMA_FUNC_REDIRECT	=> 0x0002; #/* is $h->func(..., "method")*/
use constant IMA_KEEP_ERR	=> 0x0004; #/* don't reset err & errstr	*/
use constant IMA_KEEP_ERR_SUB	=> 0x0008; #/*  '' if in nested call */
use constant IMA_NO_TAINT_IN   	=> 0x0010; #/* don't check for tainted args*/
use constant IMA_NO_TAINT_OUT   => 0x0020; #/* don't taint results	*/
use constant IMA_COPY_UP_STMT   => 0x0040; #/* copy sth Statement to dbh */
use constant IMA_END_WORK	=> 0x0080; #/* set on commit & rollback	*/
use constant IMA_STUB		=> 0x0100; #/* donothing eg $dbh->connected */
use constant IMA_CLEAR_STMT     => 0x0200; #/* clear Statement before call  */
use constant IMA_UNRELATED_TO_STMT=> 0x0400; #/* profile as empty Statement   */
use constant IMA_NOT_FOUND_OKAY	=> 0x0800; #/* not error if not found */
use constant IMA_EXECUTE	=> 0x1000; #/* do/execute: DBIcf_Executed   */
use constant IMA_SHOW_ERR_STMT  => 0x2000; #/* dbh meth relates to Statement*/
use constant IMA_HIDE_ERR_PARAMVALUES => 0x4000; #/* ParamValues are not relevant */
use constant IMA_IS_FACTORY     => 0x8000; #/* new h ie connect & prepare */
use constant IMA_CLEAR_CACHED_KIDS    => 0x10000; #/* clear CachedKids before call */

my %is_flag_attribute = map {$_ =>1 } qw(
	Active
	AutoCommit
	ChopBlanks
	CompatMode
	Executed
	Taint
	TaintIn
	TaintOut
	InactiveDestroy
	LongTruncOk
	MultiThread
	PrintError
	PrintWarn
	RaiseError
	ShowErrorStatement
	Warn
);
my %is_valid_attribute = map {$_ =>1 } (keys %is_flag_attribute, qw(
	ActiveKids
	Attribution
	BegunWork
	CachedKids
        Callbacks
	ChildHandles
	CursorName
	Database
	DebugDispatch
	Driver
        Err
        Errstr
	ErrCount
	FetchHashKeyName
	HandleError
	HandleSetErr
	ImplementorClass
	Kids
	LongReadLen
	NAME NAME_uc NAME_lc NAME_uc_hash NAME_lc_hash
	NULLABLE
	NUM_OF_FIELDS
	NUM_OF_PARAMS
	Name
	PRECISION
	ParamValues
	Profile
	Provider
        ReadOnly
	RootClass
	RowCacheSize
	RowsInCache
	SCALE
        State
	Statement
	TYPE
        Type
	TraceLevel
	Username
	Version
));

sub valid_attribute {
    my $attr = shift;
    return 1 if $is_valid_attribute{$attr};
    return 1 if $attr =~ m/^[a-z]/; # starts with lowercase letter
    return 0
}

my $initial_setup;
sub initial_setup {
    $initial_setup = 1;
    print $DBI::tfh  __FILE__ . " version " . $DBI::PurePerl::VERSION . "\n"
	if $DBI::dbi_debug & 0xF;
    untie $DBI::err;
    untie $DBI::errstr;
    untie $DBI::state;
    untie $DBI::rows;
    #tie $DBI::lasth,  'DBI::var', '!lasth';  # special case: return boolean
}

sub  _install_method {
    my ( $caller, $method, $from, $param_hash ) = @_;
    initial_setup() unless $initial_setup;

    my ($class, $method_name) = $method =~ /^[^:]+::(.+)::(.+)$/;
    my $bitmask = $param_hash->{'O'} || 0;
    my @pre_call_frag;

    return if $method_name eq 'can';

    push @pre_call_frag, q{
	return if $h_inner; # ignore DESTROY for outer handle
	# copy err/errstr/state up to driver so $DBI::err etc still work
	if ($h->{err} and my $drh = $h->{Driver}) {
	    $drh->{$_} = $h->{$_} for ('err','errstr','state');
	}
    } if $method_name eq 'DESTROY';

    push @pre_call_frag, q{
	return $h->{$_[0]} if exists $h->{$_[0]};
    } if $method_name eq 'FETCH' && !exists $ENV{DBI_TRACE}; # XXX ?

    push @pre_call_frag, "return;"
	if IMA_STUB & $bitmask;

    push @pre_call_frag, q{
	$method_name = pop @_;
    } if IMA_FUNC_REDIRECT & $bitmask;

    push @pre_call_frag, q{
	my $parent_dbh = $h->{Database};
    } if (IMA_COPY_UP_STMT|IMA_EXECUTE) & $bitmask;

    push @pre_call_frag, q{
	warn "No Database set for $h on $method_name!" unless $parent_dbh; # eg proxy problems
	$parent_dbh->{Statement} = $h->{Statement} if $parent_dbh;
    } if IMA_COPY_UP_STMT & $bitmask;

    push @pre_call_frag, q{
	$h->{Executed} = 1;
	$parent_dbh->{Executed} = 1 if $parent_dbh;
    } if IMA_EXECUTE & $bitmask;

    push @pre_call_frag, q{
	%{ $h->{CachedKids} } = () if $h->{CachedKids};
    } if IMA_CLEAR_CACHED_KIDS & $bitmask;

    if (IMA_KEEP_ERR & $bitmask) {
	push @pre_call_frag, q{
	    my $keep_error = 1;
	};
    }
    else {
	my $ke_init = (IMA_KEEP_ERR_SUB & $bitmask)
		? q{= $h->{dbi_pp_parent}->{dbi_pp_call_depth} }
		: "";
	push @pre_call_frag, qq{
	    my \$keep_error $ke_init;
	};
	my $keep_error_code = q{
	    #warn "$method_name cleared err";
	    $h->{err}    = $DBI::err    = undef;
	    $h->{errstr} = $DBI::errstr = undef;
	    $h->{state}  = $DBI::state  = '';
	};
	$keep_error_code = q{
	    printf $DBI::tfh "    !! %s: %s CLEARED by call to }.$method_name.q{ method\n".
		    $h->{err}, $h->{err}
		if defined $h->{err} && $DBI::dbi_debug & 0xF;
	}. $keep_error_code
	    if exists $ENV{DBI_TRACE};
	push @pre_call_frag, ($ke_init)
		? qq{ unless (\$keep_error) { $keep_error_code }}
		: $keep_error_code
	    unless $method_name eq 'set_err';
    }

    push @pre_call_frag, q{
	my $ErrCount = $h->{ErrCount};
    };

    push @pre_call_frag, q{
        if (($DBI::dbi_debug & 0xF) >= 2) {
	    local $^W;
	    my $args = join " ", map { DBI::neat($_) } ($h, @_);
	    printf $DBI::tfh "    > $method_name in $imp ($args) [$@]\n";
	}
    } if exists $ENV{DBI_TRACE};	# note use of 'exists'

    push @pre_call_frag, q{
        $h->{'dbi_pp_last_method'} = $method_name;
    } unless exists $DBI::last_method_except{$method_name};

    # --- post method call code fragments ---
    my @post_call_frag;

    push @post_call_frag, q{
        if (my $trace_level = ($DBI::dbi_debug & 0xF)) {
	    if ($h->{err}) {
		printf $DBI::tfh "    !! ERROR: %s %s\n", $h->{err}, $h->{errstr};
	    }
	    my $ret = join " ", map { DBI::neat($_) } @ret;
	    my $msg = "    < $method_name= $ret";
	    $msg = ($trace_level >= 2) ? Carp::shortmess($msg) : "$msg\n";
	    print $DBI::tfh $msg;
	}
    } if exists $ENV{DBI_TRACE}; # note use of exists

    push @post_call_frag, q{
	$h->{Executed} = 0;
	if ($h->{BegunWork}) {
	    $h->{BegunWork}  = 0;
	    $h->{AutoCommit} = 1;
	}
    } if IMA_END_WORK & $bitmask;

    push @post_call_frag, q{
        if ( ref $ret[0] and
            UNIVERSAL::isa($ret[0], 'DBI::_::common') and
            defined( (my $h_new = tied(%{$ret[0]})||$ret[0])->{err} )
        ) {
            # copy up info/warn to drh so PrintWarn on connect is triggered
            $h->set_err($h_new->{err}, $h_new->{errstr}, $h_new->{state})
        }
    } if IMA_IS_FACTORY & $bitmask;

    push @post_call_frag, q{
	$keep_error = 0 if $keep_error && $h->{ErrCount} > $ErrCount;

	$DBI::err    = $h->{err};
	$DBI::errstr = $h->{errstr};
	$DBI::state  = $h->{state};

        if ( !$keep_error
	&& defined(my $err = $h->{err})
	&& ($call_depth <= 1 && !$h->{dbi_pp_parent}{dbi_pp_call_depth})
	) {

	    my($pe,$pw,$re,$he) = @{$h}{qw(PrintError PrintWarn RaiseError HandleError)};
	    my $msg;

	    if ($err && ($pe || $re || $he)	# error
	    or (!$err && length($err) && $pw)	# warning
	    ) {
		my $last = ($DBI::last_method_except{$method_name})
		    ? ($h->{'dbi_pp_last_method'}||$method_name) : $method_name;
		my $errstr = $h->{errstr} || $DBI::errstr || $err || '';
		my $msg = sprintf "%s %s %s: %s", $imp, $last,
			($err eq "0") ? "warning" : "failed", $errstr;

		if ($h->{'ShowErrorStatement'} and my $Statement = $h->{Statement}) {
		    $msg .= ' for [``' . $Statement . "''";
		    if (my $ParamValues = $h->FETCH('ParamValues')) {
			my $pv_idx = 0;
			$msg .= " with params: ";
			while ( my($k,$v) = each %$ParamValues ) {
			    $msg .= sprintf "%s%s=%s", ($pv_idx++==0) ? "" : ", ", $k, DBI::neat($v);
			}
		    }
		    $msg .= "]";
		}
		if ($err eq "0") { # is 'warning' (not info)
		    carp $msg if $pw;
		}
		else {
		    my $do_croak = 1;
		    if (my $subsub = $h->{'HandleError'}) {
			$do_croak = 0 if &$subsub($msg,$h,$ret[0]);
		    }
		    if ($do_croak) {
			printf $DBI::tfh "    $method_name has failed ($h->{PrintError},$h->{RaiseError})\n"
				if ($DBI::dbi_debug & 0xF) >= 4;
			carp  $msg if $pe;
			die $msg if $h->{RaiseError};