libs/Class/Tangram-1.04.pm

package Class::Tangram;

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

# Some modifications
# $Id: Tangram.pm,v 1.1 2002/07/27 00:20:12 cvsjoko Exp $
# Copyright © 2001 Micro Sharp Technologies, Inc., Vancouver, WA, USA
# Author: Karl M. Hegbloom <karlheg@microsharp.com>
# Perl Artistic Licence.

=head1 NAME

Class::Tangram - create constructors, accessor and update methods for
objects from a Tangram-compatible object specification.

=head1 SYNOPSIS

 package Orange;

 use base qw(Class::Tangram);
 use vars qw($schema);
 use Tangram::Ref;

 # define the schema (ie, allowed attributes) of this object.  See the
 # Tangram::Schema man page for more information on the syntax here.
 $schema = {
     table => "oranges",

     fields => {
         int => {
             juiciness => undef,
             segments => {
                 # here is a new one - this code reference is called
                 # when this attribute is set; it should die() on
                 # error, as it is wrapped in an eval { } block
                 check_func => sub {
                     die "too many segments"
                         if ($ {$_[0]} > 30);
                 },
                 # the default for this attribute.
                 init_default => 7,
             },
         },
         ref => {
             grower => undef,
         },
     },
 };
 Class::Tangram::import_schema("Orange");

 package Project;
 # here's where we build the individual object schemas into a
 # Tangram::Schema object, which the Tangram::Storage class uses to
 # know which tables and columns to find objects.
 use Tangram::Schema;

 my $dbschema = Tangram::Schema->new
     ({ classes => [ 'Orange' => $Orange::schema ]});

 sub schema { $dbschema };

 package main;

 # See Tangram::Relational for instructions on using "deploy" to
 # create the database this connects to.  You only have to do this if
 # you want to write the objects to a database.
 use Tangram::Relational;
 my ($dsn, $u, $p);
 my $storage = Tangram::Relational->connect(Project->schema,
                                            $dsn, $u, $p);

 # OK
 my $orange = Orange->new(juiciness => 8);
 my $juiciness = $orange->juiciness;   # returns 8

 # a "ref" must be set to a blessed object
 my $grower = bless { name => "Joe" }, "Farmer";
 $orange->set_grower ($grower);

 # these are all illegal
 eval { $orange->set_juiciness ("Yum"); }; print $@;
 eval { $orange->set_segments (31); }; print $@;
 eval { $orange->set_grower ("Mr. Nice"); }; print $@;

 # if you prefer
 $orange->get( "juiciness" );
 $orange->set( juiciness => 123 );

=head1 DESCRIPTION

Class::Tangram is a base class originally intended for use with
Tangram objects, that gives you free constructors, access methods,
update methods, and a destructor that should help in breaking circular
references for you. Type checking is achieved by parsing the schema
for the object, which is contained within the object class in an
exported variable C<$schema>.

After writing this I found that it was useful for merely adding type
checking and validation to arbitrary objects.  There are several
modules on CPAN to do that already, but many don't have finely grained
type checking, and none of them integrated with Tangram.

=cut

use strict;
use Carp qw(croak cluck);

use vars qw($AUTOLOAD $VERSION);
$VERSION = "1.04";

local $AUTOLOAD;

# $types{$class}->{$attribute} is the tangram type of each attribute
my (%types);

# $check{$class}->{$attribute}->($value) is a function that will die
# if $value is not alright, see check_X functions
my (%check);

# Destructors for each attribute.  They are called as
# $cleaners{$class}->{$attribute}->($self, $attribute);
my (%cleaners);

# init_default values for each attribute.  These could be hash refs,
# array refs, code refs, or simple scalars.  They will be stored as
# $init_defaults{$class}->{$attribute}
my (%init_defaults);

# if a class is abstract, complain if one is constructed.
my (%abstract);

=head1 METHODS

=over 4

=item Class-E<gt>new (attribute1 =E<gt> value, attribute2 =E<gt> value)

sets up a new object of type Class, with attributes set to the values
supplied.

