Initial Commit

database/perl/vendor/lib/DBI/Gofer/Transport/Base.pm

@@ -0,0 +1,174 @@
+package DBI::Gofer::Transport::Base;
+
+#   $Id: Base.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 warnings;
+
+use DBI;
+
+use base qw(DBI::Util::_accessor);
+
+use DBI::Gofer::Serializer::Storable;
+use DBI::Gofer::Serializer::DataDumper;
+
+our $VERSION = "0.012537";
+
+__PACKAGE__->mk_accessors(qw(
+    trace
+    keep_meta_frozen
+    serializer_obj
+));
+
+
+# see also $ENV{DBI_GOFER_TRACE} in DBI::Gofer::Execute
+sub _init_trace { (split(/=/,$ENV{DBI_GOFER_TRACE}||0))[0] }
+
+
+sub new {
+    my ($class, $args) = @_;
+    $args->{trace} ||= $class->_init_trace;
+    $args->{serializer_obj} ||= DBI::Gofer::Serializer::Storable->new();
+    my $self = bless {}, $class;
+    $self->$_( $args->{$_} ) for keys %$args;
+    $self->trace_msg("$class->new({ @{[ %$args ]} })\n") if $self->trace;
+    return $self;
+}
+
+my $packet_header_text  = "GoFER1:";
+my $packet_header_regex = qr/^GoFER(\d+):/;
+
+
+sub _freeze_data {
+    my ($self, $data, $serializer, $skip_trace) = @_;
+    my $frozen = eval {
+        $self->_dump("freezing $self->{trace} ".ref($data), $data)
+            if !$skip_trace and $self->trace;
+
+        local $data->{meta}; # don't include meta in serialization
+	$serializer ||= $self->{serializer_obj};
+        my ($data, $deserializer_class)  = $serializer->serialize($data);
+
+        $packet_header_text . $data;
+    };
+    if ($@) {
+        chomp $@;
+        die "Error freezing ".ref($data)." object: $@";
+    }
+
+    # stash the frozen data into the data structure itself
+    # to make life easy for the client caching code in DBD::Gofer::Transport::Base
+    $data->{meta}{frozen} = $frozen if $self->keep_meta_frozen;
+
+    return $frozen;
+}
+# public aliases used by subclasses
+*freeze_request  = \&_freeze_data;
+*freeze_response = \&_freeze_data;
+
+
+sub _thaw_data {
+    my ($self, $frozen_data, $serializer, $skip_trace) = @_;
+    my $data;
+    eval {
+        # check for and extract our gofer header and the info it contains
+        (my $frozen = $frozen_data) =~ s/$packet_header_regex//o
+            or die "does not have gofer header\n";
+        my ($t_version) = $1;
+	$serializer ||= $self->{serializer_obj};
+        $data = $serializer->deserialize($frozen);
+        die ref($serializer)."->deserialize didn't return a reference"
+            unless ref $data;
+        $data->{_transport}{version} = $t_version;
+
+        $data->{meta}{frozen} = $frozen_data if $self->keep_meta_frozen;
+    };
+    if ($@) {
+        chomp(my $err = $@);
+        # remove extra noise from Storable
+        $err =~ s{ at \S+?/Storable.pm \(autosplit into \S+?/Storable/thaw.al\) line \d+(, \S+ line \d+)?}{};
+        my $msg = sprintf "Error thawing: %s (data=%s)", $err, DBI::neat($frozen_data,50);
+        Carp::cluck("$msg, pid $$ stack trace follows:"); # XXX if $self->trace;
+        die $msg;
+    }
+    $self->_dump("thawing $self->{trace} ".ref($data), $data)
+        if !$skip_trace and $self->trace;
+
+    return $data;
+}
+# public aliases used by subclasses
+*thaw_request  = \&_thaw_data;
+*thaw_response = \&_thaw_data;
+
+
+# this should probably live in the request and response classes
+# and the tace level passed in
+sub _dump {
+    my ($self, $label, $data) = @_;
+
+    # don't dump the binary
+    local $data->{meta}{frozen} if $data->{meta} && $data->{meta}{frozen};
+
+    my $trace_level = $self->trace;
+    my $summary;
+    if ($trace_level >= 4) {
+        require Data::Dumper;
+        local $Data::Dumper::Indent    = 1;
+        local $Data::Dumper::Terse     = 1;
+        local $Data::Dumper::Useqq     = 0;
+        local $Data::Dumper::Sortkeys  = 1;
+        local $Data::Dumper::Quotekeys = 0;
+        local $Data::Dumper::Deparse   = 0;
+        local $Data::Dumper::Purity    = 0;
+        $summary = Data::Dumper::Dumper($data);
+    }
+    elsif ($trace_level >= 2) {
+        $summary = eval { $data->summary_as_text } || $@ || "no summary available\n";
+    }
+    else {
+        $summary = eval { $data->outline_as_text."\n" } || $@ || "no summary available\n";
+    }
+    $self->trace_msg("$label: $summary");
+}
+
+
+sub trace_msg {
+    my ($self, $msg, $min_level) = @_;
+    $min_level = 1 unless defined $min_level;
+    # transport trace level can override DBI's trace level
+    $min_level = 0 if $self->trace >= $min_level;
+    return DBI->trace_msg("gofer ".$msg, $min_level);
+}
+
+1;
+
+=head1 NAME
+
+DBI::Gofer::Transport::Base - Base class for Gofer transports
+
+=head1 DESCRIPTION
+
+This is the base class for server-side Gofer transports.
+
+It's also the base class for the client-side base class L<DBD::Gofer::Transport::Base>.
+
+This is an internal class.
+
+=head1 AUTHOR
+
+Tim Bunce, L<http://www.tim.bunce.name>
+
+=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<perlartistic>.
+
+=cut
+

