pureperl.pm

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

		    }
		}
	    }
	}
    };


    my $method_code = q[
      sub {
        my $h = shift;
	my $h_inner = tied(%$h);
	$h = $h_inner if $h_inner;

        my $imp;
	if ($method_name eq 'DESTROY') {
	    # during global destruction, $h->{...} can trigger "Can't call FETCH on an undef value"
	    # implying that tied() above lied to us, so we need to use eval
	    local $@;	 # protect $@
	    $imp = eval { $h->{"ImplementorClass"} } or return; # probably global destruction
	}
	else {
	    $imp = $h->{"ImplementorClass"} or do {
                warn "Can't call $method_name method on handle $h after take_imp_data()\n"
                    if not exists $h->{Active};
                return; # or, more likely, global destruction
            };
	}

	] . join("\n", '', @pre_call_frag, '') . q[

	my $call_depth = $h->{'dbi_pp_call_depth'} + 1;
	local ($h->{'dbi_pp_call_depth'}) = $call_depth;

	my @ret;
        my $sub = $imp->can($method_name);
        if (!$sub and IMA_FUNC_REDIRECT & $bitmask and $sub = $imp->can('func')) {
            push @_, $method_name;
        }
	if ($sub) {
	    (wantarray) ? (@ret = &$sub($h,@_)) : (@ret = scalar &$sub($h,@_));
	}
	else {
	    # XXX could try explicit fallback to $imp->can('AUTOLOAD') etc
	    # which would then let Multiplex pass PurePerl tests, but some
	    # hook into install_method may be better.
	    croak "Can't locate DBI object method \"$method_name\" via package \"$imp\""
		if ] . ((IMA_NOT_FOUND_OKAY & $bitmask) ? 0 : 1) . q[;
	}

	] . join("\n", '', @post_call_frag, '') . q[

	return (wantarray) ? @ret : $ret[0];
      }
    ];
    no strict qw(refs);
    my $code_ref = eval qq{#line 1 "DBI::PurePerl $method"\n$method_code};
    warn "$@\n$method_code\n" if $@;
    die "$@\n$method_code\n" if $@;
    *$method = $code_ref;
    if (0 && $method =~ /\b(connect|FETCH)\b/) { # debuging tool
	my $l=0; # show line-numbered code for method
	warn "*$method code:\n".join("\n", map { ++$l.": $_" } split/\n/,$method_code);
    }
}


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) {
	local $^W;
	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 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$/) {
	    $h_inner->{Database} = $parent;
	    $parent->{Statement} = $h_inner->{Statement};
	    $h_inner->{NUM_OF_PARAMS} = 0;
	}
	elsif (ref($parent) =~ /::dr$/){
	    $h_inner->{Driver} = $parent;
	}
	$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}		= $^W;
        $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->{"dbi_pp_call_depth"} = 0;
    $h_inner->{ErrCount} = 0;
    $h_inner->{Active} = 1;
}

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;
    }
    $DBI::tfh_needs_close = 1;
    if (!$file || $file eq 'STDERR') {
	open $DBI::tfh, ">&STDERR" or carp "Can't dup STDERR: $!";
    }
    elsif ($file eq 'STDOUT') {
	open $DBI::tfh, ">&STDOUT" or carp "Can't dup STDOUT: $!";
    }
    else {
        open $DBI::tfh, ">>$file" or carp "Can't open $file: $!";
    }
    select((select($DBI::tfh), $| = 1)[0]);
    return 1;
}
sub _get_imp_data {  shift->{"imp_data"}; }
sub _svdump       { }
sub dump_handle   {
    my ($h,$msg,$level) = @_;
    $msg||="dump_handle $h";
    print $DBI::tfh "$msg:\n";
    for my $attrib (sort keys %$h) {
	print $DBI::tfh "\t$attrib => ".DBI::neat($h->{$attrib})."\n";
    }
}

sub _handles {
    my $h = shift;
    my $h_inner = tied %$h;
    if ($h_inner) {	# this is okay
	return $h unless wantarray;
	return ($h, $h_inner);
    }
    # XXX this isn't okay... we have an inner handle but
    # currently have no way to get at its outer handle,
    # so we just warn and return the inner one for both...
    Carp::carp("Can't return outer handle from inner handle using DBI::PurePerl");
    return $h unless wantarray;
    return ($h,$h);
}

