execute.pm

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

package DBI::Gofer::Execute;

#   $Id: Execute.pm 10087 2007-10-16 12:42:37Z 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.

use strict;
use warnings;

use DBI qw(dbi_time);
use DBI::Gofer::Request;
use DBI::Gofer::Response;

use base qw(DBI::Util::_accessor);

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

our @all_dbh_methods = sort map { keys %$_ } $DBI::DBI_methods{db}, $DBI::DBI_methods{common};
our %all_dbh_methods = map { $_ => (DBD::_::db->can($_)||undef) } @all_dbh_methods;

our $local_log = $ENV{DBI_GOFER_LOCAL_LOG}; # do extra logging to stderr

our $current_dbh;   # the dbh we're using for this request


# set trace for server-side gofer
# Could use DBI_TRACE env var when it's an unrelated separate process
# but using DBI_GOFER_TRACE makes testing easier for subprocesses (eg stream)
DBI->trace(split /=/, $ENV{DBI_GOFER_TRACE}, 2) if $ENV{DBI_GOFER_TRACE};


# define valid configuration attributes (args to new())
# the values here indicate the basic type of values allowed
my %configuration_attributes = (
    default_connect_dsn => 1,
    forced_connect_dsn  => 1,
    default_connect_attributes => {},
    forced_connect_attributes  => {},
    track_recent => 1,
    check_request_sub => sub {},
    check_response_sub => sub {},
    forced_single_resultset => 1,
    max_cached_dbh_per_drh => 1,
    max_cached_sth_per_dbh => 1,
    forced_response_attributes => {},
    forced_gofer_random => 1,
    stats => {},
);

__PACKAGE__->mk_accessors(
    keys %configuration_attributes
);



sub new {
    my ($self, $args) = @_;
    $args->{default_connect_attributes} ||= {};
    $args->{forced_connect_attributes}  ||= {};
    $args->{max_cached_sth_per_dbh}     ||= 1000;
    $args->{stats} ||= {};
    return $self->SUPER::new($args);
}


sub valid_configuration_attributes {
    my $self = shift;
    return { %configuration_attributes };
}


my %extra_attr = (
    # Only referenced if the driver doesn't support private_attribute_info method.
    # What driver-specific attributes should be returned for the driver being used?
    # keyed by $dbh->{Driver}{Name}
    # XXX for sth should split into attr specific to resultsets (where NUM_OF_FIELDS > 0) and others
    # which would reduce processing/traffic for non-select statements
    mysql  => {
        dbh => [qw(
            mysql_errno mysql_error mysql_hostinfo mysql_info mysql_insertid
            mysql_protoinfo mysql_serverinfo mysql_stat mysql_thread_id
        )],
        sth => [qw(
            mysql_is_blob mysql_is_key mysql_is_num mysql_is_pri_key mysql_is_auto_increment
            mysql_length mysql_max_length mysql_table mysql_type mysql_type_name mysql_insertid
        )],
        # XXX this dbh_after_sth stuff is a temporary, but important, hack.
        # should be done via hash instead of arrays where the hash value contains
        # flags that can indicate which attributes need to be handled in this way
        dbh_after_sth => [qw(
            mysql_insertid
        )],
    },
    Pg  => {
        dbh => [qw(
            pg_protocol pg_lib_version pg_server_version
            pg_db pg_host pg_port pg_default_port
            pg_options pg_pid
        )],
        sth => [qw(
            pg_size pg_type pg_oid_status pg_cmd_status
        )],
    },
    Sybase => {
        dbh => [qw(
            syb_dynamic_supported syb_oc_version syb_server_version syb_server_version_string
        )],
        sth => [qw(
            syb_types syb_proc_status syb_result_type
        )],
    },
    SQLite => {
        dbh => [qw(
            sqlite_version
        )],
        sth => [qw(
        )],
    },
    ExampleP => {
        dbh => [qw(
            examplep_private_dbh_attrib
        )],
        sth => [qw(
            examplep_private_sth_attrib
        )],
        dbh_after_sth => [qw(
            examplep_insertid
        )],
    },
);


