gofer.pm

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

            my $sth = $dbh->prepare(undef, { go_skip_prepare_check => 1 });
            # set the sth response to our dbh response
            (tied %$sth)->{go_response} = $response;
            # setup the sth with the results in our response
            $sth->more_results;
            # and return that new sth as if it came from original request
            $rv = [ $sth ];
        }

        DBD::Gofer::set_err_from_response($dbh, $response);

        return (wantarray) ? @$rv : $rv->[0];
    }


    # Methods that should be forwarded but can be cached
    for my $method (qw(
        tables table_info column_info primary_key_info foreign_key_info statistics_info
        data_sources type_info_all get_info
        parse_trace_flags parse_trace_flag
        func
    )) {
        my $policy_name = "cache_$method";
        my $super_name  = "SUPER::$method";
        my $sub = sub {
            my $dbh = shift;
            my $rv;

            # if we know the remote side doesn't override the DBI's default method
            # then we might as well just call the DBI's default method on the client
            # (which may, in turn, call other methods that are forwarded, like get_info)
            if ($dbh->{dbi_default_methods}{$method} && $dbh->{go_policy}->skip_default_methods()) {
                $dbh->trace_msg("    !! $method: using local default as remote method is also default\n");
                return $dbh->$super_name(@_);
            }

            my $cache;
            my $cache_key;
            if (my $cache_it = $dbh->{go_policy}->$policy_name(undef, $dbh, @_)) {
                $cache = $dbh->{go_meta_cache} ||= {}; # keep separate from go_cache
                $cache_key = sprintf "%s_wa%d(%s)", $policy_name, wantarray||0,
                    join(",\t", map { # XXX basic but sufficient for now
                         !ref($_)            ? DBI::neat($_,1e6)
                        : ref($_) eq 'ARRAY' ? DBI::neat_list($_,1e6,",\001")
                        : ref($_) eq 'HASH'  ? do { my @k = sort keys %$_; DBI::neat_list([@k,@{$_}{@k}],1e6,",\002") }
                        : do { warn "unhandled argument type ($_)"; $_ }
                    } @_);
                if ($rv = $cache->{$cache_key}) {
                    $dbh->trace_msg("$method(@_) returning previously cached value ($cache_key)\n",4);
                    my @cache_rv = @$rv;
                    # if it's an sth we have to clone it
                    $cache_rv[0] = $cache_rv[0]->go_clone_sth if UNIVERSAL::isa($cache_rv[0],'DBI::st');
                    return (wantarray) ? @cache_rv : $cache_rv[0];
                }
            }

            $rv = [ (wantarray)
                ?       ($dbh->go_dbh_method(undef, $method, @_))
                : scalar $dbh->go_dbh_method(undef, $method, @_)
            ];

            if ($cache) {
                $dbh->trace_msg("$method(@_) caching return value ($cache_key)\n",4);
                my @cache_rv = @$rv;
                # if it's an sth we have to clone it
                #$cache_rv[0] = $cache_rv[0]->go_clone_sth
                #   if UNIVERSAL::isa($cache_rv[0],'DBI::st');
                $cache->{$cache_key} = \@cache_rv
                    unless UNIVERSAL::isa($cache_rv[0],'DBI::st'); # XXX cloning sth not yet done
            }

            return (wantarray) ? @$rv : $rv->[0];
        };
        no strict 'refs';
        *$method = $sub;
    }


    # Methods that can use the DBI defaults for some situations/drivers
    for my $method (qw(
        quote quote_identifier
    )) {    # XXX keep DBD::Gofer::Policy::Base in sync
        my $policy_name = "locally_$method";
        my $super_name  = "SUPER::$method";
        my $sub = sub {
            my $dbh = shift;

            # if we know the remote side doesn't override the DBI's default method
            # then we might as well just call the DBI's default method on the client
            # (which may, in turn, call other methods that are forwarded, like get_info)
            if ($dbh->{dbi_default_methods}{$method} && $dbh->{go_policy}->skip_default_methods()) {
                $dbh->trace_msg("    !! $method: using local default as remote method is also default\n");
                return $dbh->$super_name(@_);
            }

            # false:    use remote gofer
            # 1:        use local DBI default method
            # code ref: use the code ref
            my $locally = $dbh->{go_policy}->$policy_name($dbh, @_);
            if ($locally) {
                return $locally->($dbh, @_) if ref $locally eq 'CODE';
                return $dbh->$super_name(@_);
            }
            return $dbh->go_dbh_method(undef, $method, @_); # propagate context
        };
        no strict 'refs';
        *$method = $sub;
    }


    # Methods that should always fail
    for my $method (qw(
        begin_work commit rollback
    )) {
        no strict 'refs';
        *$method = sub { return shift->set_err($DBI::stderr, "$method not available with DBD::Gofer") }
    }


    sub do {
        my ($dbh, $sql, $attr, @args) = @_;
        delete $dbh->{Statement}; # avoid "Modification of non-creatable hash value attempted"
        $dbh->{Statement} = $sql; # for profiling and ShowErrorStatement
        my $meta = { go_last_insert_id_args => $attr->{go_last_insert_id_args} };
        return $dbh->go_dbh_method($meta, 'do', $sql, $attr, @args);
    }

    sub ping {
        my $dbh = shift;
        return $dbh->set_err(0, "can't ping while not connected") # warning
            unless $dbh->SUPER::FETCH('Active');
        my $skip_ping = $dbh->{go_policy}->skip_ping();
        return ($skip_ping) ? 1 : $dbh->go_dbh_method(undef, 'ping', @_);
    }

    sub last_insert_id {
        my $dbh = shift;
        my $response = $dbh->{go_response} or return undef;
        return $response->last_insert_id;
    }

    sub FETCH {
        my ($dbh, $attrib) = @_;

        # FETCH is effectively already cached because the DBI checks the
        # attribute cache in the handle before calling FETCH
        # and this FETCH copies the value into the attribute cache

        # forward driver-private attributes (except ours)
        if ($attrib =~ m/^[a-z]/ && $attrib !~ /^go_/) {
            my $value = $dbh->go_dbh_method(undef, 'FETCH', $attrib);
            $dbh->{$attrib} = $value; # XXX forces caching by DBI
            return $dbh->{$attrib} = $value;
        }

        # else pass up to DBI to handle
        return $dbh->SUPER::FETCH($attrib);
    }

    sub STORE {
        my ($dbh, $attrib, $value) = @_;
        if ($attrib eq 'AutoCommit') {
            croak "Can't enable transactions when using DBD::Gofer" if !$value;
            return $dbh->SUPER::STORE($attrib => ($value) ? -901 : -900);
        }
        return $dbh->SUPER::STORE($attrib => $value)
            # we handle this attribute locally
            if $dbh_local_store_attrib{$attrib}
            # or it's a private_ (application) attribute
            or $attrib =~ /^private_/
            # or not yet connected (ie being called by DBI->connect)
            or not $dbh->FETCH('Active');

        return $dbh->SUPER::STORE($attrib => $value)
            if $DBD::Gofer::xxh_local_store_attrib_if_same_value{$attrib}
            && do { # values are the same
                my $crnt = $dbh->FETCH($attrib);
                local $^W;
                (defined($value) ^ defined($crnt))
                    ? 0 # definedness differs
                    : $value eq $crnt;
            };

        # dbh attributes are set at connect-time - see connect()
        carp("Can't alter \$dbh->{$attrib} after handle created with DBD::Gofer") if $dbh->FETCH('Warn');
        return $dbh->set_err($DBI::stderr, "Can't alter \$dbh->{$attrib} after handle created with DBD::Gofer");
    }

    sub disconnect {
        my $dbh = shift;
        $dbh->{go_transport} = undef;
        $dbh->STORE(Active => 0);
    }

    sub prepare {
        my ($dbh, $statement, $attr)= @_;

        return $dbh->set_err($DBI::stderr, "Can't prepare when disconnected")
            unless $dbh->FETCH('Active');

        $attr = { %$attr } if $attr; # copy so we can edit

        my $policy     = delete($attr->{go_policy}) || $dbh->{go_policy};
        my $lii_args   = delete $attr->{go_last_insert_id_args};
        my $go_prepare = delete($attr->{go_prepare_method})
                      || $dbh->{go_prepare_method}
                      || $policy->prepare_method($dbh, $statement, $attr)
                      || 'prepare'; # e.g. for code not using placeholders
        my $go_cache = delete $attr->{go_cache};
        # set to undef if there are no attributes left for the actual prepare call
        $attr = undef if $attr and not %$attr;

        my ($sth, $sth_inner) = DBI::_new_sth($dbh, {
            Statement => $statement,
            go_prepare_call => [ 0, $go_prepare, $statement, $attr ],
            # go_method_calls => [], # autovivs if needed
            go_request => $dbh->{go_request},
            go_transport => $dbh->{go_transport},
            go_policy => $policy,
            go_last_insert_id_args => $lii_args,
            go_cache => $go_cache,
        });
        $sth->STORE(Active => 0);

        my $skip_prepare_check = $policy->skip_prepare_check($attr, $dbh, $statement, $attr, $sth);
        if (not $skip_prepare_check) {
            $sth->go_sth_method() or return undef;
        }

        return $sth;
    }

    sub prepare_cached {
        my ($dbh, $sql, $attr, $if_active)= @_;
        $attr ||= {};
        return $dbh->SUPER::prepare_cached($sql, {
            %$attr,
            go_prepare_method => $attr->{go_prepare_method} || 'prepare_cached',
        }, $if_active);
    }

    *go_cache = \&DBD::Gofer::go_cache;
}