Can also be used as an object method, in which case it returns a
B<copy> of the object, without any deep copying.

=cut

sub new ($@)
{
    my $invocant = shift;
    my $class = ref $invocant || $invocant;

    my @values = @_;

    # Setup the object
    my $self = { };
    bless $self, $class;

    exists $check{$class} or import_schema($class);

    croak "Attempt to instantiate an abstract type"
        if ($abstract{$class});

    if ($invocant ne $class)
    {
        # The copy constructor; this could be better :)
        # this has the side effect of much auto-vivification.
        %$self = %$invocant;
        $self->set (@values); # override with @values
    }
    else
    {
        $self->set (@values); # start with @values

        # now fill in fields that have defaults
        for my $attribute (keys %{$init_defaults{$class}}) {

            next if (exists $self->{$attribute});

            my $default = $init_defaults{$class}->{$attribute}
                unless tied $init_defaults{$class}->{$attribute};

            if (ref $default eq "CODE") {
                # sub { }, attribute gets return value
                $self->{$attribute}
                    = $init_defaults{$class}->{$attribute}->();

            } elsif (ref $default eq "HASH") {
                # hash ref, copy hash
                $self->{$attribute}
                    = { %{ $init_defaults{$class}->{$attribute} } };

            } elsif (ref $default eq "ARRAY") {
                # array ref, copy array
                $self->{$attribute}
                    = [ @{ $init_defaults{$class}->{$attribute} } ];

            } else {
                # something else, an object or a scalar
                $self->{$attribute}
                    = $init_defaults{$class}->{$attribute};
            }
        }
    }
    return $self;
}

=item $instance->set(attribute => $value, ...)

Sets the attributes of the given instance to the given values.  croaks
if there is a problem with the values.

=cut

sub set($@) {
    my ($self, @values) = (@_);

    # yes, this is a lot to do.  yes, it's slow.  But I'm fairly
    # certain that this could be handled efficiently if it were to be
    # moved inside the Perl interpreter or an XS module
    $self->isa("Class::Tangram") or croak "type mismatch";
    my $class = ref $self;
    exists $check{$class} or import_schema($class);

    while (my ($name, $value) = splice @values, 0, 2) {
        croak "attempt to set an illegal field $name in a $class"
            if (!defined $check{$class}->{$name});

        #local $@;

        # these handlers die on failure
        eval { $check{$class}->{$name}->(\$value) };
        $@ && croak ("value failed type check - ${class}->{$name}, "
                     ."\"$value\" ($@)");

        #should be ok now
        $self->{$name} = $value;
    }
}

=item $instance->get($attribute)

Gets the value of $attribute.  If the attribute in question is a set,
and this method is called in list context, then it returns the MEMBERS
of the set (if called in scalar context, it returns the Set::Object
container).

=cut

sub get($$) {
    my ($self, $field) = (@_);
    $self->isa("Class::Tangram") or croak "type mismatch";
    my $class = ref $self;
    exists $check{$class} or import_schema($class);
    croak "attempt to read an illegal field $field in a $class"
        if (!defined $check{$class}->{$field});

    if ($types{$class}->{$field} =~ m/^i?set$/o) {
        if (!defined $self->{$field}) {
            $self->{$field} = Set::Object->new();
        }
        if (wantarray) {
            return $self->{$field}->members;
        }
    }

    return $self->{$field};
}

=item $instance->attribute($value)

If $value is not given, then
this is equivalent to $instance->get("attribute")

If $value is given, then this is equivalent to
$instance->set("attribute", $value).  This usage issues a warning; you
should change your code to use the set_attribute syntax for better
readability.

=item $instance->get_attribute

=item $instance->set_attribute($value)

Equivalent to $instance->get("attribute") and $instance->set(attribute
=> $value), respectively.

=item $instance->attribute_includes(@objects)

=item $instance->attribute_insert(@objects)

=item $instance->attribute_size

=item $instance->attribute_clear

=item $instance->attribute_remove(@objects)

