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