[ Index ] |
PHP Cross Reference of Unnamed Project |
[Summary view] [Print] [Text view]
1 package DBI::Gofer::Transport::Base; 2 3 # $Id: Base.pm 11425 2008-06-16 14:56:22Z timbo $ 4 # 5 # Copyright (c) 2007, Tim Bunce, Ireland 6 # 7 # You may distribute under the terms of either the GNU General Public 8 # License or the Artistic License, as specified in the Perl README file. 9 10 use strict; 11 use warnings; 12 13 use DBI; 14 15 use base qw(DBI::Util::_accessor); 16 17 use DBI::Gofer::Serializer::Storable; 18 use DBI::Gofer::Serializer::DataDumper; 19 20 21 our $VERSION = sprintf("0.%06d", q$Revision: 11425 $ =~ /(\d+)/o); 22 23 24 __PACKAGE__->mk_accessors(qw( 25 trace 26 keep_meta_frozen 27 serializer_obj 28 )); 29 30 31 # see also $ENV{DBI_GOFER_TRACE} in DBI::Gofer::Execute 32 sub _init_trace { (split(/=/,$ENV{DBI_GOFER_TRACE}||0))[0] } 33 34 35 sub new { 36 my ($class, $args) = @_; 37 $args->{trace} ||= $class->_init_trace; 38 $args->{serializer_obj} ||= DBI::Gofer::Serializer::Storable->new(); 39 my $self = bless {}, $class; 40 $self->$_( $args->{$_} ) for keys %$args; 41 $self->trace_msg("$class->new({ @{[ %$args ]} })\n") if $self->trace; 42 return $self; 43 } 44 45 my $packet_header_text = "GoFER1:"; 46 my $packet_header_regex = qr/^GoFER(\d+):/; 47 48 49 sub _freeze_data { 50 my ($self, $data, $serializer, $skip_trace) = @_; 51 my $frozen = eval { 52 $self->_dump("freezing $self->{trace} ".ref($data), $data) 53 if !$skip_trace and $self->trace; 54 55 local $data->{meta}; # don't include _meta in serialization 56 $serializer ||= $self->{serializer_obj}; 57 my ($data, $deserializer_class) = $serializer->serialize($data); 58 59 $packet_header_text . $data; 60 }; 61 if ($@) { 62 chomp $@; 63 die "Error freezing ".ref($data)." object: $@"; 64 } 65 66 # stash the frozen data into the data structure itself 67 # to make life easy for the client caching code in DBD::Gofer::Transport::Base 68 $data->{meta}{frozen} = $frozen if $self->keep_meta_frozen; 69 70 return $frozen; 71 } 72 # public aliases used by subclasses 73 *freeze_request = \&_freeze_data; 74 *freeze_response = \&_freeze_data; 75 76 77 sub _thaw_data { 78 my ($self, $frozen_data, $serializer, $skip_trace) = @_; 79 my $data; 80 eval { 81 # check for and extract our gofer header and the info it contains 82 (my $frozen = $frozen_data) =~ s/$packet_header_regex//o 83 or die "does not have gofer header\n"; 84 my ($t_version) = $1; 85 $serializer ||= $self->{serializer_obj}; 86 $data = $serializer->deserialize($frozen); 87 die ref($serializer)."->deserialize didn't return a reference" 88 unless ref $data; 89 $data->{_transport}{version} = $t_version; 90 91 $data->{meta}{frozen} = $frozen_data if $self->keep_meta_frozen; 92 }; 93 if ($@) { 94 chomp(my $err = $@); 95 # remove extra noise from Storable 96 $err =~ s{ at \S+?/Storable.pm \(autosplit into \S+?/Storable/thaw.al\) line \d+(, \S+ line \d+)?}{}; 97 my $msg = sprintf "Error thawing: %s (data=%s)", $err, DBI::neat($frozen_data,50); 98 Carp::cluck("$msg, pid $$ stack trace follows:"); # XXX if $self->trace; 99 die $msg; 100 } 101 $self->_dump("thawing $self->{trace} ".ref($data), $data) 102 if !$skip_trace and $self->trace; 103 104 return $data; 105 } 106 # public aliases used by subclasses 107 *thaw_request = \&_thaw_data; 108 *thaw_response = \&_thaw_data; 109 110 111 # this should probably live in the request and response classes 112 # and the tace level passed in 113 sub _dump { 114 my ($self, $label, $data) = @_; 115 116 # don't dump the binary 117 local $data->{meta}{frozen} if $data->{meta} && $data->{meta}{frozen}; 118 119 my $trace_level = $self->trace; 120 my $summary; 121 if ($trace_level >= 4) { 122 require Data::Dumper; 123 local $Data::Dumper::Indent = 1; 124 local $Data::Dumper::Terse = 1; 125 local $Data::Dumper::Useqq = 0; 126 local $Data::Dumper::Sortkeys = 1; 127 local $Data::Dumper::Quotekeys = 0; 128 local $Data::Dumper::Deparse = 0; 129 local $Data::Dumper::Purity = 0; 130 $summary = Data::Dumper::Dumper($data); 131 } 132 elsif ($trace_level >= 2) { 133 $summary = eval { $data->summary_as_text } || $@ || "no summary available\n"; 134 } 135 else { 136 $summary = eval { $data->outline_as_text."\n" } || $@ || "no summary available\n"; 137 } 138 $self->trace_msg("$label: $summary"); 139 } 140 141 142 sub trace_msg { 143 my ($self, $msg, $min_level) = @_; 144 $min_level = 1 unless defined $min_level; 145 # transport trace level can override DBI's trace level 146 $min_level = 0 if $self->trace >= $min_level; 147 return DBI->trace_msg("gofer ".$msg, $min_level); 148 } 149 150 1; 151 152 =head1 NAME 153 154 DBI::Gofer::Transport::Base - Base class for Gofer transports 155 156 =head1 DESCRIPTION 157 158 This is the base class for server-side Gofer transports. 159 160 It's also the base class for the client-side base class L<DBD::Gofer::Transport::Base>. 161 162 This is an internal class. 163 164 =head1 AUTHOR 165 166 Tim Bunce, L<http://www.tim.bunce.name> 167 168 =head1 LICENCE AND COPYRIGHT 169 170 Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. 171 172 This module is free software; you can redistribute it and/or 173 modify it under the same terms as Perl itself. See L<perlartistic>. 174 175 =cut 176
title
Description
Body
title
Description
Body
title
Description
Body
title
Body
Generated: Tue Mar 17 22:47:18 2015 | Cross-referenced by PHPXref 0.7.1 |