Equivalent to calling $instance->attribute->includes(@objects), etc.
This only works if the attribute in question is a Set::Object.

=cut

sub AUTOLOAD ($;$) {
    my ($self, $value) = (@_);
    $self->isa("Class::Tangram") or croak "type mismatch";

    my $class = ref $self;
    $AUTOLOAD =~ s/.*://;
    if ($AUTOLOAD =~ m/^(set_|get_)?([^:]+)$/
        and defined $types{$class}->{$2}) {

        # perl sucks at this type of test
        if ((defined $1 and $1 eq "set_")
            or (!defined $1 and defined $value)) {

            if ($^W && !defined $1) {
                cluck("The OO police say change your call to "
                      ."\$obj->set_$2");
            }
            return set($self, $2, $value);
        } else {
            return get($self, $2);
        }
    } elsif (my ($attr, $method) =
             ($AUTOLOAD =~ m/^(.*)_(includes|insert|
                             size|clear|remove)$/x)
             and $types{$class}->{$1} =~ m/^i?set$/) {
        return get($self, $attr)->$method(@_[1..$#_]);
    } else {
        croak("unknown method/attribute ${class}->$AUTOLOAD called");
    }
}

=item $instance->getset($attribute, $value)

If you're replacing the AUTOLOAD function in your Class::Tangram
derived class, but would still like to use the behaviour for one or
two fields, then you can define functions for them to fall through to
the Class::Tangram method, like so:

 sub attribute { $_[0]->SUPER::getset("attribute", $_[1]) }

=cut

sub getset($$;$) {
    my ($self, $attr, $value) = (@_);
    $self->isa("Class::Tangram") or croak "type mismatch";

    if (defined $value) {
        return set($self, $attr, $value);
    } else {
        return get($self, $attr);
    }

}

=item check_X (\$value)

This series of functions checks that $value is of the type X, and
within applicable bounds.  If there is a problem, then it will croak()
the error.  These functions are not called from the code, but by the
set() method on a particular attribute.

Available functions are:

  check_string - checks that the supplied value is less
                 than 255 characters long.

=cut

sub check_string {
    croak "string ${$_[0]} too long"
        if (length ${$_[0]} > 255);
}

=pod

  check_int    - checks that the value is a (possibly
                 signed) integer

=cut

my $int_re = qr/^-?\d+$/;
sub check_int {
    croak "not an int"
        if (${$_[0]} !~ m/$int_re/ms);
}

=pod

  check_real   - checks that the value is a real number
                 (m/^\d*(\.\d*)?(e\d*)?$/)

=cut

my $real_re = qr/^-?\d*(\.\d*)?(e-?\d*)?$/;
sub check_real {
    croak "not a real"
        if (${$_[0]} !~ m/$real_re/ms);
}

=pod

  check_obj    - checks that the supplied variable is a
                 reference to a blessed object

=cut

# this pattern matches a regular reference
my $obj_re = qr/^(?:HASH|ARRAY|SCALAR)?$/;
sub check_obj {
    croak "not an object reference"
        if ((ref ${$_[0]}) =~ m/$obj_re/);
}

=pod

  check_flat_array
               - checks that $value is a ref ARRAY

=cut

sub check_flat_array {
    croak "not a flat array"
        if (ref ${$_[0]} ne "ARRAY");
}

=pod

  check_array  - checks that $value is a ref ARRAY, and that
                 each element in the array is a reference to
                 a blessed object.

=cut

sub check_array {
    croak "array attribute not passed an array ref"
        if (ref ${$_[0]} ne "ARRAY");
    for my $a (@{${$_[0]}}) {
        croak "member in array not an object reference"
            if ((ref $a) =~ m/$obj_re/);
    }
}

=pod

  check_set    - checks that $value->isa("Set::Object")

=cut

sub check_set {
    croak "set type not passed a Set::Object"
        unless (ref ${$_[0]} and ${$_[0]}->isa("Set::Object"));
}

=pod

  check_rawdatetime 
               - checks that $value is of the form
                 YYYY-MM-DD HH:MM:SS

=cut

# YYYY-MM-DD HH:MM:SS
my $rawdatetime_re = qr/^\d{4}-\d{2}-\d{2}\s+\d{1,2}:\d{2}:\d{2}$/;
sub check_rawdatetime {
    croak "invalid SQL rawdatetime"
        unless (${$_[0]} =~ m/$rawdatetime_re/);
}

=pod

  check_time
              - checks that $value is of the form
                HH:MM(:SS)?

=cut

my $time_re = qr/^\d{1,2}:\d{2}(?::\d{2})?$/;
sub check_time {
    croak "invalid SQL time"
        unless (${$_[0]} =~ m/$time_re/);
}

=pod

  check_timestamp
              - checks that $value is of the form
                (YYYY-MM-DD )?HH:MM(:SS)?

=cut

my $timestamp_re = qr/^(?:\d{4}-\d{2}-\d{2}\s+)?\d{1,2}:\d{2}(?::\d{2})?$/;
sub check_timestamp {
    croak "invalid SQL timestamp"
        unless (${$_[0]} =~ m/$timestamp_re/);
}

=pod

  check_flat_hash
               - checks that $value is a ref HASH

=cut

sub check_flat_hash {
    croak "not a hash"
        unless (ref ${$_[0]} eq "HASH");
    while (my ($k, $v) = each %${$_[0]}) {
        croak "hash not flat"
            if (ref $k or ref $v);
    }
}

=pod

  check_hash   - checks that $value is a ref HASH, that
                 every key in the hash is a scalar, and that
                 every value is a blessed object.

=cut

sub check_hash {
    croak "not a hash"
        unless (ref ${$_[0]} eq "HASH");
    while (my ($k, $v) = each %${$_[0]}) {
        croak "hash key not flat"
            if (ref $k);
        croak "hash value not an object"
            if (ref $v !~ m/$obj_re/);
    }
}

=pod

  check_nothing - checks whether Australians like sport

=cut

sub check_nothing { }

=item destroy_X ($instance, $attr)

Similar story with the check_X series of functions, these are called
during object destruction on every attribute that has a reference that
might need breaking.  Note: B<these functions all assume that
attributes belonging to an object that is being destroyed may be
destroyed also>.  In other words, do not allow distinct objects to
share Set::Object containers or hash references in their attributes,
otherwise when one gets destroyed the others will lose their data.

Available functions are:

  destroy_array - empties an array

=cut

sub destroy_array {
    my ($self, $attr) = (@_);
    my $t = tied $self->{$attr};
    @{$self->{$attr}} = () unless ($t =~ m,Tangram::CollOnDemand,);
    delete $self->{$attr};
}

=pod

  destroy_set   - calls Set::Object::clear to clear the set

=cut

sub destroy_set {
    my ($self, $attr) = (@_);

    # warnings suck sometimes
    local $^W = 0;

    my $t = tied $self->{$attr};
    return if ($t =~ m,Tangram::CollOnDemand,);
    if (ref $self->{$attr} eq "Set::Object") {
        $self->{$attr}->clear;
    }
    delete $self->{$attr};
}

=pod

  destroy_hash  - empties a hash

=cut

sub destroy_hash {
    my ($self, $attr) = (@_);
    my $t = tied $self->{$attr};
    %{$self->{$attr}} = () unless ($t =~ m,Tangram::CollOnDemand,);
    delete $self->{$attr};
}

=pod

  destroy_ref   - destroys a reference.  Contains a hack for
                  Tangram so that if this ref is not loaded,
                  it will not be autoloaded when it is
                  attempted to be accessed.

=cut

sub destroy_ref {
    my ($self, $attr) = (@_);

    # warnings suck sometimes
    local $^W = 0;

    # the only reason I bother with all of this is that I experienced
    # Perl did not always call an object's destructor if you just used
    # delete.
    my $t = tied $self->{$attr};
    if (defined $t and $t =~ m/OnDemand/) {
        delete $self->{$attr};
    } else {
        my $ref = delete $self->{$attr};
    }
}

=item parse_X ($attribute, { schema option })

Parses the schema option field, and returns one or two closures that
act as a check_X and a destroy_X function for the attribute.

This is currently a very ugly hack, parsing the SQL type definition of
an object.  But it was bloody handy in my case for hacking this in
quickly.  This is unmanagably unportable across databases.  This
should be replaced by primitives that go the other way, building the
SQL type definition from a more abstract definition of the type.

Available functions:

  parse_string  - parses SQL types of:

=cut

sub parse_string {

    my ($attribute, $option) = (@_);

    # simple case; return the check_string function.  We don't
    # need a destructor for a string so don't return one.
    if (!$option->{sql}) {
        return \&check_string;
    }

=pod

      CHAR(N), VARCHAR(N)
          closure checks length of string is less
          than N characters

=cut

    if ($option->{sql} =~ m/^\s*(?:var)?char\s*\(\s*(\d+)\s*\)/ix) {
        my $max_length = $1;
        return sub {
            die "string too long for $attribute"
                if (length ${$_[0]} > $max_length);
        };

=pod

      TINYBLOB, BLOB, LONGBLOB
      TINYTEXT, TEXT, LONGTEXT
          checks max. length of string to be 255,
          65535 or 16777215 chars respectively

=cut

    } elsif ($option->{sql} =~ m/^\s*(tiny|long|medium)?
                                 (blob|text)/ix) {
        my $max_length = ($1 ? ($1 eq "tiny"?255:2**24 - 1)
                          : 2**16 - 1);
        return sub {
            die "string too long for $attribute"
                if (length ${$_[0]} > $max_length);
        };

=pod

      SET("members", "of", "set")
          checks that the value passed is valid as
          a SQL set type, and that all of the 
          passed values are allowed to be a member
          of that set

=cut

    } elsif ($option->{sql} =~
             m/^\s*set\s*\(
               (\"[^\"]+\" (?:\s*,\s*\"[^\"]+\")* \s* )
               \)\s*$/xi) {
        my $members = $1;
        my ($member, %members);
        while (($member, $members) =
               ($members =~ m/^[,\s]*\"([^\"]+)\"(.*)$/)) {
            $members{lc($member)} = 1;
        }
        return sub {
            for my $x (split /,/, ${$_[0]}) {
                croak ("SQL set badly formed or invalid member $x "
                       ." (SET" . join(",", keys %members). ")")
                    if (not exists $members{lc($x)});
            }
        };

=pod

      ENUM("possible", "values")
          checks that the value passed is one of
          the allowed values.

=cut

    } elsif ($option->{sql} =~
             m/^\s*enum\s*\(
               (\"[^\"]+\" (?:\s*,\s*\"[^\"]+\")* \s* )
               \)\s*/xi) {
        my $values = $1;
        my ($value, %values);
        while (($value, $values) =
               ($values =~ m/^[,\s]*\"([^\"]+)\"(.*)$/)) {
            $values{lc($value)} = 1;
        }
        return sub {
            croak ("invalid enum value ${$_[0]} must be ("
                   . join(",", keys %values). ")")
                if (not exists $values{lc(${$_[0]})});
        }

    } else {
        die ("Please build support for your string SQL type in "
             ."Class::Tangram (".$option->{sql}.")");
    }
}

# Here is where I map Tangram::Type types to functions.
# Format:
#  type => {
#      check => \&check_X
#      parse => \&parse_type
#      destroy => \&destroy_X
#  }
#
my %defaults =
    (
     int         => { check => \&check_int },
     real        => { check => \&check_real },
     string      => {             parse => \&parse_string },
     ref         => { check => \&check_obj,     destroy => \&destroy_ref },
     array       => { check => \&check_array,   destroy => \&destroy_array },
     iarray      => { check => \&check_array,   destroy => \&destroy_array },
     flat_array  => { check => \&check_flat_array },
     set         => { check => \&check_set,     destroy => \&destroy_set },
     iset        => { check => \&check_set,     destroy => \&destroy_set },
     rawdatetime => { check => \&check_rawdatetime },
     time        => { check => \&check_time },
     timestamp   => { check => \&check_timestamp },
     flat_hash   => { check => \&check_flat_hash },
     hash        => { check => \&check_hash,    destroy => \&destroy_hash },
     perl_dump   => { check => \&check_nothing }
    );

=item import_schema($class)

Parses a tangram object schema, in "\$${class}::schema" to the
internal representation used to check types values by set().  Called
automatically on the first get(), set(), or new() for an object of a
given class.

This function updates Tangram schema option hashes, with the following
keys:

  check_func   - supply/override the check_X function for
                 this attribute.

  destroy_func - supply/override the destroy_X function for
                 this attribute

See the SYNOPSIS section for an example of supplying a check_func in
an object schema.

=cut

sub import_schema($) {
    my ($class) = (@_);

    eval {
        my ($fields, $bases, $abstract);
        {
            no strict 'refs';
            $fields = ${"${class}::schema"}->{fields};
            $bases = ${"${class}::schema"}->{bases};
            $abstract = ${"${class}::schema"}->{abstract};
        }

        my $check_class = { };
        my $cleaners_class = { };
        my $init_defaults_class = { };
        my $types_class = { };

        # if this is an abstract type, do not allow it to be
        # instantiated
        if ($abstract) {
            $abstract{$class} = 1;
        }

        # If there are any base classes, import them first so that the
        # check, cleaners and init_defaults can be inherited
        if (defined $bases) {
            (ref $bases eq "ARRAY")
                or die "bases not an array ref for $class";

            # Note that the order of your bases is significant, that
            # is if you are using multiple iheritance then the later
            # classes override the earlier ones.
            #for my $super ( Class::ISA::super_path($class) ) {
            for my $super ( @$bases ) {
                import_schema $super unless (exists $check{$super});

                # copy each of the per-class configuration hashes to
                # this class as defaults.
                my ($k, $v);
                $types_class->{$k} = $v
                    while (($k, $v) = each %{ $types{$super} } );
                $check_class->{$k} = $v
                    while (($k, $v) = each %{ $check{$super} } );
                $cleaners_class->{$k} = $v
                    while (($k, $v) = each %{ $cleaners{$super} } );
                $init_defaults_class->{$k} = $v
                    while (($k, $v) = each %{ $init_defaults{$super} } );
            }
        }

        # iterate over each of the *types* of fields (string, int, ref, etc.)
        while (my ($type, $v) = each %$fields) {
            if (ref $v eq "ARRAY") {
                $v = { map { $_, undef } @$v };
            }
            my $def = $defaults{$type};

            # iterate each of the *attributes* of a particular type
            while (my ($attribute, $option) = each %$v) {
                $types_class->{$attribute} = $type;

                # ----- check_X functions ----
                if (ref $option eq "HASH" and $option->{check_func}) {
                    # user-supplied check_X function
                    $check_class->{$attribute} =
                        $option->{check_func};

                } else {
                    if (not defined $def) {
                        die "No default check function for type $type";
                    }

                    # check for a type-specific option hash parser
                    if ($def->{parse}) {
                        my ($check, $destroy) =
                            $def->{parse}->($attribute, $option);

                        $check_class->{$attribute} = $check;
                        $cleaners_class->{$attribute} = $destroy
                            if (defined $destroy);

                    } else {
                        # use the default for this type
                        $check_class->{$attribute} = $def->{check};
                    }
                }

                # ----- destroy_X functions
                if (ref $option eq "HASH" and $option->{destroy_func}) {
                    # user-supplied destroy_X function
                    $cleaners_class->{$attribute} =
                        $option->{destroy_func};
                } else {
                    if ($def->{destroy}) {
                        # use the default for this type
                        $cleaners_class->{$attribute} =
                            $def->{destroy};
                    }
                }

                # ----- init_default functions
                # create empty Set::Object containers as necessary
                if ($type =~ m/^i?set$/) {
                    $init_defaults_class->{$attribute} =
                        sub { Set::Object->new() };
                }
                if (ref $option eq "HASH" and $option->{init_default}) {
                    $init_defaults_class->{$attribute} =
                        $option->{init_default};
                }
            }
        }
        $types{$class} = $types_class;
        $check{$class} = $check_class;
        $cleaners{$class} = $cleaners_class;
        $init_defaults{$class} = $init_defaults_class;
    };

    $@ && die "$@ while trying to import schema for $class";
}


=item $instance->quickdump

Quickly show the blessed hash of an object, without descending into
it.  Primarily useful when you have a large interconnected graph of
objects so don't want to use the B<x> command within the debugger.
It also doesn't have the side effect of auto-vivifying members.

This function returns a string, suitable for print()ing.  It does not
currently escape unprintable characters.

=cut

sub quickdump($) {
    my ($self) = (@_);

    my $r = "REF ". (ref $self). "\n";
    for my $k (sort keys %$self) {
        $r .= ("   $k => "
               . (
                  tied $self->{$k}
                  || ( ref $self->{$k}
                       ? $self->{$k}
                       : "'".$self->{$k}."'" )
                 )
               . "\n");
    }
    return $r;
}


=item $instance->DESTROY

This function ensures that all of your attributes have their
destructors called.  It calls the destroy_X function for attributes
that have it defined, if that attribute exists in the instance that we
are destroying.  It calls the destroy_X functions as destroy_X($self,
$k)

=cut

sub DESTROY($) {
    my ($self) = (@_);

    my $class = ref $self;

    # if no cleaners are known for this class, it hasn't been imported
    # yet.  Don't call import_schema, that would be a bad idea in a
    # destructor.
    exists $cleaners{$class} or return;

    # for every attribute that is defined, and has a cleaner function,
    # call the cleaner function.
    for my $k (keys %$self) {
        if (defined $cleaners{$class}->{$k} and exists $self->{$k}) {
            $cleaners{$class}->{$k}->($self, $k);
        }
    }
    $self->{_DESTROYED} = 1;
}

=item $instance->clear_refs

This clears all references from this object, ie exactly what DESTROY
normally does, but calling an object's destructor method directly is
bad form.  Also, this function has no qualms with loading the class'
schema with import_schema() as needed.

This is useful for breaking circular references, if you know you are
no longer going to be using an object then you can call this method,
which in many cases will end up cleaning up most of the objects you
want to get rid of.

However, it still won't do anything about Tangram's internal reference
to the object, which must still be explicitly unlinked with the
Tangram::Storage->unload method.

=cut

sub clear_refs($) {
    my ($self) = (@_);

    my $class = ref $self;

    exists $cleaners{$class} or import_schema($class);

    # break all ref's, sets, arrays
    for my $k (keys %$self) {
        if (defined $cleaners{$class}->{$k} and exists $self->{$k}) {
            $cleaners{$class}->{$k}->($self, $k);
        }
    }
    $self->{_NOREFS} = 1;
}


=back

=head1 SEE ALSO

L<Tangram::Schema>

B<A guided tour of Tangram, by Sound Object Logic.>

 http://www.soundobjectlogic.com/tangram/guided_tour/fs.html

=head1 BUGS/TODO

More datetime types.  I originally avoided the DMDateTime type because
Date::Manip is self-admittedly the most bloated module on CPAN, and I
didn't want to be seen encouraging it.  Then I found out about
autosplit :-}.

More AUTOLOAD methods, in particular for container types such as
array, hash, etc.

This documentation should be easy enough for a fool to understand.

There should be more functions for breaking loops; in particular, a
standard function called drop_refs($obj), which replaces references to
$obj with the appropriate Tangram::RefOnDemand so that an object can
be unloaded via Tangram::Storage->unload() and actually have a hope of
being reclaimed.  Another function that would be handy would be a
deep "mark" operation for mark & sweep garbage collection.

=head1 AUTHOR

Sam Vilain, <sam@vilain.net>

=cut

69;
MailToCvsAdmin">MailToCvsAdmin	ViewVC Help
Powered by ViewVC 1.1.26