sub _connect {
    my ($self, $request) = @_;

    my $stats = $self->{stats};

    # discard CachedKids from time to time
    if (++$stats->{_requests_served} % 1000 == 0 # XXX config?
        and my $max_cached_dbh_per_drh = $self->{max_cached_dbh_per_drh}
    ) {
        my %drivers = DBI->installed_drivers();
        while ( my ($driver, $drh) = each %drivers ) {
            next unless my $CK = $drh->{CachedKids};
            next unless keys %$CK > $max_cached_dbh_per_drh;
            next if $driver eq 'Gofer'; # ie transport=null when testing
            DBI->trace_msg(sprintf "Clearing %d cached dbh from $driver",
                scalar keys %$CK, $self->{max_cached_dbh_per_drh});
            $_->{Active} && $_->disconnect for values %$CK;
            %$CK = ();
        }
    }

    local $ENV{DBI_AUTOPROXY}; # limit the insanity

    my ($connect_method, $dsn, $username, $password, $attr) = @{ $request->dbh_connect_call };
    $connect_method ||= 'connect_cached';

    # delete attributes we don't want to affect the server-side
    # (Could just do this on client-side and trust the client. DoS?)
    delete @{$attr}{qw(Profile InactiveDestroy HandleError HandleSetErr TraceLevel Taint TaintIn TaintOut)};

    $dsn = $self->forced_connect_dsn || $dsn || $self->default_connect_dsn
        or die "No forced_connect_dsn, requested dsn, or default_connect_dsn for request";

    # ensure this connect_cached doesn't have the same args as the client
    # because that causes subtle issues if in the same process (ie transport=null)
    # include pid to avoid problems with forking (ie null transport in mod_perl)
    # include gofer-random to avoid random behaviour leaking to other handles
    my $extra_cache_key = join "|",
        __PACKAGE__, "$$", $self->{forced_gofer_random} || $ENV{DBI_GOFER_RANDOM} || '';

    # XXX implement our own private connect_cached method? (with rate-limited ping)
    my $dbh = DBI->$connect_method($dsn, undef, undef, {

        # the configured default attributes, if any
        %{ $self->default_connect_attributes },

        # pass username and password as attributes
        # then they can be overridden by forced_connect_attributes
        Username => $username,
        Password => $password,

        # the requested attributes
        %$attr,

        # force some attributes the way we'd like them
        PrintWarn  => $local_log,
        PrintError => $local_log,

        # the configured default attributes, if any
        %{ $self->forced_connect_attributes },

        # RaiseError must be enabled
        RaiseError => 1,

        # reset Executed flag (of the cached handle) so we can use it to tell
        # if errors happened before the main part of the request was executed
        Executed => 0,

        # ensure connect_cached is sufficiently distinct
        dbi_go_execute_unique => $extra_cache_key,
    });

    $dbh->{ShowErrorStatement} = 1 if $local_log;

    # XXX should probably just be a Callbacks => arg to connect_cached
    # with a cache of pre-built callback hoks (memoized, without $self) 
    if (my $random = $self->{forced_gofer_random} || $ENV{DBI_GOFER_RANDOM}) {
        $self->_install_rand_callbacks($dbh, $random);
    }

    my $CK = $dbh->{CachedKids};
    if ($CK && keys %$CK > $self->{max_cached_sth_per_dbh}) {
        %$CK = (); #  clear all statement handles
    }

    #$dbh->trace(0);
    $current_dbh = $dbh;
    return $dbh;
}


sub reset_dbh {
    my ($self, $dbh) = @_;
    $dbh->set_err(undef, undef); # clear any error state
}


sub new_response_with_err {
    my ($self, $rv, $eval_error, $dbh) = @_;
    # capture err+errstr etc and merge in $eval_error ($@)

    my ($err, $errstr, $state) = ($DBI::err, $DBI::errstr, $DBI::state);

    # if we caught an exception and there's either no DBI error, or the
    # exception itself doesn't look like a DBI exception, then append the
    # exception to errstr
    if ($eval_error and (!$errstr || $eval_error !~ /^DBD::/)) {
        chomp $eval_error;
        $err ||= 1;
        $errstr = ($errstr) ? "$errstr; $eval_error" : $eval_error;
    }

    my $flags;
    # (XXX if we ever add transaction support then we'll need to take extra
    # steps because the commit/rollback would reset Executed before we get here)
    $flags |= GOf_RESPONSE_EXECUTED if $dbh && $dbh->{Executed};

    my $response = DBI::Gofer::Response->new({
        rv     => $rv,
        err    => $err,
        errstr => $errstr,
        state  => $state,
        flags  => $flags,
    });

    return $response;
}


sub execute_request {
    my ($self, $request) = @_;
    # should never throw an exception

    DBI->trace_msg("-----> execute_request\n");

    my @warnings;
    local $SIG{__WARN__} = sub { push @warnings, @_; warn @_ if $local_log };

    my $response = eval {

        if (my $check_request_sub = $self->check_request_sub) {
            $request = $check_request_sub->($request, $self)
                or die "check_request_sub failed";
        }

        my $version = $request->version || 0;
        die ref($request)." version $version is not supported"
            if $version < 0.009116 or $version >= 1;

        ($request->is_sth_request)
            ? $self->execute_sth_request($request)
            : $self->execute_dbh_request($request);
    };
    $response ||= $self->new_response_with_err(undef, $@, $current_dbh);

    if (my $check_response_sub = $self->check_response_sub) {
        # not protected with an eval so it can choose to throw an exception
        my $new = $check_response_sub->($response, $self, $request);
        $response = $new if ref $new;
    }

    undef $current_dbh;

    $response->warnings(\@warnings) if @warnings;
    DBI->trace_msg("<----- execute_request\n");
    return $response;
}