sub hash {
    my ($key, $type) = @_;
    my ($hash);
    if (!$type) {
        $hash = 0;
        # XXX The C version uses the "char" type, which could be either
        # signed or unsigned.  I use signed because so do the two
        # compilers on my system.
        for my $char (unpack ("c*", $key)) {
            $hash = $hash * 33 + $char;
        }
        $hash &= 0x7FFFFFFF;    # limit to 31 bits
        $hash |= 0x40000000;    # set bit 31
        return -$hash;          # return negative int
    }
    elsif ($type == 1) {	# Fowler/Noll/Vo hash
        # see http://www.isthe.com/chongo/tech/comp/fnv/
        require Math::BigInt;   # feel free to reimplement w/o BigInt!
	(my $version = $Math::BigInt::VERSION || 0) =~ s/_.*//; # eg "1.70_01"
	if ($version >= 1.56) {
	    $hash = Math::BigInt->new(0x811c9dc5);
	    for my $uchar (unpack ("C*", $key)) {
		# multiply by the 32 bit FNV magic prime mod 2^64
		$hash = ($hash * 0x01000193) & 0xffffffff;
		# xor the bottom with the current octet
		$hash ^= $uchar;
	    }
	    # cast to int
	    return unpack "i", pack "i", $hash;
	}
	croak("DBI::PurePerl doesn't support hash type 1 without Math::BigInt >= 1.56 (available on CPAN)");
    }
    else {
        croak("bad hash type $type");
    }
}
sub looks_like_number {
    my @new = ();
    for my $thing(@_) {
        if (!defined $thing or $thing eq '') {
            push @new, undef;
        }
        else {
            push @new, ($thing =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/) ? 1 : 0;
        }
    }
    return (@_ >1) ? @new : $new[0];
}

sub neat {
    my $v = shift;
    return "undef" unless defined $v;
    my $quote = q{"};
    if (not utf8::is_utf8($v)) {
        return $v if (($v & ~ $v) eq "0"); # is SvNIOK
        $quote = q{'};
    }
    my $maxlen = shift || $DBI::neat_maxlen;
    if ($maxlen && $maxlen < length($v) + 2) {
	$v = substr($v,0,$maxlen-5);
	$v .= '...';
    }
    return "$quote$v$quote";
}

sub dbi_time {
    return time();
}

sub DBI::st::TIEHASH { bless $_[1] => $_[0] };

package
	DBI::var;

sub FETCH {
    my($key)=shift;
    return $DBI::err     if $$key eq '*err';
    return $DBI::errstr  if $$key eq '&errstr';
    Carp::confess("FETCH $key not supported when using DBI::PurePerl");
}

package
	DBD::_::common;

sub swap_inner_handle {
    my ($h1, $h2) = @_;
    # can't make this work till we can get the outer handle from the inner one
    # probably via a WeakRef
    return $h1->set_err($DBI::stderr, "swap_inner_handle not currently supported by DBI::PurePerl");
}

sub trace {	# XXX should set per-handle level, not global
    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;
    DBI::_set_trace_file($file) if defined $file;
    if (defined $level) {
	$DBI::dbi_debug = $level;
	if ($DBI::dbi_debug) {
	    printf $DBI::tfh
		"    %s trace level set to %d in DBI $DBI::VERSION (PurePerl)\n",
		$h, $DBI::dbi_debug;
	    print $DBI::tfh "    Full trace not available because DBI_TRACE is not in environment\n"
		unless exists $ENV{DBI_TRACE};
	}
    }
    return $old_level;
}
*debug = \&trace; *debug = \&trace; # twice to avoid typo warning

sub FETCH {
    my($h,$key)= @_;
    my $v = $h->{$key};
    #warn ((exists $h->{$key}) ? "$key=$v\n" : "$key NONEXISTANT\n");
    return $v if defined $v;
    if ($key =~ /^NAME_.c$/) {
        my $cols = $h->FETCH('NAME');
        return undef unless $cols;
        my @lcols = map { lc $_ } @$cols;
        $h->{NAME_lc} = \@lcols;
        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]/) {
	    local $^W; # 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') {