gofer.pm

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

{
    package DBD::Gofer;

    use strict;

    require DBI;
    require DBI::Gofer::Request;
    require DBI::Gofer::Response;
    require Carp;

    our $VERSION = sprintf("0.%06d", q$Revision: 10103 $ =~ /(\d+)/o);

#   $Id: Gofer.pm 10103 2007-10-21 22:05:38Z timbo $
#
#   Copyright (c) 2007, Tim Bunce, Ireland
#
#   You may distribute under the terms of either the GNU General Public
#   License or the Artistic License, as specified in the Perl README file.



    # attributes we'll allow local STORE
    our %xxh_local_store_attrib = map { $_=>1 } qw(
        Active
        CachedKids
        Callbacks
        DbTypeSubclass
        ErrCount Executed
        FetchHashKeyName
        HandleError HandleSetErr
        InactiveDestroy
        PrintError PrintWarn
        Profile
        RaiseError
        RootClass
        ShowErrorStatement
        Taint TaintIn TaintOut
        TraceLevel
        Warn
        dbi_quote_identifier_cache
        dbi_connect_closure
        dbi_go_execute_unique
    );
    our %xxh_local_store_attrib_if_same_value = map { $_=>1 } qw(
        Username
        dbi_connect_method
    );

    our $drh = undef;    # holds driver handle once initialised
    our $methods_already_installed;

    sub driver{
        return $drh if $drh;

        DBI->setup_driver('DBD::Gofer');

        unless ($methods_already_installed++) {
            my $opts = { O=> 0x0004 }; # IMA_KEEP_ERR
            DBD::Gofer::db->install_method('go_dbh_method', $opts);
            DBD::Gofer::st->install_method('go_sth_method', $opts);
            DBD::Gofer::st->install_method('go_clone_sth',  $opts);
            DBD::Gofer::db->install_method('go_cache',      $opts);
            DBD::Gofer::st->install_method('go_cache',      $opts);
        }

        my($class, $attr) = @_;
        $class .= "::dr";
        ($drh) = DBI::_new_drh($class, {
            'Name' => 'Gofer',
            'Version' => $VERSION,
            'Attribution' => 'DBD Gofer by Tim Bunce',
        });

        $drh;
    }


    sub CLONE {
        undef $drh;
    }


    sub go_cache {
        my $h = shift;
        $h->{go_cache} = shift if @_;
        # return handle's override go_cache, if it has one
        return $h->{go_cache} if defined $h->{go_cache};
        # or else the transports default go_cache
        return $h->{go_transport}->{go_cache};
    }


    sub set_err_from_response { # set error/warn/info and propagate warnings
        my ($h, $response) = @_;
        if (my $warnings = $response->warnings) {
            warn $_ for @$warnings;
        }
        return $h->set_err($response->err, $response->errstr, $response->state);
    }


    sub install_methods_proxy {
        my ($installed_methods) = @_;
        while ( my ($full_method, $attr) = each %$installed_methods ) {
            # need to install both a DBI dispatch stub and a proxy stub
            # (the dispatch stub may be already here due to local driver use)

            DBI->_install_method($full_method, "", $attr||{})
                unless defined &{$full_method};

            # now install proxy stubs on the driver side
            $full_method =~ m/^DBI::(\w\w)::(\w+)$/
                or die "Invalid method name '$full_method' for install_method";
            my ($type, $method) = ($1, $2);
            my $driver_method = "DBD::Gofer::${type}::${method}";
            next if defined &{$driver_method};
            my $sub;
            if ($type eq 'db') {
                $sub = sub { return shift->go_dbh_method(undef, $method, @_) };
            }
            else {
                $sub = sub { shift->set_err($DBI::stderr, "Can't call \$${type}h->$method when using DBD::Gofer"); return; };
            }
            no strict 'refs';
            *$driver_method = $sub;
        }
    }
}