sub execute_dbh_request {
    my ($self, $request) = @_;
    my $stats = $self->{stats};

    my $dbh;
    my $rv_ref = eval {
        $dbh = $self->_connect($request);
        my $args = $request->dbh_method_call; # [ wantarray, 'method_name', @args ]
        my $wantarray = shift @$args;
        my $meth      = shift @$args;
        $stats->{method_calls_dbh}->{$meth}++;
        my @rv = ($wantarray)
            ?        $dbh->$meth(@$args)
            : scalar $dbh->$meth(@$args);
        \@rv;
    } || [];
    my $response = $self->new_response_with_err($rv_ref, $@, $dbh);

    return $response if not $dbh;

    # does this request also want any dbh attributes returned?
    if (my $dbh_attributes = $request->dbh_attributes) {
        $response->dbh_attributes( $self->gather_dbh_attributes($dbh, $dbh_attributes) );
    }

    if ($rv_ref and my $lid_args = $request->dbh_last_insert_id_args) {
        $stats->{method_calls_dbh}->{last_insert_id}++;
        my $id = $dbh->last_insert_id( @$lid_args );
        $response->last_insert_id( $id );
    }

    if ($rv_ref and UNIVERSAL::isa($rv_ref->[0],'DBI::st')) {
        # dbh_method_call was probably a metadata method like table_info
        # that returns a statement handle, so turn the $sth into resultset
        my $sth = $rv_ref->[0];
        $response->sth_resultsets( $self->gather_sth_resultsets($sth, $request, $response) );
        $response->rv("(sth)"); # don't try to return actual sth
    }

    # we're finished with this dbh for this request
    $self->reset_dbh($dbh);

    return $response;
}


sub gather_dbh_attributes {
    my ($self, $dbh, $dbh_attributes) = @_;
    my @req_attr_names = @$dbh_attributes;
    if ($req_attr_names[0] eq '*') { # auto include std + private
        shift @req_attr_names;
        push @req_attr_names, @{ $self->_std_response_attribute_names($dbh) };
    }
    my %dbh_attr_values;
    @dbh_attr_values{@req_attr_names} = $dbh->FETCH_many(@req_attr_names);

    # XXX piggyback installed_methods onto dbh_attributes for now
    $dbh_attr_values{dbi_installed_methods} = { DBI->installed_methods };
    
    # XXX piggyback default_methods onto dbh_attributes for now
    $dbh_attr_values{dbi_default_methods} = _get_default_methods($dbh);
    
    return \%dbh_attr_values;
}


sub _std_response_attribute_names {
    my ($self, $h) = @_;
    $h = tied(%$h) || $h; # switch to inner handle

    # cache the private_attribute_info data for each handle
    # XXX might be better to cache it in the executor
    # as it's unlikely to change
    # or perhaps at least cache it in the dbh even for sth
    # as the sth are typically very short lived

    my ($dbh, $h_type, $driver_name, @attr_names);

    if ($dbh = $h->{Database}) {    # is an sth

        # does the dbh already have the answer cached?
        return $dbh->{private_gofer_std_attr_names_sth} if $dbh->{private_gofer_std_attr_names_sth};

        ($h_type, $driver_name) = ('sth', $dbh->{Driver}{Name});
        push @attr_names, qw(NUM_OF_PARAMS NUM_OF_FIELDS NAME TYPE NULLABLE PRECISION SCALE);
    }
    else {                          # is a dbh
        return $h->{private_gofer_std_attr_names_dbh} if $h->{private_gofer_std_attr_names_dbh};

        ($h_type, $driver_name, $dbh) = ('dbh', $h->{Driver}{Name}, $h);
        # explicitly add these because drivers may have different defaults
        # add Name so the client gets the real Name of the connection
        push @attr_names, qw(ChopBlanks LongReadLen LongTruncOk ReadOnly Name);
    }

    if (my $pai = $h->private_attribute_info) {
        push @attr_names, keys %$pai;
    }
    else {
        push @attr_names, @{ $extra_attr{ $driver_name }{$h_type} || []};
    }
    if (my $fra = $self->{forced_response_attributes}) {
        push @attr_names, @{ $fra->{ $driver_name }{$h_type} || []}
    }
    $dbh->trace_msg("_std_response_attribute_names for $driver_name $h_type: @attr_names\n");

    # cache into the dbh even for sth, as the dbh is usually longer lived
    return $dbh->{"private_gofer_std_attr_names_$h_type"} = \@attr_names;
}


sub execute_sth_request {
    my ($self, $request) = @_;
    my $dbh;
    my $sth;
    my $last_insert_id;
    my $stats = $self->{stats};