Tangram::Type::Dump::Any - Intuitive DataBase InterFace

  # ... in a nearby Tangram::Schema structure ...
  SomeClass =>
    { fields =>
      { idbif => {
            -options => { dumper => 'Data::Dumper',
                        },
            some_field => undef,
            some_property => undef,
            some_attribute => undef,
            each_one => undef,
            gets => undef,
            saved => undef,
        },
        string => {
            cheese => undef,
        },
      },
    };

  $cheese = bless { cheese   => "gouda",
                    gets     => 6,
                    each_one => 9 }, "SomeClass";

  /^'--v------v--------v----------------------------'^\
  | id | type | cheese | idbif                        |
  >----o------o--------o------------------------------<
  |  1 |   42 |  gouda | { gets => 6, each_one => 9 } |
  \_,--^------^--------^----------------------------._/

  SomeClass->px_thaw(@data)

    { fields =>
      { idbif => { -poof => # There goes another one!
                   {
                   },
                 }
      },
    }

# (c) Sam Vilain, 2004.  All rights reserved.  This program is free
# software; you can redistribute it and/or modify it under the same
# terms as Perl itself

use strict;
use Tangram::Type::Scalar;
package Tangram::Type::Dump::Any;

use Tangram::Type::Dump qw(flatten unflatten);

use vars qw(@ISA);
 @ISA = qw( Tangram::Type::String );
use Set::Object qw(reftype blessed);

$Tangram::Schema::TYPES{idbif} = Tangram::Type::Dump::Any->new;

# for the reschema for this particular attribute, we reschema all of
# the attributes mentioned to a single column
sub reschema {
    my ($self, $members, $class, $schema) = @_;

    # convert from short form
    #$members = $_[1] = { map { $_ => undef } @$members }
	#if (ref($members) eq 'ARRAY');

    my $options = {
		   col => $schema->{normalize}->("idbif", "colname"),
		   sql => $schema->{sql}{dumper_type},
		   dumper => $schema->{sql}{dumper},
		   members => [ ],
		  };

    for my $field (keys %$members) {

	if ($field eq "-options" or $field eq "-poof") {
	    my $def = $members->{$field};
	    ref $def or next;
	    reftype $def eq "HASH"
		or die("reftype invalid in schema for -options idbif;"
		       ." hash expected, got $def");

	    while (my ($option, $value) = each %$def) {
		$options->{$option} = $value;
		if ($option eq "members"
		    and reftype $value ne "ARRAY") {
		    die("idbif -options.members must be an ARRAY ref;"
			." got $value");
		}
	    }
	} else {
	    push @{ $options->{members} }, $field;
	}
    }

    if (! @{ $options->{members} }) {
	$options->{save_all} = $schema->{classes}{$class};
    }

    $options->{dumper_wanted} = $options->{dumper};
    if (lc $options->{dumper} eq "yaml") {
	require 'YAML.pm';
	$options->{dumper} = sub {
	    local($^W)=0;
	    YAML::Dump(shift)
	    };
	$options->{loader} = sub {
	    my $stream = shift;
	    $stream =~ m/^\s*$/s && return undef;
	    $stream .= "\n";
	    my $result = eval {
		local($^W)=0;
		YAML::Load($stream);
	    };
	    if ( $@ ) {
		die "Error parsing this stream: >-\n$stream\n...; $@";
	    } else {
		return $result;
	    }
	};
    } elsif (lc $options->{dumper} eq "data::dumper") {
	require 'Data/Dumper.pm';
	$options->{dumper} = sub {
	    local($Data::Dumper::Purity) = 1;
	    local $Data::Dumper::Indent = 0;  # compact
	    local($Data::Dumper::Terse) = 1;
	    Data::Dumper::Dumper(shift)
	};
	$options->{loader} = sub { eval(shift) };

    } elsif (lc $options->{dumper} eq "storable") {
	require 'Storable.pm';
	$options->{dumper} = sub {
	    Storable::freeze(shift)
	};
	$options->{loader} = sub {
	    Storable::thaw(shift)
	};
    }

    %{$_[1]} = ( idbif => $options );

    return "idbif"; # poof!
}

sub get_importer
{
    my ($self, $context) = @_;
    return sub {
	my ($obj, $row, $context2) = @_;
	my $col = shift @$row;

	my $storage = $context2->{storage};
	#print STDERR "About to load: `$col'\n";
	defined(my $tmpobj = $self->{loader}->($storage->from_dbms("blob", $col))) or do {
	
	    warn "loader for IDBIF on ".ref($obj)."[".$storage->id($obj)."] returned no value from >-\n$col\n...";
	    return $obj;
	};
	#print STDERR "Got `$tmpobj'\n";
	Tangram::Type::Dump::unflatten($storage, $tmpobj);
	if ($self->{save_all}) {
	    for my $member (keys %$tmpobj) {
		$obj->{$member} = delete $tmpobj->{$member};
	    }
	} else {
	    for my $member (@{ $self->{members} }) {
		$obj->{$member} = delete $tmpobj->{$member}
		    if exists $tmpobj->{$member};
	    }
	}
	if (ref $tmpobj ne ref $obj and blessed $tmpobj) {
	    bless $obj, ref $tmpobj;
	}
	%$tmpobj=();
	bless $tmpobj, "nothing";  # "unbless" :-)  skip DESTROY
    };
}

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

    return sub {
	my ($obj, $context2) = @_;
	my $tmpobj = bless { }, ref $obj;
	if ($self->{save_all}) {
	    %$tmpobj = %$obj;
	    while (my $member
		   = each %{ $self->{mt} ||=
				 $self->{save_all}{member_type} }) {
		delete $tmpobj->{$member};
	    }
	} else {
	    for my $member (@{ $self->{members} }) {
		$tmpobj->{$member} = $obj->{$member}
		    if exists $obj->{$member};
	    }
	}
	Tangram::Type::Dump::flatten($context2->{storage}, $tmpobj);
	my $text = $context2->{storage}->to_dbms
	    ("blob", $self->{dumper}->($tmpobj));

	print $Tangram::TRACE "IDBIF - storing: ".Data::Dumper::Dumper($tmpobj)
	    if $Tangram::TRACE and $Tangram::DEBUG_LEVEL > 2;

	Tangram::Type::Dump::unflatten($context2->{storage}, $tmpobj);
	%$tmpobj = ();
	bless $tmpobj, "nothing";
	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};
    push @$vals, $dbh->quote(&{$memdef->{dumper}}($obj->{$member}));
  }
}

1;