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
105
106
107
|
# Copyright 1999-2001 Gabor Herr. All rights reserved.
# This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself
# Modified 29dec2000 by Jean-Louis Leroy
# replaced save() by get_exporter()
# fixed reschema(): $def->{dumper} was not set when using abbreviated forms
use strict;
use Tangram::Type::Scalar;
package Tangram::Type::Dump::Perl;
use Tangram::Type::Dump qw(flatten unflatten);
use vars qw(@ISA);
@ISA = qw( Tangram::Type::String );
use Data::Dumper;
use Set::Object qw(reftype);
$Tangram::Schema::TYPES{perl_dump} = Tangram::Type::Dump::Perl->new;
my $DumpMeth = (defined &Data::Dumper::Dumpxs) ? 'Dumpxs' : 'Dump';
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} ||= 'VARCHAR(255)';
$def->{indent} ||= 0;
$def->{terse} ||= 1;
$def->{purity} ||= 0;
$def->{dumper} ||= sub {
local($Data::Dumper::Indent) = $def->{indent};
local($Data::Dumper::Terse) = $def->{terse};
local($Data::Dumper::Purity) = $def->{purity};
local($Data::Dumper::Useqq) = 1;
local($Data::Dumper::Varname) = '_t::v';
Data::Dumper->$DumpMeth([@_], []);
};
}
return keys %$members;
}
sub get_importer
{
my ($self, $context) = @_;
return("\$obj->{$self->{name}} = eval shift \@\$row;"
."Tangram::Type::Dump::unflatten(\$context->{storage}, "
."\$obj->{$self->{name}})");
}
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 $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};
Tangram::Type::Dump::flatten($storage, $obj->{$member});
push @$vals, $dbh->quote(&{$memdef->{dumper}}($obj->{$member}));
Tangram::Type::Dump::unflatten($storage, $obj->{$member});
}
}
1;
|
