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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (hide annotations)
Mon Nov 11 03:29:33 2002 UTC (21 years, 11 months ago) by joko
Branch: MAIN
no message

1 joko 1.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';
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     $Data::Dumper::Indent = $def->{indent};
53     $Data::Dumper::Terse = $def->{terse};
54     $Data::Dumper::Purity = $def->{purity};
55     $Data::Dumper::Varname = '_t::v';
56     Data::Dumper->$DumpMeth([@_], []);
57     };
58     }
59    
60     return keys %$members;
61     }
62    
63     sub get_importer
64     {
65     my ($self, $context) = @_;
66     return "\$obj->{$self->{name}} = eval shift \@\$row";
67     }
68    
69     sub get_exporter
70     {
71     my ($self, $context) = @_;
72     my $field = $self->{name};
73    
74     return sub {
75     my ($obj, $context) = @_;
76     $self->{dumper}->($obj->{$field});
77     };
78     }
79    
80     sub save {
81     my ($self, $cols, $vals, $obj, $members, $storage) = @_;
82    
83     my $dbh = $storage->{db};
84    
85     foreach my $member (keys %$members) {
86     my $memdef = $members->{$member};
87    
88     next if $memdef->{automatic};
89    
90     push @$cols, $memdef->{col};
91     push @$vals, $dbh->quote(&{$memdef->{dumper}}($obj->{$member}));
92     }
93     }
94    
95     1;

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