{   package DBD::Gofer::dr; # ====== DRIVER ======

    $imp_data_size = 0;
    use strict;

    sub connect_cached {
        my ($drh, $dsn, $user, $auth, $attr)= @_;
        $attr ||= {};
        return $drh->SUPER::connect_cached($dsn, $user, $auth, {
            (%$attr),
            go_connect_method => $attr->{go_connect_method} || 'connect_cached',
        });
    }


    sub connect {
        my($drh, $dsn, $user, $auth, $attr)= @_;
        my $orig_dsn = $dsn;

        # first remove dsn= and everything after it
        my $remote_dsn = ($dsn =~ s/;?\bdsn=(.*)$// && $1)
            or return $drh->set_err($DBI::stderr, "No dsn= argument in '$orig_dsn'");

        if ($attr->{go_bypass}) { # don't use DBD::Gofer for this connection
            # useful for testing with DBI_AUTOPROXY, e.g., t/03handle.t
            return DBI->connect($remote_dsn, $user, $auth, $attr);
        }

        my %go_attr;
        # extract any go_ attributes from the connect() attr arg
        for my $k (grep { /^go_/ } keys %$attr) {
            $go_attr{$k} = delete $attr->{$k};
        }
        # then override those with any attributes embedded in our dsn (not remote_dsn)
        for my $kv (grep /=/, split /;/, $dsn, -1) {
            my ($k, $v) = split /=/, $kv, 2;
            $go_attr{ "go_$k" } = $v;
        }

        if (not ref $go_attr{go_policy}) { # if not a policy object already
            my $policy_class = $go_attr{go_policy} || 'classic';
            $policy_class = "DBD::Gofer::Policy::$policy_class"
                unless $policy_class =~ /::/;
            _load_class($policy_class)
                or return $drh->set_err($DBI::stderr, "Can't load $policy_class: $@");
            # replace policy name in %go_attr with policy object
            $go_attr{go_policy} = eval { $policy_class->new(\%go_attr) }
                or return $drh->set_err($DBI::stderr, "Can't instanciate $policy_class: $@");
        }
        # policy object is left in $go_attr{go_policy} so transport can see it
        my $go_policy = $go_attr{go_policy};

        if ($go_attr{go_cache} and not ref $go_attr{go_cache}) { # if not a cache object already
            my $cache_class = $go_attr{go_cache};
            $cache_class = "DBI::Util::CacheMemory" if $cache_class eq '1';
            _load_class($cache_class)
                or return $drh->set_err($DBI::stderr, "Can't load $cache_class $@");
            $go_attr{go_cache} = eval { $cache_class->new() }
                or $drh->set_err(0, "Can't instanciate $cache_class: $@"); # warning
        }

        # delete any other attributes that don't apply to transport
        my $go_connect_method = delete $go_attr{go_connect_method};

        my $transport_class = delete $go_attr{go_transport}
            or return $drh->set_err($DBI::stderr, "No transport= argument in '$orig_dsn'");
        $transport_class = "DBD::Gofer::Transport::$transport_class"
            unless $transport_class =~ /::/;
        _load_class($transport_class)
            or return $drh->set_err($DBI::stderr, "Can't load $transport_class: $@");
        my $go_transport = eval { $transport_class->new(\%go_attr) }
            or return $drh->set_err($DBI::stderr, "Can't instanciate $transport_class: $@");

        my $request_class = "DBI::Gofer::Request";
        my $go_request = eval {
            my $go_attr = { %$attr };
            # XXX user/pass of fwd server vs db server ? also impact of autoproxy
            if ($user) {
                $go_attr->{Username} = $user;
                $go_attr->{Password} = $auth;
            }
            # delete any attributes we can't serialize (or don't want to)
            delete @{$go_attr}{qw(Profile HandleError HandleSetErr Callbacks)};
            # delete any attributes that should only apply to the client-side
            delete @{$go_attr}{qw(RootClass DbTypeSubclass)};

            $go_connect_method ||= $go_policy->connect_method($remote_dsn, $go_attr) || 'connect';
            $request_class->new({
                dbh_connect_call => [ $go_connect_method, $remote_dsn, $user, $auth, $go_attr ],
            })
        } or return $drh->set_err($DBI::stderr, "Can't instanciate $request_class: $@");

        my ($dbh, $dbh_inner) = DBI::_new_dbh($drh, {
            'Name' => $dsn,
            'USER' => $user,
            go_transport => $go_transport,
            go_request => $go_request,
            go_policy => $go_policy,
        });

        # mark as inactive temporarily for STORE. Active not set until connected() called.
        $dbh->STORE(Active => 0);

        # should we ping to check the connection
        # and fetch dbh attributes
        my $skip_connect_check = $go_policy->skip_connect_check($attr, $dbh);
        if (not $skip_connect_check) {
            if (not $dbh->go_dbh_method(undef, 'ping')) {
                return undef if $dbh->err; # error already recorded, typically
                return $dbh->set_err($DBI::stderr, "ping failed");
            }
        }

        return $dbh;
    }

    sub _load_class { # return true or false+$@
        my $class = shift;
        (my $pm = $class) =~ s{::}{/}g;
        $pm .= ".pm";
        return 1 if eval { require $pm };
        delete $INC{$pm}; # shouldn't be needed (perl bug?) and assigning undef isn't enough
        undef; # error in $@
    }

}


{   package DBD::Gofer::db; # ====== DATABASE ======
    $imp_data_size = 0;
    use strict;
    use Carp qw(carp croak);

    my %dbh_local_store_attrib = %DBD::Gofer::xxh_local_store_attrib;

    sub connected {
        shift->STORE(Active => 1);
    }

    sub go_dbh_method {
        my $dbh = shift;
        my $meta = shift;
        # @_ now contains ($method_name, @args)

        my $request = $dbh->{go_request};
        $request->init_request([ wantarray, @_ ], $dbh);
        ++$dbh->{go_request_count};

        my $go_policy = $dbh->{go_policy};
        my $dbh_attribute_update = $go_policy->dbh_attribute_update();
        $request->dbh_attributes( $go_policy->dbh_attribute_list() )
            if $dbh_attribute_update eq 'every'
            or $dbh->{go_request_count}==1;

        $request->dbh_last_insert_id_args($meta->{go_last_insert_id_args})
            if $meta->{go_last_insert_id_args};

        my $transport = $dbh->{go_transport}
            or return $dbh->set_err($DBI::stderr, "Not connected (no transport)");

        local $transport->{go_cache} = $dbh->{go_cache}
            if defined $dbh->{go_cache};

        my ($response, $retransmit_sub) = $transport->transmit_request($request);
        $response ||= $transport->receive_response($request, $retransmit_sub);
        $dbh->{go_response} = $response
            or die "No response object returned by $transport";

        die "response '$response' returned by $transport is not a response object"
            unless UNIVERSAL::isa($response,"DBI::Gofer::Response");

        if (my $dbh_attributes = $response->dbh_attributes) {

            # XXX installed_methods piggbacks on dbh_attributes for now
            if (my $installed_methods = delete $dbh_attributes->{dbi_installed_methods}) {
                DBD::Gofer::install_methods_proxy($installed_methods)
                    if $dbh->{go_request_count}==1;
            }

            # XXX we don't STORE here, we just stuff the value into the attribute cache
            $dbh->{$_} = $dbh_attributes->{$_}
                for keys %$dbh_attributes;
        }

        my $rv = $response->rv;
        if (my $resultset_list = $response->sth_resultsets) {
            # dbh method call returned one or more resultsets
            # (was probably a metadata method like table_info)
            #
            # setup an sth but don't execute/forward it