asda?‰PNG  IHDR ? f ??C1 sRGB ??é gAMA ±? üa pHYs ? ??o¨d GIDATx^íüL”÷e÷Y?a?("Bh?_ò???￠§?q5k?*:t0A-o??￥]VkJ￠M??f?±8\k2íll￡1]q?ù???T Request.pm000064400000012164151027616360006545 0ustar00package DBI::Gofer::Request; # $Id: Request.pm 12536 2009-02-24 22:37:09Z Tim $ # # 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 DBI qw(neat neat_list); use base qw(DBI::Util::_accessor); our $VERSION = "0.012537"; use constant GOf_REQUEST_IDEMPOTENT => 0x0001; use constant GOf_REQUEST_READONLY => 0x0002; our @EXPORT = qw(GOf_REQUEST_IDEMPOTENT GOf_REQUEST_READONLY); __PACKAGE__->mk_accessors(qw( version flags dbh_connect_call dbh_method_call dbh_attributes dbh_last_insert_id_args sth_method_calls sth_result_attr )); __PACKAGE__->mk_accessors_using(make_accessor_autoviv_hashref => qw( meta )); sub new { my ($self, $args) = @_; $args->{version} ||= $VERSION; return $self->SUPER::new($args); } sub reset { my ($self, $flags) = @_; # remove everything except connect and version %$self = ( version => $self->{version}, dbh_connect_call => $self->{dbh_connect_call}, ); $self->{flags} = $flags if $flags; } sub init_request { my ($self, $method_and_args, $dbh) = @_; $self->reset( $dbh->{ReadOnly} ? GOf_REQUEST_READONLY : 0 ); $self->dbh_method_call($method_and_args); } sub is_sth_request { return shift->{sth_result_attr}; } sub statements { my $self = shift; my @statements; if (my $dbh_method_call = $self->dbh_method_call) { my $statement_method_regex = qr/^(?:do|prepare)$/; my (undef, $method, $arg1) = @$dbh_method_call; push @statements, $arg1 if $method && $method =~ $statement_method_regex; } return @statements; } sub is_idempotent { my $self = shift; if (my $flags = $self->flags) { return 1 if $flags & (GOf_REQUEST_IDEMPOTENT|GOf_REQUEST_READONLY); } # else check if all statements are SELECT statement that don't include FOR UPDATE my @statements = $self->statements; # XXX this is very minimal for now, doesn't even allow comments before the select # (and can't ever work for "exec stored_procedure_name" kinds of statements) # XXX it also doesn't deal with multiple statements: prepare("select foo; update bar") return 1 if @statements == grep { m/^ \s* SELECT \b /xmsi && !m/ \b FOR \s+ UPDATE \b /xmsi } @statements; return 0; } sub summary_as_text { my $self = shift; my ($context) = @_; my @s = ''; if ($context && %$context) { my @keys = sort keys %$context; push @s, join(", ", map { "$_=>".$context->{$_} } @keys); } my ($method, $dsn, $user, $pass, $attr) = @{ $self->dbh_connect_call }; $method ||= 'connect_cached'; $pass = '***' if defined $pass; my $tmp = ''; if ($attr) { $tmp = { %{$attr||{}} }; # copy so we can edit $tmp->{Password} = '***' if exists $tmp->{Password}; $tmp = "{ ".neat_list([ %$tmp ])." }"; } push @s, sprintf "dbh= $method(%s, %s)", neat_list([$dsn, $user, $pass]), $tmp; if (my $flags = $self->flags) { push @s, sprintf "flags: 0x%x", $flags; } if (my $dbh_attr = $self->dbh_attributes) { push @s, sprintf "dbh->FETCH: %s", @$dbh_attr if @$dbh_attr; } my ($wantarray, $meth, @args) = @{ $self->dbh_method_call }; my $args = neat_list(\@args); $args =~ s/\n+/ /g; push @s, sprintf "dbh->%s(%s)", $meth, $args; if (my $lii_args = $self->dbh_last_insert_id_args) { push @s, sprintf "dbh->last_insert_id(%s)", neat_list($lii_args); } for my $call (@{ $self->sth_method_calls || [] }) { my ($meth, @args) = @$call; ($args = neat_list(\@args)) =~ s/\n+/ /g; push @s, sprintf "sth->%s(%s)", $meth, $args; } if (my $sth_attr = $self->sth_result_attr) { push @s, sprintf "sth->FETCH: %s", %$sth_attr if %$sth_attr; } return join("\n\t", @s) . "\n"; } sub outline_as_text { # one-line version of summary_as_text my $self = shift; my @s = ''; my $neatlen = 80; if (my $flags = $self->flags) { push @s, sprintf "flags=0x%x", $flags; } my (undef, $meth, @args) = @{ $self->dbh_method_call }; push @s, sprintf "%s(%s)", $meth, neat_list(\@args, $neatlen); for my $call (@{ $self->sth_method_calls || [] }) { my ($meth, @args) = @$call; push @s, sprintf "%s(%s)", $meth, neat_list(\@args, $neatlen); } my ($method, $dsn) = @{ $self->dbh_connect_call }; push @s, "$method($dsn,...)"; # dsn last as it's usually less interesting (my $outline = join("; ", @s)) =~ s/\s+/ /g; # squish whitespace, incl newlines return $outline; } 1; =head1 NAME DBI::Gofer::Request - Encapsulate a request from DBD::Gofer to DBI::Gofer::Execute =head1 DESCRIPTION This is an internal class. =head1 AUTHOR Tim Bunce, L =head1 LICENCE AND COPYRIGHT Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. =cut Serializer/DataDumper.pm000064400000002437151027616360011256 0ustar00package DBI::Gofer::Serializer::DataDumper; use strict; use warnings; our $VERSION = "0.009950"; # $Id: DataDumper.pm 9949 2007-09-18 09:38:15Z Tim $ # # 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. =head1 NAME DBI::Gofer::Serializer::DataDumper - Gofer serialization using DataDumper =head1 SYNOPSIS $serializer = DBI::Gofer::Serializer::DataDumper->new(); $string = $serializer->serialize( $data ); =head1 DESCRIPTION Uses DataDumper to serialize. Deserialization is not supported. The output of this class is only meant for human consumption. See also L. =cut use Data::Dumper; use base qw(DBI::Gofer::Serializer::Base); sub serialize { my $self = shift; local $Data::Dumper::Indent = 1; local $Data::Dumper::Terse = 1; local $Data::Dumper::Useqq = 0; # enabling this disables xs local $Data::Dumper::Sortkeys = 1; local $Data::Dumper::Quotekeys = 0; local $Data::Dumper::Deparse = 0; local $Data::Dumper::Purity = 0; my $frozen = Data::Dumper::Dumper(shift); return $frozen unless wantarray; return ($frozen, $self->{deserializer_class}); } 1; Serializer/Storable.pm000064400000002641151027616360011000 0ustar00package DBI::Gofer::Serializer::Storable; use strict; use warnings; use base qw(DBI::Gofer::Serializer::Base); # $Id: Storable.pm 15585 2013-03-22 20:31:22Z Tim $ # # 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. =head1 NAME DBI::Gofer::Serializer::Storable - Gofer serialization using Storable =head1 SYNOPSIS $serializer = DBI::Gofer::Serializer::Storable->new(); $string = $serializer->serialize( $data ); ($string, $deserializer_class) = $serializer->serialize( $data ); $data = $serializer->deserialize( $string ); =head1 DESCRIPTION Uses Storable::nfreeze() to serialize and Storable::thaw() to deserialize. The serialize() method sets local $Storable::forgive_me = 1; so it doesn't croak if it encounters any data types that can't be serialized, such as code refs. See also L. =cut use Storable qw(nfreeze thaw); our $VERSION = "0.015586"; use base qw(DBI::Gofer::Serializer::Base); sub serialize { my $self = shift; local $Storable::forgive_me = 1; # for CODE refs etc local $Storable::canonical = 1; # for go_cache my $frozen = nfreeze(shift); return $frozen unless wantarray; return ($frozen, $self->{deserializer_class}); } sub deserialize { my $self = shift; return thaw(shift); } 1; Serializer/Base.pm000064400000002735151027616360010103 0ustar00package DBI::Gofer::Serializer::Base; # $Id: Base.pm 9949 2007-09-18 09:38:15Z Tim $ # # 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. =head1 NAME DBI::Gofer::Serializer::Base - base class for Gofer serialization =head1 SYNOPSIS $serializer = $serializer_class->new(); $string = $serializer->serialize( $data ); ($string, $deserializer_class) = $serializer->serialize( $data ); $data = $serializer->deserialize( $string ); =head1 DESCRIPTION DBI::Gofer::Serializer::* classes implement a very minimal subset of the L API. Gofer serializers are expected to be very fast and are not required to deal with anything other than non-blessed references to arrays and hashes, and plain scalars. =cut use strict; use warnings; use Carp qw(croak); our $VERSION = "0.009950"; sub new { my $class = shift; my $deserializer_class = $class->deserializer_class; return bless { deserializer_class => $deserializer_class } => $class; } sub deserializer_class { my $self = shift; my $class = ref($self) || $self; $class =~ s/^DBI::Gofer::Serializer:://; return $class; } sub serialize { my $self = shift; croak ref($self)." has not implemented the serialize method"; } sub deserialize { my $self = shift; croak ref($self)." has not implemented the deserialize method"; } 1; Execute.pm000064400000074634151027616360006531 0ustar00package DBI::Gofer::Execute; # $Id: Execute.pm 14282 2010-07-26 00:12:54Z David $ # # 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 Carp; use DBI qw(dbi_time); use DBI::Gofer::Request; use DBI::Gofer::Response; use base qw(DBI::Util::_accessor); our $VERSION = "0.014283"; 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 = ( gofer_execute_class => 1, 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{...} can leak, so only do it if required local $ENV{DBI_AUTOPROXY} if $ENV{DBI_AUTOPROXY}; my ($connect_method, $dsn, $username, $password, $attr) = @{ $request->dbh_connect_call }; $connect_method ||= 'connect_cached'; $stats->{method_calls_dbh}->{$connect_method}++; # 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 AutoInactiveDestroy 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"; my $random = $self->{forced_gofer_random} || $ENV{DBI_GOFER_RANDOM} || ''; my $connect_attr = { # 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 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 dbi_go_execute_unique => join("|", __PACKAGE__, $$, $random), }; # XXX implement our own private connect_cached method? (with rate-limited ping) my $dbh = DBI->$connect_method($dsn, undef, undef, $connect_attr); $dbh->{ShowErrorStatement} = 1 if $local_log; # XXX should probably just be a Callbacks => arg to connect_cached # with a cache of pre-built callback hooks (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) = @_; # this is the usual way to create a response for both success and failure # capture err+errstr etc and merge in $eval_error ($@) my ($err, $errstr, $state) = ($DBI::err, $DBI::errstr, $DBI::state); if ($eval_error) { $err ||= $DBI::stderr || 1; # ensure err is true if ($errstr) { $eval_error =~ s/(?: : \s)? \Q$errstr//x if $errstr; chomp $errstr; $errstr .= "; $eval_error"; } else { $errstr = $eval_error; } } chomp $errstr if $errstr; 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}; my $rv = eval { $dbh = $self->_connect($request); my $args = $request->dbh_method_call; # [ wantarray, 'method_name', @args ] shift @$args; # discard wantarray my $meth = shift @$args; $stats->{method_calls_sth}->{$meth}++; $sth = $dbh->$meth(@$args); my $last = '(sth)'; # a true value (don't try to return actual sth) # execute methods on the sth, e.g., bind_param & execute if (my $calls = $request->sth_method_calls) { for my $meth_call (@$calls) { my $method = shift @$meth_call; $stats->{method_calls_sth}->{$method}++; $last = $sth->$method(@$meth_call); } } if (my $lid_args = $request->dbh_last_insert_id_args) { $stats->{method_calls_sth}->{last_insert_id}++; $last_insert_id = $dbh->last_insert_id( @$lid_args ); } $last; }; my $response = $self->new_response_with_err($rv, $@, $dbh); return $response if not $dbh; $response->last_insert_id( $last_insert_id ) if defined $last_insert_id; # even if the eval failed we still want to try to gather attribute values # (XXX would be nice to be able to support streaming of results. # which would reduce memory usage and latency for large results) if ($sth) { $response->sth_resultsets( $self->gather_sth_resultsets($sth, $request, $response) ); $sth->finish; } # does this request also want any dbh attributes returned? my $dbh_attr_set; if (my $dbh_attributes = $request->dbh_attributes) { $dbh_attr_set = $self->gather_dbh_attributes($dbh, $dbh_attributes); } # XXX needs to be integrated with private_attribute_info() etc if (my $dbh_attr = $extra_attr{$dbh->{Driver}{Name}}{dbh_after_sth}) { @{$dbh_attr_set}{@$dbh_attr} = $dbh->FETCH_many(@$dbh_attr); } $response->dbh_attributes($dbh_attr_set) if $dbh_attr_set && %$dbh_attr_set; $self->reset_dbh($dbh); return $response; } sub gather_sth_resultsets { my ($self, $sth, $request, $response) = @_; my $resultsets = eval { my $attr_names = $self->_std_response_attribute_names($sth); my $sth_attr = {}; $sth_attr->{$_} = 1 for @$attr_names; # let the client add/remove sth attributes if (my $sth_result_attr = $request->sth_result_attr) { $sth_attr->{$_} = $sth_result_attr->{$_} for keys %$sth_result_attr; } my @sth_attr = grep { $sth_attr->{$_} } keys %$sth_attr; my $row_count = 0; my $rs_list = []; while (1) { my $rs = $self->fetch_result_set($sth, \@sth_attr); push @$rs_list, $rs; if (my $rows = $rs->{rowset}) { $row_count += @$rows; } last if $self->{forced_single_resultset}; last if !($sth->more_results || $sth->{syb_more_results}); } my $stats = $self->{stats}; $stats->{rows_returned_total} += $row_count; $stats->{rows_returned_max} = $row_count if $row_count > ($stats->{rows_returned_max}||0); $rs_list; }; $response->add_err(1, $@) if $@; return $resultsets; } sub fetch_result_set { my ($self, $sth, $sth_attr) = @_; my %meta; eval { @meta{ @$sth_attr } = $sth->FETCH_many(@$sth_attr); # we assume @$sth_attr contains NUM_OF_FIELDS $meta{rowset} = $sth->fetchall_arrayref() if (($meta{NUM_OF_FIELDS}||0) > 0); # is SELECT # the fetchall_arrayref may fail with a 'not executed' kind of error # because gather_sth_resultsets/fetch_result_set are called even if # execute() failed, or even if there was no execute() call at all. # The corresponding error goes into the resultset err, not the top-level # response err, so in most cases this resultset err is never noticed. }; if ($@) { chomp $@; $meta{err} = $DBI::err || 1; $meta{errstr} = $DBI::errstr || $@; $meta{state} = $DBI::state; } return \%meta; } sub _get_default_methods { my ($dbh) = @_; # returns a ref to a hash of dbh method names for methods which the driver # hasn't overridden i.e., quote(). These don't need to be forwarded via gofer. my $ImplementorClass = $dbh->{ImplementorClass} or die; my %default_methods; for my $method (@all_dbh_methods) { my $dbi_sub = $all_dbh_methods{$method} || 42; my $imp_sub = $ImplementorClass->can($method) || 42; next if $imp_sub != $dbi_sub; #warn("default $method\n"); $default_methods{$method} = 1; } return \%default_methods; } # XXX would be nice to make this a generic DBI module sub _install_rand_callbacks { my ($self, $dbh, $dbi_gofer_random) = @_; my $callbacks = $dbh->{Callbacks} || {}; my $prev = $dbh->{private_gofer_rand_fail_callbacks} || {}; # return if we've already setup this handle with callbacks for these specs return if (($callbacks->{_dbi_gofer_random_spec}||'') eq $dbi_gofer_random); #warn "$dbh # $callbacks->{_dbi_gofer_random_spec}"; $callbacks->{_dbi_gofer_random_spec} = $dbi_gofer_random; my ($fail_percent, $fail_err, $delay_percent, $delay_duration, %spec_part, @spec_note); my @specs = split /,/, $dbi_gofer_random; for my $spec (@specs) { if ($spec =~ m/^fail=(-?[.\d]+)%?$/) { $fail_percent = $1; $spec_part{fail} = $spec; next; } if ($spec =~ m/^err=(-?\d+)$/) { $fail_err = $1; $spec_part{err} = $spec; next; } if ($spec =~ m/^delay([.\d]+)=(-?[.\d]+)%?$/) { $delay_duration = $1; $delay_percent = $2; $spec_part{delay} = $spec; next; } elsif ($spec !~ m/^(\w+|\*)$/) { warn "Ignored DBI_GOFER_RANDOM item '$spec' which isn't a config or a dbh method name"; next; } my $method = $spec; if ($callbacks->{$method} && $prev->{$method} && $callbacks->{$method} != $prev->{$method}) { warn "Callback for $method method already installed so DBI_GOFER_RANDOM callback not installed\n"; next; } unless (defined $fail_percent or defined $delay_percent) { warn "Ignored DBI_GOFER_RANDOM item '$spec' because not preceded by 'fail=N' and/or 'delayN=N'"; next; } push @spec_note, join(",", values(%spec_part), $method); $callbacks->{$method} = $self->_mk_rand_callback($method, $fail_percent, $delay_percent, $delay_duration, $fail_err); } warn "DBI_GOFER_RANDOM failures/delays enabled: @spec_note\n" if @spec_note; $dbh->{Callbacks} = $callbacks; $dbh->{private_gofer_rand_fail_callbacks} = $callbacks; } my %_mk_rand_callback_seqn; sub _mk_rand_callback { my ($self, $method, $fail_percent, $delay_percent, $delay_duration, $fail_err) = @_; my ($fail_modrate, $delay_modrate); $fail_percent ||= 0; $fail_modrate = int(1/(-$fail_percent )*100) if $fail_percent; $delay_percent ||= 0; $delay_modrate = int(1/(-$delay_percent)*100) if $delay_percent; # note that $method may be "*" but that's not recommended or documented or wise return sub { my ($h) = @_; my $seqn = ++$_mk_rand_callback_seqn{$method}; my $delay = ($delay_percent > 0) ? rand(100) < $delay_percent : ($delay_percent < 0) ? !($seqn % $delay_modrate): 0; my $fail = ($fail_percent > 0) ? rand(100) < $fail_percent : ($fail_percent < 0) ? !($seqn % $fail_modrate) : 0; #no warnings 'uninitialized'; #warn "_mk_rand_callback($fail_percent:$fail_modrate, $delay_percent:$delay_modrate): seqn=$seqn fail=$fail delay=$delay"; if ($delay) { my $msg = "DBI_GOFER_RANDOM delaying execution of $method() by $delay_duration seconds\n"; # Note what's happening in a trace message. If the delay percent is an even # number then use warn() instead so it's sent back to the client. ($delay_percent % 2 == 1) ? warn($msg) : $h->trace_msg($msg); select undef, undef, undef, $delay_duration; # allows floating point value } if ($fail) { undef $_; # tell DBI to not call the method # the "induced by DBI_GOFER_RANDOM" is special and must be included in errstr # as it's checked for in a few places, such as the gofer retry logic return $h->set_err($fail_err || $DBI::stderr, "fake error from $method method induced by DBI_GOFER_RANDOM env var ($fail_percent%)"); } return; } } sub update_stats { my ($self, $request, $response, $frozen_request, $frozen_response, $time_received, $store_meta, $other_meta, ) = @_; # should always have a response object here carp("No response object provided") unless $request; my $stats = $self->{stats}; $stats->{frozen_request_max_bytes} = length($frozen_request) if $frozen_request && length($frozen_request) > ($stats->{frozen_request_max_bytes}||0); $stats->{frozen_response_max_bytes} = length($frozen_response) if $frozen_response && length($frozen_response) > ($stats->{frozen_response_max_bytes}||0); my $recent; if (my $track_recent = $self->{track_recent}) { $recent = { request => $frozen_request, response => $frozen_response, time_received => $time_received, duration => dbi_time()-$time_received, # for any other info ($store_meta) ? (meta => $store_meta) : (), }; $recent->{request_object} = $request if !$frozen_request && $request; $recent->{response_object} = $response if !$frozen_response; my @queues = ($stats->{recent_requests} ||= []); push @queues, ($stats->{recent_errors} ||= []) if !$response or $response->err; for my $queue (@queues) { push @$queue, $recent; shift @$queue if @$queue > $track_recent; } } return $recent; } 1; __END__ =head1 NAME DBI::Gofer::Execute - Executes Gofer requests and returns Gofer responses =head1 SYNOPSIS $executor = DBI::Gofer::Execute->new( { ...config... }); $response = $executor->execute_request( $request ); =head1 DESCRIPTION Accepts a DBI::Gofer::Request object, executes the requested DBI method calls, and returns a DBI::Gofer::Response object. Any error, including any internal 'fatal' errors are caught and converted into a DBI::Gofer::Response object. This module is usually invoked by a 'server-side' Gofer transport module. They usually have names in the "C" namespace. Examples include: L and L. =head1 CONFIGURATION =head2 check_request_sub If defined, it must be a reference to a subroutine that will 'check' the request. It is passed the request object and the executor as its only arguments. The subroutine can either return the original request object or die with a suitable error message (which will be turned into a Gofer response). It can also construct and return a new request that should be executed instead of the original request. =head2 check_response_sub If defined, it must be a reference to a subroutine that will 'check' the response. It is passed the response object, the executor, and the request object. The sub may alter the response object and return undef, or return a new response object. This mechanism can be used to, for example, terminate the service if specific database errors are seen. =head2 forced_connect_dsn If set, this DSN is always used instead of the one in the request. =head2 default_connect_dsn If set, this DSN is used if C is not set and the request does not contain a DSN itself. =head2 forced_connect_attributes A reference to a hash of connect() attributes. Individual attributes in C will take precedence over corresponding attributes in the request. =head2 default_connect_attributes A reference to a hash of connect() attributes. Individual attributes in the request take precedence over corresponding attributes in C. =head2 max_cached_dbh_per_drh If set, the loaded drivers will be checked to ensure they don't have more than this number of cached connections. There is no default value. This limit is not enforced for every request. =head2 max_cached_sth_per_dbh If set, all the cached statement handles will be cleared once the number of cached statement handles rises above this limit. The default is 1000. =head2 forced_single_resultset If true, then only the first result set will be fetched and returned in the response. =head2 forced_response_attributes A reference to a data structure that can specify extra attributes to be returned in responses. forced_response_attributes => { DriverName => { dbh => [ qw(dbh_attrib_name) ], sth => [ qw(sth_attrib_name) ], }, }, This can be useful in cases where the driver has not implemented the private_attribute_info() method and DBI::Gofer::Execute's own fallback list of private attributes doesn't include the driver or attributes you need. =head2 track_recent If set, specifies the number of recent requests and responses that should be kept by the update_stats() method for diagnostics. See L. Note that this setting can significantly increase memory use. Use with caution. =head2 forced_gofer_random Enable forced random failures and/or delays for testing. See L below. =head1 DRIVER-SPECIFIC ISSUES Gofer needs to know about any driver-private attributes that should have their values sent back to the client. If the driver doesn't support private_attribute_info() method, and very few do, then the module fallsback to using some hard-coded details, if available, for the driver being used. Currently hard-coded details are available for the mysql, Pg, Sybase, and SQLite drivers. =head1 TESTING DBD::Gofer, DBD::Execute and related packages are well tested by executing the DBI test suite with DBI_AUTOPROXY configured to route all DBI calls via DBD::Gofer. Because Gofer includes timeout and 'retry on error' mechanisms there is a need for some way to trigger delays and/or errors. This can be done via the C configuration item, or else the DBI_GOFER_RANDOM environment variable. =head2 DBI_GOFER_RANDOM The value of the C configuration item (or else the DBI_GOFER_RANDOM environment variable) is treated as a series of tokens separated by commas. The tokens can be one of three types: =over 4 =item fail=R% Set the current failure rate to R where R is a percentage. The value R can be floating point, e.g., C. Negative values for R have special meaning, see below. =item err=N Sets the current failure err value to N (instead of the DBI's default 'standard err value' of 2000000000). This is useful when you want to simulate a specific error. =item delayN=R% Set the current random delay rate to R where R is a percentage, and set the current delay duration to N seconds. The values of R and N can be floating point, e.g., C. Negative values for R have special meaning, see below. If R is an odd number (R % 2 == 1) then a message is logged via warn() which will be returned to, and echoed at, the client. =item methodname Applies the current fail, err, and delay values to the named method. If neither a fail nor delay have been set yet then a warning is generated. =back For example: $executor = DBI::Gofer::Execute->new( { forced_gofer_random => "fail=0.01%,do,delay60=1%,execute", }); will cause the do() method to fail for 0.01% of calls, and the execute() method to fail 0.01% of calls and be delayed by 60 seconds on 1% of calls. If the percentage value (C) is negative then instead of the failures being triggered randomly (via the rand() function) they are triggered via a sequence number. In other words "C" will mean every fifth call will fail. Each method has a distinct sequence number. =head1 AUTHOR Tim Bunce, L =head1 LICENCE AND COPYRIGHT Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. =cut Response.pm000064400000014123151027616360006710 0ustar00package DBI::Gofer::Response; # $Id: Response.pm 11565 2008-07-22 20:17:33Z Tim $ # # 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 Carp; use DBI qw(neat neat_list); use base qw(DBI::Util::_accessor Exporter); our $VERSION = "0.011566"; use constant GOf_RESPONSE_EXECUTED => 0x0001; our @EXPORT = qw(GOf_RESPONSE_EXECUTED); __PACKAGE__->mk_accessors(qw( version rv err errstr state flags last_insert_id dbh_attributes sth_resultsets warnings )); __PACKAGE__->mk_accessors_using(make_accessor_autoviv_hashref => qw( meta )); sub new { my ($self, $args) = @_; $args->{version} ||= $VERSION; chomp $args->{errstr} if $args->{errstr}; return $self->SUPER::new($args); } sub err_errstr_state { my $self = shift; return @{$self}{qw(err errstr state)}; } sub executed_flag_set { my $flags = shift->flags or return 0; return $flags & GOf_RESPONSE_EXECUTED; } sub add_err { my ($self, $err, $errstr, $state, $trace) = @_; # acts like the DBI's set_err method. # this code copied from DBI::PurePerl's set_err method. chomp $errstr if $errstr; $state ||= ''; carp ref($self)."->add_err($err, $errstr, $state)" if $trace and defined($err) || $errstr; my ($r_err, $r_errstr, $r_state) = ($self->{err}, $self->{errstr}, $self->{state}); if ($r_errstr) { $r_errstr .= sprintf " [err was %s now %s]", $r_err, $err if $r_err && $err && $r_err ne $err; $r_errstr .= sprintf " [state was %s now %s]", $r_state, $state if $r_state and $r_state ne "S1000" && $state && $r_state ne $state; $r_errstr .= "\n$errstr" if $r_errstr ne $errstr; } else { $r_errstr = $errstr; } # assign if higher priority: err > "0" > "" > undef my $err_changed; if ($err # new error: so assign or !defined $r_err # no existing warn/info: so assign # new warn ("0" len 1) > info ("" len 0): so assign or defined $err && length($err) > length($r_err) ) { $r_err = $err; ++$err_changed; } $r_state = ($state eq "00000") ? "" : $state if $state && $err_changed; ($self->{err}, $self->{errstr}, $self->{state}) = ($r_err, $r_errstr, $r_state); return undef; } sub summary_as_text { my $self = shift; my ($context) = @_; my ($rv, $err, $errstr, $state) = ($self->{rv}, $self->{err}, $self->{errstr}, $self->{state}); my @s = sprintf("\trv=%s", (ref $rv) ? "[".neat_list($rv)."]" : neat($rv)); $s[-1] .= sprintf(", err=%s, errstr=%s", $err, neat($errstr)) if defined $err; $s[-1] .= sprintf(", flags=0x%x", $self->{flags}) if defined $self->{flags}; push @s, "last_insert_id=%s", $self->last_insert_id if defined $self->last_insert_id; if (my $dbh_attr = $self->dbh_attributes) { my @keys = sort keys %$dbh_attr; push @s, sprintf "dbh= { %s }", join(", ", map { "$_=>".neat($dbh_attr->{$_},100) } @keys) if @keys; } for my $rs (@{$self->sth_resultsets || []}) { my ($rowset, $err, $errstr, $state) = @{$rs}{qw(rowset err errstr state)}; my $summary = "rowset: "; my $NUM_OF_FIELDS = $rs->{NUM_OF_FIELDS} || 0; my $rows = $rowset ? @$rowset : 0; if ($rowset || $NUM_OF_FIELDS > 0) { $summary .= sprintf "%d rows, %d columns", $rows, $NUM_OF_FIELDS; } $summary .= sprintf ", err=%s, errstr=%s", $err, neat($errstr) if defined $err; if ($rows) { my $NAME = $rs->{NAME}; # generate my @colinfo = map { "$NAME->[$_]=".neat($rowset->[0][$_], 30) } 0..@{$NAME}-1; $summary .= sprintf " [%s]", join ", ", @colinfo; $summary .= ",..." if $rows > 1; # we can be a little more helpful for Sybase/MSSQL user $summary .= " syb_result_type=$rs->{syb_result_type}" if $rs->{syb_result_type} and $rs->{syb_result_type} != 4040; } push @s, $summary; } for my $w (@{$self->warnings || []}) { chomp $w; push @s, "warning: $w"; } if ($context && %$context) { my @keys = sort keys %$context; push @s, join(", ", map { "$_=>".$context->{$_} } @keys); } return join("\n\t", @s). "\n"; } sub outline_as_text { # one-line version of summary_as_text my $self = shift; my ($context) = @_; my ($rv, $err, $errstr, $state) = ($self->{rv}, $self->{err}, $self->{errstr}, $self->{state}); my $s = sprintf("rv=%s", (ref $rv) ? "[".neat_list($rv)."]" : neat($rv)); $s .= sprintf(", err=%s %s", $err, neat($errstr)) if defined $err; $s .= sprintf(", flags=0x%x", $self->{flags}) if $self->{flags}; if (my $sth_resultsets = $self->sth_resultsets) { $s .= sprintf(", %d resultsets ", scalar @$sth_resultsets); my @rs; for my $rs (@{$self->sth_resultsets || []}) { my $summary = ""; my ($rowset, $err, $errstr) = @{$rs}{qw(rowset err errstr)}; my $NUM_OF_FIELDS = $rs->{NUM_OF_FIELDS} || 0; my $rows = $rowset ? @$rowset : 0; if ($rowset || $NUM_OF_FIELDS > 0) { $summary .= sprintf "%dr x %dc", $rows, $NUM_OF_FIELDS; } $summary .= sprintf "%serr %s %s", ($summary?", ":""), $err, neat($errstr) if defined $err; push @rs, $summary; } $s .= join "; ", map { "[$_]" } @rs; } return $s; } 1; =head1 NAME DBI::Gofer::Response - Encapsulate a response from DBI::Gofer::Execute to DBD::Gofer =head1 DESCRIPTION This is an internal class. =head1 AUTHOR Tim Bunce, L =head1 LICENCE AND COPYRIGHT Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. =cut Transport/pipeone.pm000064400000016203151027616360010546 0ustar00package DBD::Gofer::Transport::pipeone; # $Id: pipeone.pm 10087 2007-10-16 12:42:37Z Tim $ # # 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 Carp; use Fcntl; use IO::Select; use IPC::Open3 qw(open3); use Symbol qw(gensym); use base qw(DBD::Gofer::Transport::Base); our $VERSION = "0.010088"; __PACKAGE__->mk_accessors(qw( connection_info go_perl )); sub new { my ($self, $args) = @_; $args->{go_perl} ||= do { ($INC{"blib.pm"}) ? [ $^X, '-Mblib' ] : [ $^X ]; }; if (not ref $args->{go_perl}) { # user can override the perl to be used, either with an array ref # containing the command name and args to use, or with a string # (ie via the DSN) in which case, to enable args to be passed, # we split on two or more consecutive spaces (otherwise the path # to perl couldn't contain a space itself). $args->{go_perl} = [ split /\s{2,}/, $args->{go_perl} ]; } return $self->SUPER::new($args); } # nonblock($fh) puts filehandle into nonblocking mode sub nonblock { my $fh = shift; my $flags = fcntl($fh, F_GETFL, 0) or croak "Can't get flags for filehandle $fh: $!"; fcntl($fh, F_SETFL, $flags | O_NONBLOCK) or croak "Can't make filehandle $fh nonblocking: $!"; } sub start_pipe_command { my ($self, $cmd) = @_; $cmd = [ $cmd ] unless ref $cmd eq 'ARRAY'; # if it's important that the subprocess uses the same # (versions of) modules as us then the caller should # set PERL5LIB itself. # limit various forms of insanity, for now local $ENV{DBI_TRACE}; # use DBI_GOFER_TRACE instead local $ENV{DBI_AUTOPROXY}; local $ENV{DBI_PROFILE}; my ($wfh, $rfh, $efh) = (gensym, gensym, gensym); my $pid = open3($wfh, $rfh, $efh, @$cmd) or die "error starting @$cmd: $!\n"; if ($self->trace) { $self->trace_msg(sprintf("Started pid $pid: @$cmd {fd: w%d r%d e%d, ppid=$$}\n", fileno $wfh, fileno $rfh, fileno $efh),0); } nonblock($rfh); nonblock($efh); my $ios = IO::Select->new($rfh, $efh); return { cmd=>$cmd, pid=>$pid, wfh=>$wfh, rfh=>$rfh, efh=>$efh, ios=>$ios, }; } sub cmd_as_string { my $self = shift; # XXX meant to return a properly shell-escaped string suitable for system # but its only for debugging so that can wait my $connection_info = $self->connection_info; return join " ", map { (m/^[-:\w]*$/) ? $_ : "'$_'" } @{$connection_info->{cmd}}; } sub transmit_request_by_transport { my ($self, $request) = @_; my $frozen_request = $self->freeze_request($request); my $cmd = [ @{$self->go_perl}, qw(-MDBI::Gofer::Transport::pipeone -e run_one_stdio)]; my $info = $self->start_pipe_command($cmd); my $wfh = delete $info->{wfh}; # send frozen request local $\; print $wfh $frozen_request or warn "error writing to @$cmd: $!\n"; # indicate that there's no more close $wfh or die "error closing pipe to @$cmd: $!\n"; $self->connection_info( $info ); return; } sub read_response_from_fh { my ($self, $fh_actions) = @_; my $trace = $self->trace; my $info = $self->connection_info || die; my ($ios) = @{$info}{qw(ios)}; my $errors = 0; my $complete; die "No handles to read response from" unless $ios->count; while ($ios->count) { my @readable = $ios->can_read(); for my $fh (@readable) { local $_; my $actions = $fh_actions->{$fh} || die "panic: no action for $fh"; my $rv = sysread($fh, $_='', 1024*31); # to fit in 32KB slab unless ($rv) { # error (undef) or end of file (0) my $action; unless (defined $rv) { # was an error $self->trace_msg("error on handle $fh: $!\n") if $trace >= 4; $action = $actions->{error} || $actions->{eof}; ++$errors; # XXX an error may be a permenent condition of the handle # if so we'll loop here - not good } else { $action = $actions->{eof}; $self->trace_msg("eof on handle $fh\n") if $trace >= 4; } if ($action->($fh)) { $self->trace_msg("removing $fh from handle set\n") if $trace >= 4; $ios->remove($fh); } next; } # action returns true if the response is now complete # (we finish all handles $actions->{read}->($fh) && ++$complete; } last if $complete; } return $errors; } sub receive_response_by_transport { my $self = shift; my $info = $self->connection_info || die; my ($pid, $rfh, $efh, $ios, $cmd) = @{$info}{qw(pid rfh efh ios cmd)}; my $frozen_response; my $stderr_msg; $self->read_response_from_fh( { $efh => { error => sub { warn "error reading response stderr: $!"; 1 }, eof => sub { warn "eof on stderr" if 0; 1 }, read => sub { $stderr_msg .= $_; 0 }, }, $rfh => { error => sub { warn "error reading response: $!"; 1 }, eof => sub { warn "eof on stdout" if 0; 1 }, read => sub { $frozen_response .= $_; 0 }, }, }); waitpid $info->{pid}, 0 or warn "waitpid: $!"; # XXX do something more useful? die ref($self)." command (@$cmd) failed: $stderr_msg" if not $frozen_response; # no output on stdout at all # XXX need to be able to detect and deal with corruption my $response = $self->thaw_response($frozen_response); if ($stderr_msg) { # add stderr messages as warnings (for PrintWarn) $response->add_err(0, $stderr_msg, undef, $self->trace) # but ignore warning from old version of blib unless $stderr_msg =~ /^Using .*blib/ && "@$cmd" =~ /-Mblib/; } return $response; } 1; __END__ =head1 NAME DBD::Gofer::Transport::pipeone - DBD::Gofer client transport for testing =head1 SYNOPSIS $original_dsn = "..."; DBI->connect("dbi:Gofer:transport=pipeone;dsn=$original_dsn",...) or, enable by setting the DBI_AUTOPROXY environment variable: export DBI_AUTOPROXY="dbi:Gofer:transport=pipeone" =head1 DESCRIPTION Connect via DBD::Gofer and execute each request by starting executing a subprocess. This is, as you might imagine, spectacularly inefficient! It's only intended for testing. Specifically it demonstrates that the server side is completely stateless. It also provides a base class for the much more useful L transport. =head1 AUTHOR Tim Bunce, L =head1 LICENCE AND COPYRIGHT Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. =head1 SEE ALSO L L =cut Transport/stream.pm000064400000022040151027616360010376 0ustar00package DBD::Gofer::Transport::stream; # $Id: stream.pm 14598 2010-12-21 22:53:25Z Tim $ # # 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 Carp; use base qw(DBD::Gofer::Transport::pipeone); our $VERSION = "0.014599"; __PACKAGE__->mk_accessors(qw( go_persist )); my $persist_all = 5; my %persist; sub _connection_key { my ($self) = @_; return join "~", $self->go_url||"", @{ $self->go_perl || [] }; } sub _connection_get { my ($self) = @_; my $persist = $self->go_persist; # = 0 can force non-caching $persist = $persist_all if not defined $persist; my $key = ($persist) ? $self->_connection_key : ''; if ($persist{$key} && $self->_connection_check($persist{$key})) { $self->trace_msg("reusing persistent connection $key\n",0) if $self->trace >= 1; return $persist{$key}; } my $connection = $self->_make_connection; if ($key) { %persist = () if keys %persist > $persist_all; # XXX quick hack to limit subprocesses $persist{$key} = $connection; } return $connection; } sub _connection_check { my ($self, $connection) = @_; $connection ||= $self->connection_info; my $pid = $connection->{pid}; my $ok = (kill 0, $pid); $self->trace_msg("_connection_check: $ok (pid $$)\n",0) if $self->trace; return $ok; } sub _connection_kill { my ($self) = @_; my $connection = $self->connection_info; my ($pid, $wfh, $rfh, $efh) = @{$connection}{qw(pid wfh rfh efh)}; $self->trace_msg("_connection_kill: closing write handle\n",0) if $self->trace; # closing the write file handle should be enough, generally close $wfh; # in future we may want to be more aggressive #close $rfh; close $efh; kill 15, $pid # but deleting from the persist cache... delete $persist{ $self->_connection_key }; # ... and removing the connection_info should suffice $self->connection_info( undef ); return; } sub _make_connection { my ($self) = @_; my $go_perl = $self->go_perl; my $cmd = [ @$go_perl, qw(-MDBI::Gofer::Transport::stream -e run_stdio_hex)]; #push @$cmd, "DBI_TRACE=2=/tmp/goferstream.log", "sh", "-c"; if (my $url = $self->go_url) { die "Only 'ssh:user\@host' style url supported by this transport" unless $url =~ s/^ssh://; my $ssh = $url; my $setup_env = join "||", map { "source $_ 2>/dev/null" } qw(.bash_profile .bash_login .profile); my $setup = $setup_env.q{; exec "$@"}; # don't use $^X on remote system by default as it's possibly wrong $cmd->[0] = 'perl' if "@$go_perl" eq $^X; # -x not only 'Disables X11 forwarding' but also makes connections *much* faster unshift @$cmd, qw(ssh -xq), split(' ', $ssh), qw(bash -c), $setup; } $self->trace_msg("new connection: @$cmd\n",0) if $self->trace; # XXX add a handshake - some message from DBI::Gofer::Transport::stream that's # sent as soon as it starts that we can wait for to report success - and soak up # and report useful warnings etc from ssh before we get it? Increases latency though. my $connection = $self->start_pipe_command($cmd); return $connection; } sub transmit_request_by_transport { my ($self, $request) = @_; my $trace = $self->trace; my $connection = $self->connection_info || do { my $con = $self->_connection_get; $self->connection_info( $con ); $con; }; my $encoded_request = unpack("H*", $self->freeze_request($request)); $encoded_request .= "\015\012"; my $wfh = $connection->{wfh}; $self->trace_msg(sprintf("transmit_request_by_transport: to fh %s fd%d\n", $wfh, fileno($wfh)),0) if $trace >= 4; # send frozen request local $\; $wfh->print($encoded_request) # autoflush enabled or do { my $err = $!; # XXX could/should make new connection and retry $self->_connection_kill; die "Error sending request: $err"; }; $self->trace_msg("Request sent: $encoded_request\n",0) if $trace >= 4; return undef; # indicate no response yet (so caller calls receive_response_by_transport) } sub receive_response_by_transport { my $self = shift; my $trace = $self->trace; $self->trace_msg("receive_response_by_transport: awaiting response\n",0) if $trace >= 4; my $connection = $self->connection_info || die; my ($pid, $rfh, $efh, $cmd) = @{$connection}{qw(pid rfh efh cmd)}; my $errno = 0; my $encoded_response; my $stderr_msg; $self->read_response_from_fh( { $efh => { error => sub { warn "error reading response stderr: $!"; $errno||=$!; 1 }, eof => sub { warn "eof reading efh" if $trace >= 4; 1 }, read => sub { $stderr_msg .= $_; 0 }, }, $rfh => { error => sub { warn "error reading response: $!"; $errno||=$!; 1 }, eof => sub { warn "eof reading rfh" if $trace >= 4; 1 }, read => sub { $encoded_response .= $_; ($encoded_response=~s/\015\012$//) ? 1 : 0 }, }, }); # if we got no output on stdout at all then the command has # probably exited, possibly with an error to stderr. # Turn this situation into a reasonably useful DBI error. if (not $encoded_response) { my @msg; push @msg, "error while reading response: $errno" if $errno; if ($stderr_msg) { chomp $stderr_msg; push @msg, sprintf "error reported by \"%s\" (pid %d%s): %s", $self->cmd_as_string, $pid, ((kill 0, $pid) ? "" : ", exited"), $stderr_msg; } die join(", ", "No response received", @msg)."\n"; } $self->trace_msg("Response received: $encoded_response\n",0) if $trace >= 4; $self->trace_msg("Gofer stream stderr message: $stderr_msg\n",0) if $stderr_msg && $trace; my $frozen_response = pack("H*", $encoded_response); # XXX need to be able to detect and deal with corruption my $response = $self->thaw_response($frozen_response); if ($stderr_msg) { # add stderr messages as warnings (for PrintWarn) $response->add_err(0, $stderr_msg, undef, $trace) # but ignore warning from old version of blib unless $stderr_msg =~ /^Using .*blib/ && "@$cmd" =~ /-Mblib/; } return $response; } sub transport_timedout { my $self = shift; $self->_connection_kill; return $self->SUPER::transport_timedout(@_); } 1; __END__ =head1 NAME DBD::Gofer::Transport::stream - DBD::Gofer transport for stdio streaming =head1 SYNOPSIS DBI->connect('dbi:Gofer:transport=stream;url=ssh:username@host.example.com;dsn=dbi:...',...) or, enable by setting the DBI_AUTOPROXY environment variable: export DBI_AUTOPROXY='dbi:Gofer:transport=stream;url=ssh:username@host.example.com' =head1 DESCRIPTION Without the C parameter it launches a subprocess as perl -MDBI::Gofer::Transport::stream -e run_stdio_hex and feeds requests into it and reads responses from it. But that's not very useful. With a C parameter it uses ssh to launch the subprocess on a remote system. That's much more useful! It gives you secure remote access to DBI databases on any system you can login to. Using ssh also gives you optional compression and many other features (see the ssh manual for how to configure that and many other options via ~/.ssh/config file). The actual command invoked is something like: ssh -xq ssh:username@host.example.com bash -c $setup $run where $run is the command shown above, and $command is . .bash_profile 2>/dev/null || . .bash_login 2>/dev/null || . .profile 2>/dev/null; exec "$@" which is trying (in a limited and fairly unportable way) to setup the environment (PATH, PERL5LIB etc) as it would be if you had logged in to that system. The "C" used in the command will default to the value of $^X when not using ssh. On most systems that's the full path to the perl that's currently executing. =head1 PERSISTENCE Currently gofer stream connections persist (remain connected) after all database handles have been disconnected. This makes later connections in the same process very fast. Currently up to 5 different gofer stream connections (based on url) can persist. If more than 5 are in the cache when a new connection is made then the cache is cleared before adding the new connection. Simple but effective. =head1 TO DO Document go_perl attribute Automatically reconnect (within reason) if there's a transport error. Decide on default for persistent connection - on or off? limits? ttl? =head1 AUTHOR Tim Bunce, L =head1 LICENCE AND COPYRIGHT Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. =head1 SEE ALSO L L =cut Transport/Base.pm000064400000030723151027616360007764 0ustar00package DBD::Gofer::Transport::Base; # $Id: Base.pm 14120 2010-06-07 19:52:19Z H.Merijn $ # # 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 base qw(DBI::Gofer::Transport::Base); our $VERSION = "0.014121"; __PACKAGE__->mk_accessors(qw( trace go_dsn go_url go_policy go_timeout go_retry_hook go_retry_limit go_cache cache_hit cache_miss cache_store )); __PACKAGE__->mk_accessors_using(make_accessor_autoviv_hashref => qw( meta )); sub new { my ($class, $args) = @_; $args->{$_} = 0 for (qw(cache_hit cache_miss cache_store)); $args->{keep_meta_frozen} ||= 1 if $args->{go_cache}; #warn "args @{[ %$args ]}\n"; return $class->SUPER::new($args); } sub _init_trace { $ENV{DBD_GOFER_TRACE} || 0 } sub new_response { my $self = shift; return DBI::Gofer::Response->new(@_); } sub transmit_request { my ($self, $request) = @_; my $trace = $self->trace; my $response; my ($go_cache, $request_cache_key); if ($go_cache = $self->{go_cache}) { $request_cache_key = $request->{meta}{request_cache_key} = $self->get_cache_key_for_request($request); if ($request_cache_key) { my $frozen_response = eval { $go_cache->get($request_cache_key) }; if ($frozen_response) { $self->_dump("cached response found for ".ref($request), $request) if $trace; $response = $self->thaw_response($frozen_response); $self->trace_msg("transmit_request is returning a response from cache $go_cache\n") if $trace; ++$self->{cache_hit}; return $response; } warn $@ if $@; ++$self->{cache_miss}; $self->trace_msg("transmit_request cache miss\n") if $trace; } } my $to = $self->go_timeout; my $transmit_sub = sub { $self->trace_msg("transmit_request\n") if $trace; local $SIG{ALRM} = sub { die "TIMEOUT\n" } if $to; my $response = eval { local $SIG{PIPE} = sub { my $extra = ($! eq "Broken pipe") ? "" : " ($!)"; die "Unable to send request: Broken pipe$extra\n"; }; alarm($to) if $to; $self->transmit_request_by_transport($request); }; alarm(0) if $to; if ($@) { return $self->transport_timedout("transmit_request", $to) if $@ eq "TIMEOUT\n"; return $self->new_response({ err => 1, errstr => $@ }); } return $response; }; $response = $self->_transmit_request_with_retries($request, $transmit_sub); if ($response) { my $frozen_response = delete $response->{meta}{frozen}; $self->_store_response_in_cache($frozen_response, $request_cache_key) if $request_cache_key; } $self->trace_msg("transmit_request is returning a response itself\n") if $trace && $response; return $response unless wantarray; return ($response, $transmit_sub); } sub _transmit_request_with_retries { my ($self, $request, $transmit_sub) = @_; my $response; do { $response = $transmit_sub->(); } while ( $response && $self->response_needs_retransmit($request, $response) ); return $response; } sub receive_response { my ($self, $request, $retransmit_sub) = @_; my $to = $self->go_timeout; my $receive_sub = sub { $self->trace_msg("receive_response\n"); local $SIG{ALRM} = sub { die "TIMEOUT\n" } if $to; my $response = eval { alarm($to) if $to; $self->receive_response_by_transport($request); }; alarm(0) if $to; if ($@) { return $self->transport_timedout("receive_response", $to) if $@ eq "TIMEOUT\n"; return $self->new_response({ err => 1, errstr => $@ }); } return $response; }; my $response; do { $response = $receive_sub->(); if ($self->response_needs_retransmit($request, $response)) { $response = $self->_transmit_request_with_retries($request, $retransmit_sub); $response ||= $receive_sub->(); } } while ( $self->response_needs_retransmit($request, $response) ); if ($response) { my $frozen_response = delete $response->{meta}{frozen}; my $request_cache_key = $request->{meta}{request_cache_key}; $self->_store_response_in_cache($frozen_response, $request_cache_key) if $request_cache_key && $self->{go_cache}; } return $response; } sub response_retry_preference { my ($self, $request, $response) = @_; # give the user a chance to express a preference (or undef for default) if (my $go_retry_hook = $self->go_retry_hook) { my $retry = $go_retry_hook->($request, $response, $self); $self->trace_msg(sprintf "go_retry_hook returned %s\n", (defined $retry) ? $retry : 'undef'); return $retry if defined $retry; } # This is the main decision point. We don't retry requests that got # as far as executing because the error is probably from the database # (not transport) so retrying is unlikely to help. But note that any # severe transport error occurring after execute is likely to return # a new response object that doesn't have the execute flag set. Beware! return 0 if $response->executed_flag_set; return 1 if ($response->errstr || '') =~ m/induced by DBI_GOFER_RANDOM/; return 1 if $request->is_idempotent; # i.e. is SELECT or ReadOnly was set return undef; # we couldn't make up our mind } sub response_needs_retransmit { my ($self, $request, $response) = @_; my $err = $response->err or return 0; # nothing went wrong my $retry = $self->response_retry_preference($request, $response); if (!$retry) { # false or undef $self->trace_msg("response_needs_retransmit: response not suitable for retry\n"); return 0; } # we'd like to retry but have we retried too much already? my $retry_limit = $self->go_retry_limit; if (!$retry_limit) { $self->trace_msg("response_needs_retransmit: retries disabled (retry_limit not set)\n"); return 0; } my $request_meta = $request->meta; my $retry_count = $request_meta->{retry_count} || 0; if ($retry_count >= $retry_limit) { $self->trace_msg("response_needs_retransmit: $retry_count is too many retries\n"); # XXX should be possible to disable altering the err $response->errstr(sprintf "%s (after %d retries by gofer)", $response->errstr, $retry_count); return 0; } # will retry now, do the admin ++$retry_count; $self->trace_msg("response_needs_retransmit: retry $retry_count\n"); # hook so response_retry_preference can defer some code execution # until we've checked retry_count and retry_limit. if (ref $retry eq 'CODE') { $retry->($retry_count, $retry_limit) and warn "should return false"; # protect future use } ++$request_meta->{retry_count}; # update count for this request object ++$self->meta->{request_retry_count}; # update cumulative transport stats return 1; } sub transport_timedout { my ($self, $method, $timeout) = @_; $timeout ||= $self->go_timeout; return $self->new_response({ err => 1, errstr => "DBD::Gofer $method timed-out after $timeout seconds" }); } # return undef if we don't want to cache this request # subclasses may use more specialized rules sub get_cache_key_for_request { my ($self, $request) = @_; # we only want to cache idempotent requests # is_idempotent() is true if GOf_REQUEST_IDEMPOTENT or GOf_REQUEST_READONLY set return undef if not $request->is_idempotent; # XXX would be nice to avoid the extra freeze here my $key = $self->freeze_request($request, undef, 1); #use Digest::MD5; warn "get_cache_key_for_request: ".Digest::MD5::md5_base64($key)."\n"; return $key; } sub _store_response_in_cache { my ($self, $frozen_response, $request_cache_key) = @_; my $go_cache = $self->{go_cache} or return; # new() ensures that enabling go_cache also enables keep_meta_frozen warn "No meta frozen in response" if !$frozen_response; warn "No request_cache_key" if !$request_cache_key; if ($frozen_response && $request_cache_key) { $self->trace_msg("receive_response added response to cache $go_cache\n"); eval { $go_cache->set($request_cache_key, $frozen_response) }; warn $@ if $@; ++$self->{cache_store}; } } 1; __END__ =head1 NAME DBD::Gofer::Transport::Base - base class for DBD::Gofer client transports =head1 SYNOPSIS my $remote_dsn = "..." DBI->connect("dbi:Gofer:transport=...;url=...;timeout=...;retry_limit=...;dsn=$remote_dsn",...) or, enable by setting the DBI_AUTOPROXY environment variable: export DBI_AUTOPROXY='dbi:Gofer:transport=...;url=...' which will force I DBI connections to be made via that Gofer server. =head1 DESCRIPTION This is the base class for all DBD::Gofer client transports. =head1 ATTRIBUTES Gofer transport attributes can be specified either in the attributes parameter of the connect() method call, or in the DSN string. When used in the DSN string, attribute names don't have the C prefix. =head2 go_dsn The full DBI DSN that the Gofer server should connect to on your behalf. When used in the DSN it must be the last element in the DSN string. =head2 go_timeout A time limit for sending a request and receiving a response. Some drivers may implement sending and receiving as separate steps, in which case (currently) the timeout applies to each separately. If a request needs to be resent then the timeout is restarted for each sending of a request and receiving of a response. =head2 go_retry_limit The maximum number of times an request may be retried. The default is 2. =head2 go_retry_hook This subroutine reference is called, if defined, for each response received where $response->err is true. The subroutine is pass three parameters: the request object, the response object, and the transport object. If it returns an undefined value then the default retry behaviour is used. See L below. If it returns a defined but false value then the request is not resent. If it returns true value then the request is resent, so long as the number of retries does not exceed C. =head1 RETRY ON ERROR The default retry on error behaviour is: - Retry if the error was due to DBI_GOFER_RANDOM. See L. - Retry if $request->is_idempotent returns true. See L. A retry won't be allowed if the number of previous retries has reached C. =head1 TRACING Tracing of gofer requests and responses can be enabled by setting the C environment variable. A value of 1 gives a reasonably compact summary of each request and response. A value of 2 or more gives a detailed, and voluminous, dump. The trace is written using DBI->trace_msg() and so is written to the default DBI trace output, which is usually STDERR. =head1 METHODS I =head2 response_retry_preference $retry = $transport->response_retry_preference($request, $response); The response_retry_preference is called by DBD::Gofer when considering if a request should be retried after an error. Returns true (would like to retry), false (must not retry), undef (no preference). If a true value is returned in the form of a CODE ref then, if DBD::Gofer does decide to retry the request, it calls the code ref passing $retry_count, $retry_limit. Can be used for logging and/or to implement exponential backoff behaviour. Currently the called code must return using C to allow for future extensions. =head1 AUTHOR Tim Bunce, L =head1 LICENCE AND COPYRIGHT Copyright (c) 2007-2008, Tim Bunce, Ireland. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. =head1 SEE ALSO L, L, L, L. and some example transports: L L L =cut Policy/classic.pm000064400000004072151030236460007765 0ustar00package DBD::Gofer::Policy::classic; # $Id: classic.pm 10087 2007-10-16 12:42:37Z Tim $ # # 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; our $VERSION = "0.010088"; use base qw(DBD::Gofer::Policy::Base); __PACKAGE__->create_policy_subs({ # always use connect_cached on server connect_method => 'connect_cached', # use same methods on server as is called on client prepare_method => '', # don't skip the connect check since that also sets dbh attributes # although this makes connect more expensive, that's partly offset # by skip_ping=>1 below, which makes connect_cached very fast. skip_connect_check => 0, # most code doesn't rely on sth attributes being set after prepare skip_prepare_check => 1, # we're happy to use local method if that's the same as the remote skip_default_methods => 1, # ping is not important for DBD::Gofer and most transports skip_ping => 1, # only update dbh attributes on first contact with server dbh_attribute_update => 'first', # we'd like to set locally_* but can't because drivers differ # get_info results usually don't change cache_get_info => 1, }); 1; =head1 NAME DBD::Gofer::Policy::classic - The 'classic' policy for DBD::Gofer =head1 SYNOPSIS $dbh = DBI->connect("dbi:Gofer:transport=...;policy=classic", ...) The C policy is the default DBD::Gofer policy, so need not be included in the DSN. =head1 DESCRIPTION Temporary docs: See the source code for list of policies and their defaults. In a future version the policies and their defaults will be defined in the pod and parsed out at load-time. =head1 AUTHOR Tim Bunce, L =head1 LICENCE AND COPYRIGHT Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. =cut Policy/pedantic.pm000064400000002633151030236460010134 0ustar00package DBD::Gofer::Policy::pedantic; # $Id: pedantic.pm 10087 2007-10-16 12:42:37Z Tim $ # # 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; our $VERSION = "0.010088"; use base qw(DBD::Gofer::Policy::Base); # the 'pedantic' policy is the same as the Base policy 1; =head1 NAME DBD::Gofer::Policy::pedantic - The 'pedantic' policy for DBD::Gofer =head1 SYNOPSIS $dbh = DBI->connect("dbi:Gofer:transport=...;policy=pedantic", ...) =head1 DESCRIPTION The C policy tries to be as transparent as possible. To do this it makes round-trips to the server for almost every DBI method call. This is the best policy to use when first testing existing code with Gofer. Once it's working well you should consider moving to the C policy or defining your own policy class. Temporary docs: See the source code for list of policies and their defaults. In a future version the policies and their defaults will be defined in the pod and parsed out at load-time. =head1 AUTHOR Tim Bunce, L =head1 LICENCE AND COPYRIGHT Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. =cut Policy/rush.pm000064400000005045151030236460007326 0ustar00package DBD::Gofer::Policy::rush; # $Id: rush.pm 10087 2007-10-16 12:42:37Z Tim $ # # 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; our $VERSION = "0.010088"; use base qw(DBD::Gofer::Policy::Base); __PACKAGE__->create_policy_subs({ # always use connect_cached on server connect_method => 'connect_cached', # use same methods on server as is called on client # (because code not using placeholders would bloat the sth cache) prepare_method => '', # Skipping the connect check is fast, but it also skips # fetching the remote dbh attributes! # Make sure that your application doesn't need access to dbh attributes. skip_connect_check => 1, # most code doesn't rely on sth attributes being set after prepare skip_prepare_check => 1, # we're happy to use local method if that's the same as the remote skip_default_methods => 1, # ping is almost meaningless for DBD::Gofer and most transports anyway skip_ping => 1, # don't update dbh attributes at all # XXX actually we currently need dbh_attribute_update for skip_default_methods to work # and skip_default_methods is more valuable to us than the cost of dbh_attribute_update dbh_attribute_update => 'none', # actually means 'first' currently #dbh_attribute_list => undef, # we'd like to set locally_* but can't because drivers differ # in a rush assume metadata doesn't change cache_tables => 1, cache_table_info => 1, cache_column_info => 1, cache_primary_key_info => 1, cache_foreign_key_info => 1, cache_statistics_info => 1, cache_get_info => 1, }); 1; =head1 NAME DBD::Gofer::Policy::rush - The 'rush' policy for DBD::Gofer =head1 SYNOPSIS $dbh = DBI->connect("dbi:Gofer:transport=...;policy=rush", ...) =head1 DESCRIPTION The C policy tries to make as few round-trips as possible. It's the opposite end of the policy spectrum to the C policy. Temporary docs: See the source code for list of policies and their defaults. In a future version the policies and their defaults will be defined in the pod and parsed out at load-time. =head1 AUTHOR Tim Bunce, L =head1 LICENCE AND COPYRIGHT Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. =cut Policy/Base.pm000064400000011741151030236460007217 0ustar00package DBD::Gofer::Policy::Base; # $Id: Base.pm 10087 2007-10-16 12:42:37Z Tim $ # # 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 Carp; our $VERSION = "0.010088"; our $AUTOLOAD; my %policy_defaults = ( # force connect method (unless overridden by go_connect_method=>'...' attribute) # if false: call same method on client as on server connect_method => 'connect', # force prepare method (unless overridden by go_prepare_method=>'...' attribute) # if false: call same method on client as on server prepare_method => 'prepare', skip_connect_check => 0, skip_default_methods => 0, skip_prepare_check => 0, skip_ping => 0, dbh_attribute_update => 'every', dbh_attribute_list => ['*'], locally_quote => 0, locally_quote_identifier => 0, cache_parse_trace_flags => 1, cache_parse_trace_flag => 1, cache_data_sources => 1, cache_type_info_all => 1, cache_tables => 0, cache_table_info => 0, cache_column_info => 0, cache_primary_key_info => 0, cache_foreign_key_info => 0, cache_statistics_info => 0, cache_get_info => 0, cache_func => 0, ); my $base_policy_file = $INC{"DBD/Gofer/Policy/Base.pm"}; __PACKAGE__->create_policy_subs(\%policy_defaults); sub create_policy_subs { my ($class, $policy_defaults) = @_; while ( my ($policy_name, $policy_default) = each %$policy_defaults) { my $policy_attr_name = "go_$policy_name"; my $sub = sub { # $policy->foo($attr, ...) #carp "$policy_name($_[1],...)"; # return the policy default value unless an attribute overrides it return (ref $_[1] && exists $_[1]->{$policy_attr_name}) ? $_[1]->{$policy_attr_name} : $policy_default; }; no strict 'refs'; *{$class . '::' . $policy_name} = $sub; } } sub AUTOLOAD { carp "Unknown policy name $AUTOLOAD used"; # only warn once no strict 'refs'; *$AUTOLOAD = sub { undef }; return undef; } sub new { my ($class, $args) = @_; my $policy = {}; bless $policy, $class; } sub DESTROY { }; 1; =head1 NAME DBD::Gofer::Policy::Base - Base class for DBD::Gofer policies =head1 SYNOPSIS $dbh = DBI->connect("dbi:Gofer:transport=...;policy=...", ...) =head1 DESCRIPTION DBD::Gofer can be configured via a 'policy' mechanism that allows you to fine-tune the number of round-trips to the Gofer server. The policies are grouped into classes (which may be subclassed) and referenced by the name of the class. The L class is the base class for all the policy classes and describes all the individual policy items. The Base policy is not used directly. You should use a policy class derived from it. =head1 POLICY CLASSES Three policy classes are supplied with DBD::Gofer: L is most 'transparent' but slowest because it makes more round-trips to the Gofer server. L is a reasonable compromise - it's the default policy. L is fastest, but may require code changes in your applications. Generally the default C policy is fine. When first testing an existing application with Gofer it is a good idea to start with the C policy first and then switch to C or a custom policy, for final testing. =head1 POLICY ITEMS These are temporary docs: See the source code for list of policies and their defaults. In a future version the policies and their defaults will be defined in the pod and parsed out at load-time. See the source code to this module for more details. =head1 POLICY CUSTOMIZATION XXX This area of DBD::Gofer is subject to change. There are three ways to customize policies: Policy classes are designed to influence the overall behaviour of DBD::Gofer with existing, unaltered programs, so they work in a reasonably optimal way without requiring code changes. You can implement new policy classes as subclasses of existing policies. In many cases individual policy items can be overridden on a case-by-case basis within your application code. You do this by passing a corresponding C<>> attribute into DBI methods by your application code. This let's you fine-tune the behaviour for special cases. The policy items are implemented as methods. In many cases the methods are passed parameters relating to the DBD::Gofer code being executed. This means the policy can implement dynamic behaviour that varies depending on the particular circumstances, such as the particular statement being executed. =head1 AUTHOR Tim Bunce, L =head1 LICENCE AND COPYRIGHT Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. =cut Transport/null.pm000064400000005322151030236460010052 0ustar00package DBD::Gofer::Transport::null; # $Id: null.pm 10087 2007-10-16 12:42:37Z Tim $ # # 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 base qw(DBD::Gofer::Transport::Base); use DBI::Gofer::Execute; our $VERSION = "0.010088"; __PACKAGE__->mk_accessors(qw( pending_response transmit_count )); my $executor = DBI::Gofer::Execute->new(); sub transmit_request_by_transport { my ($self, $request) = @_; $self->transmit_count( ($self->transmit_count()||0) + 1 ); # just for tests my $frozen_request = $self->freeze_request($request); # ... # the request is magically transported over to ... ourselves # ... my $response = $executor->execute_request( $self->thaw_request($frozen_request, undef, 1) ); # put response 'on the shelf' ready for receive_response() $self->pending_response( $response ); return undef; } sub receive_response_by_transport { my $self = shift; my $response = $self->pending_response; my $frozen_response = $self->freeze_response($response, undef, 1); # ... # the response is magically transported back to ... ourselves # ... return $self->thaw_response($frozen_response); } 1; __END__ =head1 NAME DBD::Gofer::Transport::null - DBD::Gofer client transport for testing =head1 SYNOPSIS my $original_dsn = "..." DBI->connect("dbi:Gofer:transport=null;dsn=$original_dsn",...) or, enable by setting the DBI_AUTOPROXY environment variable: export DBI_AUTOPROXY="dbi:Gofer:transport=null" =head1 DESCRIPTION Connect via DBD::Gofer but execute the requests within the same process. This is a quick and simple way to test applications for compatibility with the (few) restrictions that DBD::Gofer imposes. It also provides a simple, portable way for the DBI test suite to be used to test DBD::Gofer on all platforms with no setup. Also, by measuring the difference in performance between normal connections and connections via C the basic cost of using DBD::Gofer can be measured. Furthermore, the additional cost of more advanced transports can be isolated by comparing their performance with the null transport. The C script in the DBI distribution includes a comparative benchmark. =head1 AUTHOR Tim Bunce, L =head1 LICENCE AND COPYRIGHT Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. =head1 SEE ALSO L L =cut