libs/Tangram/PerlDump.pm

# (c) Sound Object Logic 2000-2001

# 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::Scalar;

package Tangram::PerlDump;

use base qw( Tangram::String );
use Data::Dumper;

$Tangram::Schema::TYPES{perl_dump} = Tangram::PerlDump->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 = ref($def);
    
    unless ($refdef) {
      # not a reference: field => field
      $def = $members->{$field} = { col => $schema->{normalize}->(($def || $field), 'colname') };
          $refdef = ref($def);
    }

    die ref($self), ": $class\:\:$field: unexpected $refdef"
      unless $refdef eq 'HASH' or $refdef eq 'Tangram::PerlDump';
        
    $def->{col} ||= $schema->{normalize}->($field, 'colname');
    $def->{sql} ||= 'VARCHAR(255)';
    $def->{indent} ||= 0;
    $def->{terse} ||= 1;
    $def->{purity} ||= 0;
    $def->{dumper} ||= sub {

      # remember settings
      $def->{cache}->{indent}  = $Data::Dumper::Indent;
      $def->{cache}->{terse}   = $Data::Dumper::Terse;
      $def->{cache}->{purity}  = $Data::Dumper::Purity;
      $def->{cache}->{varname} = $Data::Dumper::Varname;

      $Data::Dumper::Indent = $def->{indent};
      $Data::Dumper::Terse  = $def->{terse};
      $Data::Dumper::Purity = $def->{purity};
      $Data::Dumper::Varname = '_t::v';
      my $dump = Data::Dumper->$DumpMeth([@_], []);
      
      # restore settings
      $Data::Dumper::Indent  = $def->{cache}->{indent};
      $Data::Dumper::Terse   = $def->{cache}->{terse};
      $Data::Dumper::Purity  = $def->{cache}->{purity};
      $Data::Dumper::Varname = $def->{cache}->{varname};

      return $dump;

    };
  }

  return keys %$members;
}

sub get_importer
{
        my ($self, $context) = @_;
        return "\$obj->{$self->{name}} = eval shift \@\$row";
  }

sub get_exporter
  {
        my ($self, $context) = @_;
        my $field = $self->{name};

        return sub {
          my ($obj, $context) = @_;
          $self->{dumper}->($obj->{$field});
        };
  }

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};
    push @$vals, $dbh->quote(&{$memdef->{dumper}}($obj->{$member}));
  }
}

1;
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	joko	1.2	unless $refdef eq 'HASH' or $refdef eq 'Tangram::PerlDump';
45	joko	1.1
46	joko	1.2	$def->{col} \|\|= $schema->{normalize}->($field, 'colname');
47	joko	1.1	$def->{sql} \|\|= 'VARCHAR(255)';
48			$def->{indent} \|\|= 0;
49			$def->{terse} \|\|= 1;
50			$def->{purity} \|\|= 0;
51			$def->{dumper} \|\|= sub {
52	joko	1.2
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	joko	1.1	$Data::Dumper::Indent = $def->{indent};
60			$Data::Dumper::Terse = $def->{terse};
61			$Data::Dumper::Purity = $def->{purity};
62			$Data::Dumper::Varname = '_t::v';
63	joko	1.2	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	joko	1.1	};
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