{   package DBD::Gofer::st; # ====== STATEMENT ======
    $imp_data_size = 0;
    use strict;

    my %sth_local_store_attrib = (%DBD::Gofer::xxh_local_store_attrib, NUM_OF_FIELDS => 1);

    sub go_sth_method {
        my ($sth, $meta) = @_;

        if (my $ParamValues = $sth->{ParamValues}) {
            my $ParamAttr = $sth->{ParamAttr};
            # XXX the sort here is a hack to work around a DBD::Sybase bug
            # but only works properly for params 1..9
            # (reverse because of the unshift)
            my @params = reverse sort keys %$ParamValues;
            if (@params > 9 && $sth->{Database}{go_dsn} =~ /dbi:Sybase/) {
                # if more than 9 then we need to do a proper numeric sort
                # also warn to alert user of this issue
                warn "Sybase param binding order hack in use";
                @params = sort { $b <=> $a } @params;
            }
            for my $p (@params) {
                # unshift to put binds before execute call
                unshift @{ $sth->{go_method_calls} },
                    [ 'bind_param', $p, $ParamValues->{$p}, $ParamAttr->{$p} ];
            }
        }

        my $dbh = $sth->{Database} or die "panic";
        ++$dbh->{go_request_count};

        my $request = $sth->{go_request};
        $request->init_request($sth->{go_prepare_call}, $sth);
        $request->sth_method_calls(delete $sth->{go_method_calls})
            if $sth->{go_method_calls};
        $request->sth_result_attr({}); # (currently) also indicates this is an sth request

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

        my $go_policy = $sth->{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;

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

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

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

        if (my $dbh_attributes = $response->dbh_attributes) {
            # XXX we don't STORE here, we just stuff the value into the attribute cache
            $dbh->{$_} = $dbh_attributes->{$_}
                for keys %$dbh_attributes;
            # record the values returned, so we know that we have fetched
            # values are which we have fetched (see dbh->FETCH method)
            $dbh->{go_dbh_attributes_fetched} = $dbh_attributes;
        }

        my $rv = $response->rv;
        if ($response->sth_resultsets) {
            # setup first resultset - including sth attributes
            $sth->more_results;
        }
        else {
            $sth->STORE(Active => 0);
            $sth->{go_rows} = $response->rv;