/[cvs]/nfo/perl/libs/Tangram/PerlDump.pm
ViewVC logotype

Contents of /nfo/perl/libs/Tangram/PerlDump.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Mon Nov 11 03:33:39 2002 UTC (21 years, 11 months ago) by joko
Branch: MAIN
CVS Tags: HEAD
Changes since 1.1: +19 -3 lines
+ patch: $refdef should also be able to be a "Tangram::PerlDump"???
+ patch: (already done in master cvs HEAD): do ...->{normalize}->...
+ improvement: remember settings of "Data::Dumper" before changing them (Indent, Terse, Purity and Varname) and restore settings afterwards

1 # (c) Sound Object Logic 2000-2001
2
3 # Copyright 1999-2001 Gabor Herr. All rights reserved.
4 # This program is free software; you can redistribute it and/or modify it
5 # under the same terms as Perl itself
6
7 # Modified 29dec2000 by Jean-Louis Leroy
8 # replaced save() by get_exporter()
9 # fixed reschema(): $def->{dumper} was not set when using abbreviated forms
10
11 use strict;
12
13 use Tangram::Scalar;
14
15 package Tangram::PerlDump;
16
17 use base qw( Tangram::String );
18 use Data::Dumper;
19
20 $Tangram::Schema::TYPES{perl_dump} = Tangram::PerlDump->new;
21
22 my $DumpMeth = (defined &Data::Dumper::Dumpxs) ? 'Dumpxs' : 'Dump';
23
24 sub reschema {
25 my ($self, $members, $class, $schema) = @_;
26
27 if (ref($members) eq 'ARRAY') {
28 # short form
29 # transform into hash: { fieldname => { col => fieldname }, ... }
30 $_[1] = map { $_ => { col => $schema->{normalize}->($_, 'colname') } } @$members;
31 }
32
33 for my $field (keys %$members) {
34 my $def = $members->{$field};
35 my $refdef = ref($def);
36
37 unless ($refdef) {
38 # not a reference: field => field
39 $def = $members->{$field} = { col => $schema->{normalize}->(($def || $field), 'colname') };
40 $refdef = ref($def);
41 }
42
43 die ref($self), ": $class\:\:$field: unexpected $refdef"
44 unless $refdef eq 'HASH' or $refdef eq 'Tangram::PerlDump';
45
46 $def->{col} ||= $schema->{normalize}->($field, 'colname');
47 $def->{sql} ||= 'VARCHAR(255)';
48 $def->{indent} ||= 0;
49 $def->{terse} ||= 1;
50 $def->{purity} ||= 0;
51 $def->{dumper} ||= sub {
52
53 # remember settings
54 $def->{cache}->{indent} = $Data::Dumper::Indent;
55 $def->{cache}->{terse} = $Data::Dumper::Terse;
56 $def->{cache}->{purity} = $Data::Dumper::Purity;
57 $def->{cache}->{varname} = $Data::Dumper::Varname;
58
59 $Data::Dumper::Indent = $def->{indent};
60 $Data::Dumper::Terse = $def->{terse};
61 $Data::Dumper::Purity = $def->{purity};
62 $Data::Dumper::Varname = '_t::v';
63 my $dump = Data::Dumper->$DumpMeth([@_], []);
64
65 # restore settings
66 $Data::Dumper::Indent = $def->{cache}->{indent};
67 $Data::Dumper::Terse = $def->{cache}->{terse};
68 $Data::Dumper::Purity = $def->{cache}->{purity};
69 $Data::Dumper::Varname = $def->{cache}->{varname};
70
71 return $dump;
72
73 };
74 }
75
76 return keys %$members;
77 }
78
79 sub get_importer
80 {
81 my ($self, $context) = @_;
82 return "\$obj->{$self->{name}} = eval shift \@\$row";
83 }
84
85 sub get_exporter
86 {
87 my ($self, $context) = @_;
88 my $field = $self->{name};
89
90 return sub {
91 my ($obj, $context) = @_;
92 $self->{dumper}->($obj->{$field});
93 };
94 }
95
96 sub save {
97 my ($self, $cols, $vals, $obj, $members, $storage) = @_;
98
99 my $dbh = $storage->{db};
100
101 foreach my $member (keys %$members) {
102 my $memdef = $members->{$member};
103
104 next if $memdef->{automatic};
105
106 push @$cols, $memdef->{col};
107 push @$vals, $dbh->quote(&{$memdef->{dumper}}($obj->{$member}));
108 }
109 }
110
111 1;

MailToCvsAdmin">MailToCvsAdmin
ViewVC Help
Powered by ViewVC 1.1.26 RSS 2.0 feed