[ Index ]

PHP Cross Reference of Unnamed Project

title

Body

[close]

/se3-unattended/var/se3/unattended/install/linuxaux/opt/perl/lib/site_perl/5.10.0/i586-linux-thread-multi/DBI/Gofer/Transport/ -> Base.pm (source)

   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  


Generated: Tue Mar 17 22:47:18 2015 Cross-referenced by PHPXref 0.7.1