/usr/lib/perl5/DBI/Gofer/Transport/Base.pm is in libdbi-perl 1.616-1build2.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 | package DBI::Gofer::Transport::Base;
# $Id: Base.pm 12536 2009-02-24 22:37:09Z 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;
use base qw(DBI::Util::_accessor);
use DBI::Gofer::Serializer::Storable;
use DBI::Gofer::Serializer::DataDumper;
our $VERSION = sprintf("0.%06d", q$Revision: 12536 $ =~ /(\d+)/o);
__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
|