database/perl/vendor/lib/DBI/Gofer/Transport/pipeone.pm

@@ -0,0 +1,64 @@
+package DBI::Gofer::Transport::pipeone;
+
+#   $Id: pipeone.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 warnings;
+
+use DBI::Gofer::Execute;
+
+use base qw(DBI::Gofer::Transport::Base Exporter);
+
+our $VERSION = "0.012537";
+
+our @EXPORT = qw(run_one_stdio);
+
+my $executor = DBI::Gofer::Execute->new();
+
+sub run_one_stdio {
+
+    binmode STDIN;
+    binmode STDOUT;
+
+    my $transport = DBI::Gofer::Transport::pipeone->new();
+
+    my $frozen_request = do { local $/; <STDIN> };
+
+    my $response = $executor->execute_request( $transport->thaw_request($frozen_request) );
+
+    my $frozen_response = $transport->freeze_response($response);
+
+    print $frozen_response;
+
+    # no point calling $executor->update_stats(...) for pipeONE
+}
+
+1;
+__END__
+
+=head1 NAME
+
+DBI::Gofer::Transport::pipeone - DBD::Gofer server-side transport for pipeone
+
+=head1 SYNOPSIS
+
+See L<DBD::Gofer::Transport::pipeone>.
+
+=head1 AUTHOR
+
+Tim Bunce, L<http://www.tim.bunce.name>
+
+=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<perlartistic>.
+
+=cut
+

database/perl/vendor/lib/DBI/Gofer/Transport/stream.pm

@@ -0,0 +1,76 @@
+package DBI::Gofer::Transport::stream;
+
+#   $Id: stream.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 warnings;
+
+use DBI qw(dbi_time);
+use DBI::Gofer::Execute;
+
+use base qw(DBI::Gofer::Transport::pipeone Exporter);
+
+our $VERSION = "0.012537";
+
+our @EXPORT = qw(run_stdio_hex);
+
+my $executor = DBI::Gofer::Execute->new();
+
+sub run_stdio_hex {
+
+    my $transport = DBI::Gofer::Transport::stream->new();
+    local $| = 1;
+
+    DBI->trace_msg("$0 started (pid $$)\n");
+
+    local $\; # OUTPUT_RECORD_SEPARATOR
+    local $/ = "\012"; # INPUT_RECORD_SEPARATOR
+    while ( defined( my $encoded_request = <STDIN> ) ) {
+        my $time_received = dbi_time();
+        $encoded_request =~ s/\015?\012$//;
+
+        my $frozen_request = pack "H*", $encoded_request;
+        my $request = $transport->thaw_request( $frozen_request );
+
+        my $response = $executor->execute_request( $request );
+
+        my $frozen_response = $transport->freeze_response($response);
+        my $encoded_response = unpack "H*", $frozen_response;
+
+        print $encoded_response, "\015\012"; # autoflushed due to $|=1
+
+        # there's no way to access the stats currently
+        # so this just serves as a basic test and illustration of update_stats()
+        $executor->update_stats($request, $response, $frozen_request, $frozen_response, $time_received, 1);
+    }
+    DBI->trace_msg("$0 ending (pid $$)\n");
+}
+
+1;
+__END__
+
+=head1 NAME
+
+DBI::Gofer::Transport::stream - DBD::Gofer server-side transport for stream
+
+=head1 SYNOPSIS
+
+See L<DBD::Gofer::Transport::stream>.
+
+=head1 AUTHOR
+
+Tim Bunce, L<http://www.tim.bunce.name>
+
+=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<perlartistic>.
+
+=cut