1 2# (c) Sam Vilain, 2004. All Rights Reserved. 3# This program is free software; you may use it and/or distribute it 4# under the same terms as Perl itself. 5 6package Tangram::Type::Dump::Storable; 7 8use strict; 9 10use Tangram::Type::Scalar; 11use Tangram::Type::Dump qw(flatten unflatten); 12 13use Storable qw(freeze thaw); 14 15use Set::Object qw(reftype); 16 17use vars qw(@ISA); 18 @ISA = qw( Tangram::Type::String ); 19 20$Tangram::Schema::TYPES{storable} = __PACKAGE__->new; 21 22sub reschema { 23 my ($self, $members, $class, $schema) = @_; 24 25 if (ref($members) eq 'ARRAY') { 26# XXX - not tested by test suite 27 # short form 28 # transform into hash: { fieldname => { col => fieldname }, ... } 29 $_[1] = map { $_ => { col => $schema->{normalize}->($_, 'colname') } } @$members; 30 } 31 32 for my $field (keys %$members) { 33 my $def = $members->{$field}; 34 my $refdef = reftype($def); 35 36 unless ($refdef) { 37 # not a reference: field => field 38 $def = $members->{$field} = { col => $schema->{normalize}->(($def || $field), 'colname') }; 39 $refdef = reftype($def); 40 } 41 42 die ref($self), ": $class\:\:$field: unexpected $refdef" 43 unless $refdef eq 'HASH'; 44 45 $def->{col} ||= $schema->{normalize}->($field, 'colname'); 46 $def->{sql} ||= 'BLOB'; 47 $def->{deparse} ||= 0; 48 $def->{dumper} ||= sub { 49 local($Storable::Deparse) = $def->{deparse}; 50 my $ent = [@_]; 51 my $dumped = freeze($ent); 52 $Data::Dumper::Purity = 1; 53 $Data::Dumper::Useqq = 1; 54 #print STDERR "Dumped: ".Data::Dumper::Dumper($ent, $dumped); 55 $dumped; 56 }; 57 } 58 59 return keys %$members; 60} 61 62sub get_importer 63{ 64 my ($self, $context) = @_; 65 return(" 66my \$data = shift \@\$row; 67print \$Tangram::TRACE \"THAWING (length = \".(length(\$data)).\":\".Data::Dumper::Dumper(\$data) 68 if \$Tangram::TRACE and \$Tangram::DEBUG_LEVEL > 2; 69my \$ref = Storable::thaw(\$context->{storage}->from_dbms('blob', \$data)) or die \"thaw failed on data (\".(length(\$data)).\") = \".Data::Dumper::Dumper(\$data); 70\$obj->{$self->{name}} = \$ref->[0];\n" 71 ."Tangram::Type::Dump::unflatten(\$context->{storage}, " 72 ."\$obj->{$self->{name}});\n"); 73 } 74 75sub get_exporter 76 { 77 my ($self, $context) = @_; 78 my $field = $self->{name}; 79 80 return sub { 81 my ($obj, $context) = @_; 82 flatten($context->{storage}, $obj->{$field}); 83 my $text = $self->{dumper}->($obj->{$field}); 84 unflatten($context->{storage}, $obj->{$field}); 85 return $context->{storage}->to_dbms('blob', $text); 86 }; 87 } 88 89# XXX - not tested by test suite 90sub save { 91 my ($self, $cols, $vals, $obj, $members, $storage) = @_; 92 93 my $dbh = $storage->{db}; 94 95 foreach my $member (keys %$members) { 96 my $memdef = $members->{$member}; 97 98 next if $memdef->{automatic}; 99 100 push @$cols, $memdef->{col}; 101 flatten($storage, $obj->{$member}); 102 push @$vals, $dbh->quote(&{$memdef->{dumper}}($obj->{$member})); 103 unflatten($storage, $obj->{$member}); 104 } 105} 106 1071; 108