/usr/share/perl5/Tangram/Type/Dump/Storable.pm is in libtangram-perl 2.10-2.
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 | # (c) Sam Vilain, 2004. All Rights Reserved.
# This program is free software; you may use it and/or distribute it
# under the same terms as Perl itself.
package Tangram::Type::Dump::Storable;
use strict;
use Tangram::Type::Scalar;
use Tangram::Type::Dump qw(flatten unflatten);
use Storable qw(freeze thaw);
use Set::Object qw(reftype);
use vars qw(@ISA);
@ISA = qw( Tangram::Type::String );
$Tangram::Schema::TYPES{storable} = __PACKAGE__->new;
sub reschema {
my ($self, $members, $class, $schema) = @_;
if (ref($members) eq 'ARRAY') {
# short form
# transform into hash: { fieldname => { col => fieldname }, ... }
$_[1] = map { $_ => { col => $schema->{normalize}->($_, 'colname') } } @$members;
}
for my $field (keys %$members) {
my $def = $members->{$field};
my $refdef = reftype($def);
unless ($refdef) {
# not a reference: field => field
$def = $members->{$field} = { col => $schema->{normalize}->(($def || $field), 'colname') };
$refdef = reftype($def);
}
die ref($self), ": $class\:\:$field: unexpected $refdef"
unless $refdef eq 'HASH';
$def->{col} ||= $schema->{normalize}->($field, 'colname');
$def->{sql} ||= 'BLOB';
$def->{deparse} ||= 0;
$def->{dumper} ||= sub {
local($Storable::Deparse) = $def->{deparse};
my $ent = [@_];
my $dumped = freeze($ent);
$Data::Dumper::Purity = 1;
$Data::Dumper::Useqq = 1;
#print STDERR "Dumped: ".Data::Dumper::Dumper($ent, $dumped);
$dumped;
};
}
return keys %$members;
}
sub get_importer
{
my ($self, $context) = @_;
return("
my \$data = shift \@\$row;
print \$Tangram::TRACE \"THAWING (length = \".(length(\$data)).\":\".Data::Dumper::Dumper(\$data)
if \$Tangram::TRACE and \$Tangram::DEBUG_LEVEL > 2;
my \$ref = Storable::thaw(\$context->{storage}->from_dbms('blob', \$data)) or die \"thaw failed on data (\".(length(\$data)).\") = \".Data::Dumper::Dumper(\$data);
\$obj->{$self->{name}} = \$ref->[0];\n"
."Tangram::Type::Dump::unflatten(\$context->{storage}, "
."\$obj->{$self->{name}});\n");
}
sub get_exporter
{
my ($self, $context) = @_;
my $field = $self->{name};
return sub {
my ($obj, $context) = @_;
flatten($context->{storage}, $obj->{$field});
my $text = $self->{dumper}->($obj->{$field});
unflatten($context->{storage}, $obj->{$field});
return $context->{storage}->to_dbms('blob', $text);
};
}
sub save {
my ($self, $cols, $vals, $obj, $members, $storage) = @_;
my $dbh = $storage->{db};
foreach my $member (keys %$members) {
my $memdef = $members->{$member};
next if $memdef->{automatic};
push @$cols, $memdef->{col};
flatten($storage, $obj->{$member});
push @$vals, $dbh->quote(&{$memdef->{dumper}}($obj->{$member}));
unflatten($storage, $obj->{$member});
}
}
1;
|