/[cvs]/nfo/perl/libs/Class/Tangram.pm

Diff of /nfo/perl/libs/Class/Tangram.pm

Parent Directory | Revision Log | View Patch Patch

-revision 1.2 by joko,
Thu Oct 17 02:34:06 2002 UTC
+revision 1.3 by joko,
Thu Oct 17 02:34:45 2002 UTC
 Line 1
  package Class::Tangram;
- # Copyright (c) 2001 Sam Vilain. All rights reserved. This program is
+ # Copyright (c) 2001, 2002 Sam Vilain.  All right reserved.  This file
- # free software; you can redistribute it and/or modify it under the
+ # is licensed under the terms of the Perl Artistic license.
- # same terms as Perl itself.
- # Some modifications
- # $Id$
- # Copyright Бй 2001 Micro Sharp Technologies, Inc., Vancouver, WA, USA
- # Author: Karl M. Hegbloom <karlheg@microsharp.com>
- # Perl Artistic Licence.
  =head1 NAME
-Line 17 
 objects from a Tangram-compatible object
+Line 10 
 objects from a Tangram-compatible object
  =head1 SYNOPSIS
-  package Orange;
+  package MyObject;
   use base qw(Class::Tangram);
-  use vars qw($schema);
-  use Tangram::Ref;
-  # define the schema (ie, allowed attributes) of this object.  See the
+  our $fields => { int    => [ qw(foo bar) ],
-  # Tangram::Schema man page for more information on the syntax here.
+                   string => [ qw(baz quux) ] };
-  $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;
+  package main;
-  # 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
+  my $object = MyObject->new(foo => 2, baz => "hello");
-      ({ classes => [ 'Orange' => $Orange::schema ]});
-  sub schema { $dbschema };
+  print $object->baz();            # prints "hello"
-  package main;
+  $object->set_quux("Something");
-  # See Tangram::Relational for instructions on using "deploy" to
+  $object->set_foo("Something");   # dies - not an integer
-  # 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
+ =head1 DESCRIPTION
-  my $orange = Orange->new(juiciness => 8);
-  my $juiciness = $orange->juiciness;   # returns 8
-  # a "ref" must be set to a blessed object
+ Class::Tangram is a tool for defining objects attributes.  Simply
-  my $grower = bless { name => "Joe" }, "Farmer";
+ define your object's fields/attributes using the same syntax
-  $orange->set_grower ($grower);
+ introduced in _A Guided Tour of Tangram_, and you get objects that
+ work As You'd Expect(tm).
+ Class::Tangram has no dependancy upon Tangram, and vice versa.
+ Neither requires anything special of your objects, nor do they insert
+ any special fields into your objects.  This is a very important
+ feature with innumerable benefits, and few (if any) other object
+ persistence tools have this feature.
+ So, fluff aside, let's run through how you use Class::Tangram to make
+ objects.
+ First, you decide upon the attributes your object is going to have.
+ You might do this using UML, or you might pick an existing database
+ table and declare each column to be an attribute (you can leave out
+ "id"; that one is implicit).
+ Your object should use Class::Tangram as a base class;
+   use base qw(Class::Tangram)
+ or for older versions of perl:
+   use Class::Tangram;
+   use vars qw(@ISA);
+   @ISA = qw(Class::Tangram)
+ You should then define a C<$fields> variable in the scope of the
+ package, that is a B<hash> from attribute B<types> (see
+ L<Tangram::Type>) to either an B<array> of B<attribute names>, or
+ another B<hash> from B<attribute names> to B<options hashes> (or
+ C<undef>).  The layout of this structure coincides with the C<fields>
+ portion of a tangram schema (see L<Tangram::Schema>).  Note: the term
+ `schema' is used frequently to refer to the C<$fields> structure.
-  # these are all illegal
+ For example,
-  eval { $orange->set_juiciness ("Yum"); }; print $@;
-  eval { $orange->set_segments (31); }; print $@;
-  eval { $orange->set_grower ("Mr. Nice"); }; print $@;
-  # if you prefer
+  package MyObject;
-  $orange->get( "juiciness" );
+  use base qw(Class::Tangram);
-  $orange->set( juiciness => 123 );
- =head1 DESCRIPTION
+  our $fields = {
+      int => {
+          juiciness => undef,
+          segments => {
+              # this code reference is called when this
+              # attribute is set, to check the value is
+              # OK
+              check_func => sub {
+                  die "too many segments"
+                      if (${(shift)} > 30);
+              },
+              # the default for this attribute.
+              init_default => 7,
+          },
+      },
+      ref => {
+         grower => undef,
+      },
+      # 'required' attributes - insist that these fields are
+      # set, both with constructor and set()/set_X methods
+      string => {
+          # true: 'type' must have non-empty value (for
+          # strings) or be logically true (for other types)
+          type => { required => 1 },
+          # false: 'tag' must be defined but may be empty
+          tag => { required => '' },
+      },
+      # fields allowed by Class::Tangram but not ever
+      # stored by Tangram - no type checking by default
+      transient => [ qw(_tangible) ],
+  };
+ It is of critical importance to your sanity that you understand how
+ anonymous hashes and anonymous arrays work in Perl.  Some additional
+ features are used above that have not yet been introduced, but you
+ should be able to look at the above data structure and see that it
+ satisfies the conditions stated in the paragraph before it.  If it is
+ hazy, I recommend reading L<perlref> or L<perlreftut>.
+ When the schema for the object is first imported (see L<Schema
+ import>), Class::Tangram defines accessor functions for each of the
+ attributes defined in the schema.  These accessor functions are then
+ available as C<$object-E<gt>function> on created objects.  By virtue
+ of inheritance, various other methods are available.
- Class::Tangram is a base class originally intended for use with
+ From Class::Tangram 1.12 onwards, no use of perl's C<AUTOLOAD>
- Tangram objects, that gives you free constructors, access methods,
+ functionality is used.
- 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);
+ use vars qw($VERSION %defaults);
- $VERSION = "1.04";
- local $AUTOLOAD;
+ use Set::Object;
+ use Pod::Constants -trim => 1,
+     'MODULE RELEASE' => sub { ($VERSION) = /(\d+\.\d+)/ },
+     'Default Type Checking' => sub { %defaults = eval; };
  # $types{$class}->{$attribute} is the tangram type of each attribute
  my (%types);
+ # $attribute_options{$class}->{$attribute} is the hash passed to tangram
+ # for the given attribute
+ my (%attribute_options);
  # $check{$class}->{$attribute}->($value) is a function that will die
  # if $value is not alright, see check_X functions
  my (%check);
-Line 128 
 my (%cleaners);
+Line 155 
 my (%cleaners);
  # $init_defaults{$class}->{$attribute}
  my (%init_defaults);
+ # $required_attributes{$class}->{$attribute} records which attributes
+ # are required... used only by new() at present.
+ my (%required_attributes);
  # if a class is abstract, complain if one is constructed.
  my (%abstract);
  =head1 METHODS
+ The following methods are available for all Class::Tangram objects
+ =head2 Constructor
+ A Constructor is a method that returns a new instance of an object.
  =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
+ Sets up a new object of type C<Class>, with attributes set to the
- supplied.
+ values supplied.
- Can also be used as an object method, in which case it returns a
+ Can also be used as an object method (normal use is as a "class
- B<copy> of the object, without any deep copying.
+ method"), in which case it returns a B<copy> of the object, without
+ any deep copying.
  =cut
-Line 150 
 sub new ($@)
+Line 188 
 sub new ($@)
      my $invocant = shift;
      my $class = ref $invocant || $invocant;
-     my @values = @_;
+     (my @values, @_) = @_;
      # Setup the object
      my $self = { };
      bless $self, $class;
-     exists $check{$class} or import_schema($class);
+     # auto-load schema as necessary
+     exists $types{$class} or import_schema($class);
      croak "Attempt to instantiate an abstract type"
          if ($abstract{$class});
-     if ($invocant ne $class)
+     if (ref $invocant)
      {
          # The copy constructor; this could be better :)
          # this has the side effect of much auto-vivification.
-Line 171 
 sub new ($@)
+Line 210 
 sub new ($@)
      else
      {
          $self->set (@values); # start with @values
+     }
+     $self->_fill_init_default();
+     $self->_check_required();
-         # now fill in fields that have defaults
+     return $self;
-         for my $attribute (keys %{$init_defaults{$class}}) {
+ }
-             next if (exists $self->{$attribute});
+ sub _fill_init_default {
+     my $self = shift;
+     my $class = ref $self or die "_fill_init_default usage error";
+     # fill in fields that have defaults
+     while ( my ($attribute, $default) =
+             each %{$init_defaults{$class}} ) {
+         next if (exists $self->{$attribute});
+         my $setter = "set_$attribute";
+         if (ref $default eq "CODE") {
+             # sub { }, attribute gets return value
+             $self->$setter( $default->($self) );
+         } elsif (ref $default eq "HASH") {
+             # hash ref, copy hash
+             $self->$setter( { %{ $default } } );
+         } elsif (ref $default eq "ARRAY") {
+             # array ref, copy array
+             $self->$setter( [ @{ $default } ] );
-             my $default = $init_defaults{$class}->{$attribute}
+         } else {
-                 unless tied $init_defaults{$class}->{$attribute};
+             # something else, an object or a scalar
+             $self->$setter($default);
+         }
+     }
+ }
-             if (ref $default eq "CODE") {
+ sub _check_required {
-                 # sub { }, attribute gets return value
+     my $self = shift;
-                 $self->{$attribute}
+     my $class = ref $self;
-                     = $init_defaults{$class}->{$attribute}->();
+     # make sure field is not undef if 'required' option is set
-             } elsif (ref $default eq "HASH") {
+     if (my $required = $required_attributes{$class}) {
-                 # hash ref, copy hash
-                 $self->{$attribute}
+         # find the immediate caller outside of this package
-                     = { %{ $init_defaults{$class}->{$attribute} } };
+         my $i = 0;
+         $i++ while UNIVERSAL::isa($self, scalar(caller($i))||";->");
-             } elsif (ref $default eq "ARRAY") {
-                 # array ref, copy array
+         # give Tangram some lenience - it is exempt from the effects
-                 $self->{$attribute}
+         # of the "required" option
-                     = [ @{ $init_defaults{$class}->{$attribute} } ];
+         unless ( caller($i) =~ m/^Tangram::/ ) {
+             my @missing;
-             } else {
+             while ( my ($attribute, $value) = each %$required ) {
-                 # something else, an object or a scalar
+                 push(@missing, $attribute)
-                 $self->{$attribute}
+                     if ! exists $self->{$attribute};
-                     = $init_defaults{$class}->{$attribute};
              }
+             croak("object missing required attribute(s): "
+                   .join(', ',@missing).'.') if @missing;
          }
      }
-     return $self;
  }
+ =back
+ =head2 Accessing & Setting Attributes
+ =over
  =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.
+ This function simply calls C<$instance-E<gt>set_attribute($value)> for
+ each of the C<attribute =E<gt> $value> pairs passed to it.
  =cut
- sub set($@) {
+ sub set {
-     my ($self, @values) = (@_);
+     my $self = shift;
      # 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";
+     UNIVERSAL::isa($self, "Class::Tangram") or croak "type mismatch";
      my $class = ref $self;
      exists $check{$class} or import_schema($class);
+     croak "set must be called with an even number of arguments"
+         if (scalar(@_) & 1);
-     while (my ($name, $value) = splice @values, 0, 2) {
+     while (my ($name, $value) = splice @_, 0, 2) {
-         croak "attempt to set an illegal field $name in a $class"
-             if (!defined $check{$class}->{$name});
-         #local $@;
+         my $setter = "set_".$name;
-         # these handlers die on failure
+         croak "attempt to set an illegal field $name in a $class"
-         eval { $check{$class}->{$name}->(\$value) };
+             unless $self->can($setter);
-         $@ && croak ("value failed type check - ${class}->{$name}, "
-                      ."\"$value\" ($@)");
-         #should be ok now
+         $self->$setter($value);
-         $self->{$name} = $value;
      }
  }
- =item $instance->get($attribute)
+ =item $instance->get("attribute")
- Gets the value of $attribute.  If the attribute in question is a set,
+ Gets the value of C<$attribute>.  This simply calls
- and this method is called in list context, then it returns the MEMBERS
+ C<$instance-E<gt>get_attribute>.  If multiple attributes are listed,
- of the set (if called in scalar context, it returns the Set::Object
+ then a list of the attribute values is returned in order.  Note that
- container).
+ you get back the results of the scalar context C<get_attribute> call
+ in this case.
  =cut
- sub get($$) {
+ sub get {
-     my ($self, $field) = (@_);
+     my $self = shift;
-     $self->isa("Class::Tangram") or croak "type mismatch";
+     croak "get what?" unless @_;
+     UNIVERSAL::isa($self, "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) {
+     my $multiget = (scalar(@_) != 1);
-         if (!defined $self->{$field}) {
-             $self->{$field} = Set::Object->new();
+     my @return;
-         }
+     while ( my $field = shift ) {
-         if (wantarray) {
+         my $getter = "get_".$field;
-             return $self->{$field}->members;
+         croak "attempt to read an illegal field $field in a $class"
+             unless $self->can($getter);
+         if ( $multiget ) {
+             push @return, scalar($self->$getter());
+         } else {
+             return $self->$getter();
          }
      }
-     return $self->{$field};
+     return @return;
  }
  =item $instance->attribute($value)
- If $value is not given, then
+ If C<$value> is not given, then
- this is equivalent to $instance->get("attribute")
+ this is equivalent to C<$instance-E<gt>get_attribute>
- If $value is given, then this is equivalent to
+ If C<$value> is given, then this is equivalent to
- $instance->set("attribute", $value).  This usage issues a warning; you
+ C<$instance-E<gt>set_attribute($value)>.  This usage issues a warning
- should change your code to use the set_attribute syntax for better
+ if warnings are on; you should change your code to use the
- readability.
+ set_attribute syntax for better readability.  OO veterans will tell
+ you that for maintainability object method names should always be a
+ verb.
  =item $instance->get_attribute
  =item $instance->set_attribute($value)
- Equivalent to $instance->get("attribute") and $instance->set(attribute
+ The normative way of getting and setting attributes.  If you wish to
- => $value), respectively.
+ override the behaviour of an object when getting or setting an
+ attribute, override these functions.  They will be called when you use
+ C<$instance-E<gt>attribute>, C<$instance-E<gt>get()>, constructors,
+ etc.
  =item $instance->attribute_includes(@objects)
-Line 294 
 Equivalent to $instance->get("attribute"
+Line 381 
 Equivalent to $instance->get("attribute"
  =item $instance->attribute_remove(@objects)
- Equivalent to calling $instance->attribute->includes(@objects), etc.
+ This suite of functions applies to attributes that are sets (C<iset>
- This only works if the attribute in question is a Set::Object.
+ or C<set>).  It could in theory also apply generally to all
+ collections - ie also arrays (C<iarray> or C<array>), and hashes
+ (C<hash>, C<ihash>).  This will be implemented subject to user demand.
+ =back
+ B<Note:> The above functions can be overridden, but they may not be
+ called with the C<$self-E<gt>SUPER::> superclass chaining method.
+ This is because they are not defined within the scope of
+ Class::Tangram, only your package.
  =cut
- sub AUTOLOAD ($;$) {
+ =head1 ATTRIBUTE TYPE CHECKING
-     my ($self, $value) = (@_);
-     $self->isa("Class::Tangram") or croak "type mismatch";
-     my $class = ref $self;
+ Class::Tangram provides type checking of attributes when attributes
-     $AUTOLOAD =~ s/.*://;
+ are set - either using the default C<set_attribute> functions, or
-     if ($AUTOLOAD =~ m/^(set_|get_)?([^:]+)$/
+ created via the C<new> constructor.
-         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)
+ The checking has default behaviour for each type of attribute (see
+ L<Default Type Checking>), and can be extended arbitrarily via a
+ per-attribute C<check_func>, described below.  Critical attributes can
+ be marked as such with the C<required> flag.
- If you're replacing the AUTOLOAD function in your Class::Tangram
+ The specification of this type checking is placed in the class schema,
- derived class, but would still like to use the behaviour for one or
+ in the per-attribute B<options hash>.  This is a Class::Tangram
- two fields, then you can define functions for them to fall through to
+ extension to the Tangram schema structure.
- the Class::Tangram method, like so:
-  sub attribute { $_[0]->SUPER::getset("attribute", $_[1]) }
+ =over
- =cut
+ =item check_func
- sub getset($$;$) {
+ A function that is called with a B<reference> to the new value in
-     my ($self, $attr, $value) = (@_);
+ C<$_[0]>.  It should call C<die()> if the value is bad.  Note that
-     $self->isa("Class::Tangram") or croak "type mismatch";
+ this check_func will never be passed an undefined value; this is
+ covered by the "required" option, below.
-     if (defined $value) {
+ In the example schema (above), the attribute C<segments> has a
-         return set($self, $attr, $value);
+ C<check_func> that prevents setting the value to anything greater than
-     } else {
+.  Note that it does not prevent you from setting the value to
-         return get($self, $attr);
+ something that is not an integer; if you define a C<check_func>, it
-     }
+ replaces the default.
- }
+ =item required
+ If this option is set to a true value, then the attribute must be set
+ to a true value to pass type checking.  For string attributes, this
+ means that the string must be defined and non-empty (so "0" is true).
+ For other attribute types, the normal Perl definition of logical truth
+ is used.
+ If the required option is defined but logically false, (ie "" or 0),
+ then the attribute must also be defined, but may be set to a logically
+ false value.
+ If the required option is undefined, then the attribute may be set to
+ an undefined value.
+ For integration with tangram, the C<new()> function has a special
+ hack; if it is being invoked from within Tangram, then the required
+ test is skipped.
+ =back
+ =head2 Other per-attribute options
+ Any of the following options may be inserted into the per-attribute
+ B<options hash>:
+ =over
+ =item init_default
+ This value specifies the default value of the attribute when
+ it is created with C<new()>.  It is a scalar value, it is
+ copied to the fresh object.  If it is a code reference, that
+ code reference is called and its return value inserted into
+ the attribute.  If it is an ARRAY or HASH reference, then
+ that array or hash is COPIED into the attribute.
+ =item destroy_func
+ If anything special needs to happen to this attribute before the
+ object is destroyed (or when someone calls
+ C<$object-E<gt>clear_refs()>), then define this.  It is called as
+ C<$sub-E<gt>($object, "attribute")>.
+ =back
+ =head2 Default Type Checking
+  # The following list is eval'ed from this documentation
+  # when Class::Tangram loads, and used as default attribute
+  # options for the specified types.  So, eg, the default
+  # "init_default" for "set" types is a subroutine that
+  # returns a new Set::Object container.
+  # "parse" is special - it is passed the options hash given
+  # by the user and should return (\&check_func,
+  # \&destroy_func).  This is how the magical string type
+  # checking is performed - see the entry for parse_string(),
+  # below.
+  int         => { check_func   => \&check_int },
+  real        => { check_func   => \&check_real },
+  string      => { parse        => \&parse_string },
+  ref         => { check_func   => \&check_obj,
+                   destroy_func => \&destroy_ref },
+  array       => { check_func   => \&check_array,
+                   destroy_func => \&destroy_array },
+  iarray      => { check_func   => \&check_array,
+                   destroy_func => \&destroy_array },
+  flat_array  => { check_func   => \&check_flat_array },
+  set         => { check_func   => \&check_set,
+                   destroy_func => \&destroy_set,
+                   init_default => sub { Set::Object->new() } },
+  iset        => { check_func   => \&check_set,
+                   destroy_func => \&destroy_set,
+                   init_default => sub { Set::Object->new() } },
+  dmdatetime  => { check_func   => \&check_dmdatetime },
+  rawdatetime => { check_func   => \&check_rawdatetime },
+  rawdate     => { check_func   => \&check_rawdate },
+  rawtime     => { check_func   => \&check_rawtime },
+  flat_hash   => { check_func   => \&check_flat_hash },
+  transient   => { check_func   => \&check_nothing },
+  hash        => { check_func   => \&check_hash,
+                   destroy_func => \&destroy_hash,
+                   get_func     => \&get_hash },
+  perl_dump   => { check_func   => \&check_nothing }
+ =over
  =item check_X (\$value)
- This series of functions checks that $value is of the type X, and
+ This series of internal functions are built-in C<check_func> functions
- within applicable bounds.  If there is a problem, then it will croak()
+ defined for all of the standard Tangram attribute types.
- the error.  These functions are not called from the code, but by the
- set() method on a particular attribute.
+ =over
- Available functions are:
+ =item check_string
-   check_string - checks that the supplied value is less
+ checks that the supplied value is less than 255 characters long.
-                  than 255 characters long.
  =cut
  sub check_string {
-     croak "string ${$_[0]} too long"
+     croak "string too long"
          if (length ${$_[0]} > 255);
  }
- =pod
+ =item check_int
-   check_int    - checks that the value is a (possibly
+ checks that the value is a (possibly signed) integer
-                  signed) integer
  =cut
  my $int_re = qr/^-?\d+$/;
  sub check_int {
-     croak "not an int"
+     croak "not an integer"
-         if (${$_[0]} !~ m/$int_re/ms);
+         if (${$_[0]} !~ m/$int_re/o);
  }
- =pod
+ =item check_real
-   check_real   - checks that the value is a real number
+ checks that the value is a real number, by stringifying it and
-                  (m/^\d*(\.\d*)?(e\d*)?$/)
+ matching it against (C<m/^-?\d*(\.\d*)?(e-?\d*)?$/>).  Inefficient?
+ Yes.  Patches welcome.
  =cut
  my $real_re = qr/^-?\d*(\.\d*)?(e-?\d*)?$/;
  sub check_real {
-     croak "not a real"
+     croak "not a real number"
-         if (${$_[0]} !~ m/$real_re/ms);
+         if (${$_[0]} !~ m/$real_re/o);
  }
- =pod
+ =item check_obj
-   check_obj    - checks that the supplied variable is a
+ checks that the supplied variable is a reference to a blessed object
-                  reference to a blessed object
  =cut
-Line 409 
 sub check_real {
+Line 568 
 sub check_real {
  my $obj_re = qr/^(?:HASH|ARRAY|SCALAR)?$/;
  sub check_obj {
      croak "not an object reference"
-         if ((ref ${$_[0]}) =~ m/$obj_re/);
+         if ((ref ${$_[0]}) =~ m/$obj_re/o);
  }
- =pod
+ =item check_flat_array
-   check_flat_array
+ checks that $value is a ref ARRAY and that all elements are unblessed
-                - checks that $value is a ref ARRAY
+ scalars.  Does NOT currently check that all values are of the correct
+ type (int vs real vs string, etc)
  =cut
  sub check_flat_array {
      croak "not a flat array"
          if (ref ${$_[0]} ne "ARRAY");
+     croak "flat array may not contain references"
+         if (map { (ref $_ ? "1" : ()) } @{$_[0]});
  }
- =pod
+ =item check_array
-   check_array  - checks that $value is a ref ARRAY, and that
+ checks that $value is a ref ARRAY, and that each element in the array
-                  each element in the array is a reference to
+ is a reference to a blessed object.
-                  a blessed object.
  =cut
-Line 437 
 sub check_array {
+Line 598 
 sub check_array {
          if (ref ${$_[0]} ne "ARRAY");
      for my $a (@{${$_[0]}}) {
          croak "member in array not an object reference"
-             if ((ref $a) =~ m/$obj_re/);
+             if ((ref $a) =~ m/$obj_re/o);
      }
  }
- =pod
+ =item check_set
-   check_set    - checks that $value->isa("Set::Object")
+ 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"));
+         unless (UNIVERSAL::isa(${$_[0]}, "Set::Object"));
  }
- =pod
+ =item check_rawdate
-   check_rawdatetime
+ checks that $value is of the form YYYY-MM-DD, or YYYYMMDD, or YYMMDD.
-                - 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}$/;
+ my $rawdate_re = qr/^(?:  \d{4}-\d{2}-\d{2}
- sub check_rawdatetime {
+                      |    (?:\d\d){3,4}
-     croak "invalid SQL rawdatetime"
+                      )$/x;
-         unless (${$_[0]} =~ m/$rawdatetime_re/);
+ sub check_rawdate {
+     croak "invalid SQL rawdate"
+         unless (${$_[0]} =~ m/$rawdate_re/o);
  }
- =pod
+ =item check_rawtime
-   check_time
+ checks that $value is of the form HH:MM(:SS)?
-               - checks that $value is of the form
-                 HH:MM(:SS)?
  =cut
- my $time_re = qr/^\d{1,2}:\d{2}(?::\d{2})?$/;
+ # YYYY-MM-DD HH:MM:SS
- sub check_time {
+ my $rawtime_re = qr/^\d{1,2}:\d{2}(?::\d{2})?$/;
-     croak "invalid SQL time"
+ sub check_rawtime {
-         unless (${$_[0]} =~ m/$time_re/);
+     croak "invalid SQL rawtime"
+         unless (${$_[0]} =~ m/$rawtime_re/o);
+ }
+ =item check_rawdatetime
+ checks that $value is of the form YYYY-MM-DD HH:MM(:SS)? (the time
+ and/or the date can be missing), or a string of numbers between 6 and
+numbers long.
+ =cut
+ my $rawdatetime_re = qr/^(?:
+                             # YYYY-MM-DD HH:MM:SS
+                             (?: (?:\d{4}-\d{2}-\d{2}\s+)?
+                                 \d{1,2}:\d{2}(?::\d{2})?
+                             |   \d{4}-\d{2}-\d{2}
+                             )
+                          |  # YYMMDD, etc
+                             (?:\d\d){3,7}
+                          )$/x;
+ sub check_rawdatetime {
+     croak "invalid SQL rawdatetime dude"
+         unless (${$_[0]} =~ m/$rawdatetime_re/o);
  }
- =pod
+ =item check_dmdatetime
-   check_timestamp
+ checks that $value is of the form YYYYMMDDHH:MM:SS, or those allowed
-               - checks that $value is of the form
+ for rawdatetime.
-                 (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_dmdatetime {
- sub check_timestamp {
+     croak "invalid SQL rawdatetime dude"
-     croak "invalid SQL timestamp"
+         unless (${$_[0]} =~ m/^\d{10}:\d\d:\d\d$|$rawdatetime_re/o);
-         unless (${$_[0]} =~ m/$timestamp_re/);
  }
- =pod
+ =item check_flat_hash
-   check_flat_hash
+ checks that $value is a ref HASH and all values are scalars.  Does NOT
-                - checks that $value is a ref HASH
+ currently check that all values are of the correct type (int vs real
+ vs string, etc)
  =cut
-Line 511 
 sub check_flat_hash {
+Line 692 
 sub check_flat_hash {
      }
  }
- =pod
+ =item check_hash
-   check_hash   - checks that $value is a ref HASH, that
+ checks that $value is a ref HASH, that every key in the hash is a
-                  every key in the hash is a scalar, and that
+ scalar, and that every value is a blessed object.
-                  every value is a blessed object.
  =cut
-Line 530 
 sub check_hash {
+Line 710 
 sub check_hash {
      }
  }
- =pod
+ =item check_nothing
-   check_nothing - checks whether Australians like sport
+ checks whether Australians like sport
  =cut
  sub check_nothing { }
+ =back
  =item destroy_X ($instance, $attr)
  Similar story with the check_X series of functions, these are called
-Line 548 
 destroyed also>.  In other words, do not
+Line 730 
 destroyed also>.  In other words, do not
  share Set::Object containers or hash references in their attributes,
  otherwise when one gets destroyed the others will lose their data.
- Available functions are:
+ Available functions:
+ =over
-   destroy_array - empties an array
+ =item destroy_array
+ empties an array
  =cut
  sub destroy_array {
-     my ($self, $attr) = (@_);
+     my $self = shift;
+     my $attr = shift;
      my $t = tied $self->{$attr};
-     @{$self->{$attr}} = () unless ($t =~ m,Tangram::CollOnDemand,);
+     @{$self->{$attr}} = ()
+         unless (defined $t and $t =~ m,Tangram::CollOnDemand,);
      delete $self->{$attr};
  }
- =pod
+ =item destroy_set
-   destroy_set   - calls Set::Object::clear to clear the set
+ Calls Set::Object::clear to clear the set
  =cut
  sub destroy_set {
-     my ($self, $attr) = (@_);
+     my $self = shift;
+     my $attr = shift;
-     # warnings suck sometimes
-     local $^W = 0;
      my $t = tied $self->{$attr};
-     return if ($t =~ m,Tangram::CollOnDemand,);
+     return if (defined $t and $t =~ m,Tangram::CollOnDemand,);
      if (ref $self->{$attr} eq "Set::Object") {
          $self->{$attr}->clear;
      }
      delete $self->{$attr};
  }
- =pod
+ =item destroy_hash
-   destroy_hash  - empties a hash
+ empties a hash
  =cut
  sub destroy_hash {
-     my ($self, $attr) = (@_);
+     my $self = shift;
+     my $attr = shift;
      my $t = tied $self->{$attr};
-     %{$self->{$attr}} = () unless ($t =~ m,Tangram::CollOnDemand,);
+     %{$self->{$attr}} = ()
+         unless (defined $t and $t =~ m,Tangram::CollOnDemand,);
      delete $self->{$attr};
  }
- =pod
+ =item destroy_ref
-   destroy_ref   - destroys a reference.  Contains a hack for
+ destroys a reference.
-                   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) = (@_);
+     my $self = shift;
+     delete $self->{shift};
-     # 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};
-     }
  }
+ =back
  =item parse_X ($attribute, { schema option })
  Parses the schema option field, and returns one or two closures that
-Line 627 
 act as a check_X and a destroy_X functio
+Line 802 
 act as a check_X and a destroy_X functio
  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
+ quickly.  This is probably unmanagably unportable across databases;
- should be replaced by primitives that go the other way, building the
+ but send me bug reports on it anyway, and I'll try and make the
- SQL type definition from a more abstract definition of the type.
+ parsers work for as many databases as possible.
+ This perhaps 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:
+ =over
+ =item parse_string
+ parses SQL types of:
+ =over
  =cut
+ use vars qw($quoted_part $sql_list);
+ $quoted_part = qr/(?: \"([^\"]+)\" | \'([^\']+)\' )/x;
+ $sql_list = qr/\(\s*
+                   (
+                       $quoted_part
+                         (?:\s*,\s* $quoted_part )*
+                   ) \s*\)/x;
  sub parse_string {
-     my ($attribute, $option) = (@_);
+     my $attribute = shift;
+     my $option = shift;
      # simple case; return the check_string function.  We don't
      # need a destructor for a string so don't return one.
-Line 647 
 sub parse_string {
+Line 842 
 sub parse_string {
          return \&check_string;
      }
- =pod
+ =item CHAR(N), VARCHAR(N)
-       CHAR(N), VARCHAR(N)
+ closure checks length of string is less than N characters
-           closure checks length of string is less
-           than N characters
  =cut
-Line 662 
 sub parse_string {
+Line 855 
 sub parse_string {
                  if (length ${$_[0]} > $max_length);
          };
- =pod
+ =item TINYBLOB, BLOB, LONGBLOB
-       TINYBLOB, BLOB, LONGBLOB
+ checks max. length of string to be 255, 65535 or 16777215 chars
-       TINYTEXT, TEXT, LONGTEXT
+ respectively.  Also works with "TEXT" instead of "BLOB"
-           checks max. length of string to be 255,
-or 16777215 chars respectively
  =cut
-     } elsif ($option->{sql} =~ m/^\s*(tiny|long|medium)?
+     } elsif ($option->{sql} =~ m/^\s*(?:tiny|long|medium)?
-                                  (blob|text)/ix) {
+                                  (?: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);
+                 if (${$_[0]} and length ${$_[0]} > $max_length);
          };
- =pod
+ =item SET("members", "of", "set")
-       SET("members", "of", "set")
+ checks that the value passed is valid as a SQL set type, and that all
-           checks that the value passed is valid as
+ of the passed values are allowed to be a member of that set.
-           a SQL set type, and that all of the
-           passed values are allowed to be a member
-           of that set
  =cut
-     } elsif ($option->{sql} =~
+     } elsif (my ($members) = $option->{sql} =~
-              m/^\s*set\s*\(
+              m/^\s*set\s*$sql_list/oi) {
-                (\"[^\"]+\" (?:\s*,\s*\"[^\"]+\")* \s* )
-                \)\s*$/xi) {
+         my %members;
-         my $members = $1;
+         $members{lc($1 || $2)} = 1
-         my ($member, %members);
+             while ( $members =~ m/\G[,\s]*$quoted_part/cog );
-         while (($member, $members) =
-                ($members =~ m/^[,\s]*\"([^\"]+)\"(.*)$/)) {
-             $members{lc($member)} = 1;
-         }
          return sub {
-             for my $x (split /,/, ${$_[0]}) {
+             for my $x (split /\s*,\s*/, ${$_[0]}) {
                  croak ("SQL set badly formed or invalid member $x "
                         ." (SET" . join(",", keys %members). ")")
                      if (not exists $members{lc($x)});
              }
          };
- =pod
+ =item ENUM("possible", "values")
-       ENUM("possible", "values")
+ checks that the value passed is one of the allowed values.
-           checks that the value passed is one of
-           the allowed values.
  =cut
-     } elsif ($option->{sql} =~
+     } elsif (my ($values) = $option->{sql} =~
-              m/^\s*enum\s*\(
+              m/^\s*enum\s*$sql_list/oi ) {
-                (\"[^\"]+\" (?:\s*,\s*\"[^\"]+\")* \s* )
-                \)\s*/xi) {
+         my %values;
-         my $values = $1;
+         $values{lc($1 || $2)} = 1
-         my ($value, %values);
+             while ( $values =~ m/\G[,\s]*$quoted_part/gc);
-         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.
+ =back
- # 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
+ =back
-                 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
+ =back
-                 # 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";
+ =head2 Quick Object Dumping and Destruction
- }
+ =over
  =item $instance->quickdump
-Line 921 
 currently escape unprintable characters.
+Line 942 
 currently escape unprintable characters.
  =cut
  sub quickdump($) {
-     my ($self) = (@_);
+     my $self = shift;
      my $r = "REF ". (ref $self). "\n";
      for my $k (sort keys %$self) {
-Line 949 
 $k)
+Line 970 
 $k)
  =cut
  sub DESTROY($) {
-     my ($self) = (@_);
+     my $self = shift;
      my $class = ref $self;
-Line 987 
 Tangram::Storage->unload method.
+Line 1008 
 Tangram::Storage->unload method.
  =cut
  sub clear_refs($) {
-     my ($self) = (@_);
+     my $self = shift;
      my $class = ref $self;
      exists $cleaners{$class} or import_schema($class);
-Line 1002 
 sub clear_refs($) {
+Line 1022 
 sub clear_refs($) {
      $self->{_NOREFS} = 1;
  }
+ =back
+ =head1 FUNCTIONS
+ The following functions are not intended to be called as object
+ methods.
+ =head2 Schema Import
+  our $fields = { int => [ qw(foo bar) ],
+                  string => [ qw(baz quux) ] };
+  # Version 1.115 and below compatibility:
+  our $schema = {
+     fields => { int => [ qw(foo bar) ],
+                 string => [ qw(baz quux) ] }
+     };
+ =over
+ =item Class::Tangram::import_schema($class)
+ Parses a tangram object field list, in C<${"${class}::fields"}> (or
+ C<${"${class}::schema"}-E<gt>{fields}> to the internal type information
+ hashes.  It will also define all of the attribute accessor and update
+ methods in the C<$class> package.
+ Note that calling this function twice for the same class is not
+ tested and may produce arbitrary results.  Patches welcome.
+ =cut
+ sub import_schema($) {    # Damn this function is long
+     my $class = shift;
+     eval {
+         my ($fields, $bases, $abstract);
+         {
+             # Here, we go hunting around for their defined schema and
+             # options
+             no strict 'refs';
+             local $^W=0;
+             eval {
+                 $fields = (${"${class}::fields"} ||
+                            ${"${class}::schema"}->{fields});
+                 $abstract = (${"${class}::abstract"} ||
+                              ${"${class}::schema"}->{abstract});
+                 $bases = ${"${class}::schema"}->{bases};
+             };
+             if ( my @stack = @{"${class}::ISA"}) {
+                 # clean "bases" information from @ISA
+                 my %seen = map { $_ => 1 } $class, __PACKAGE__;
+                 $bases = [];
+                 while ( my $super = pop @stack ) {
+                     if ( defined ${"${super}::schema"}
+                          or defined ${"${super}::fields"} ) {
+                         push @$bases, $super;
+                     } else {
+                         push @stack, grep { !$seen{$_}++ }
+                             @{"${super}::ISA"};
+                     }
+                 }
+                 if ( !$fields and !@$bases ) {
+                     die ("No schema and no Class::Tangram "
+                          ."superclass for $class; define "
+                          ."${class}::fields!");
+                 }
+             }
+         }
+         # 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 ( @$bases ) {
+                 import_schema $super unless (exists $check{$super});
+                 # copy each of the per-class configuration hashes to
+                 # this class as defaults.
+                 my ($k, $v);
+                 # FIXME - this repetition of code is getting silly :)
+                 $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} } );
+                 $attribute_options{$class}->{$k} = $v
+                     while (($k, $v) = each %{ $attribute_options{$super} } );
+                 $init_defaults{$class}->{$k} = $v
+                     while (($k, $v) = each %{ $init_defaults{$super} } );
+                 $required_attributes{$class}->{$k} = $v
+                     while (($k, $v) = each %{ $required_attributes{$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, $options) = each %$v) {
+                 # this is what we are finding out about each attribute
+                 # $type is already set
+                 my ($default, $check_func, $required, $cleaner);
+                 # set defaults from what they give
+                 $options ||= {};
+                 if (ref $options eq "HASH" or
+                     UNIVERSAL::isa($options, 'Tangram::Type')) {
+                     ($check_func, $default, $required, $cleaner)
+                         = @{$options}{qw(check_func init_default
+                                          required destroy_func)};
+                 }
+                 # Fill their settings with info from defaults
+                 if (ref $def eq "HASH") {
+                     # try to magically parse their options
+                     if ( $def->{parse} and !($check_func and $cleaner) ) {
+                         my @a = $def->{parse}->($attribute, $options);
+                         $check_func ||= $a[0];
+                         $cleaner ||= $a[1];
+                     }
+                     # fall back to defaults for this class
+                     $check_func ||= $def->{check_func};
+                     $cleaner ||= $def->{destroy_func};
+                     $default = $def->{init_default} unless defined $default;
+                 }
+                 # everything must be checked!
+                 die "No check function for ${class}\->$attribute (type $type)"
+                     unless (ref $check_func eq "CODE");
+                 $types{$class}->{$attribute} = $type;
+                 $check{$class}->{$attribute} = $check_func;
+                 {
+                     no strict "refs";
+                     local ($^W) = 0;
+                     # build an appropriate "get_attribute" method, and
+                     # define other per-type methods
+                     my ($get_closure, $set_closure);
+                     # implement with closures for speed
+                     if ( $type =~ m/i?set/ ) {
+                         # GET_$attribute (Set::Object)
+                         $get_closure = sub {
+                             my $self = shift;
+                             if ( !defined $self->{$attribute} ) {
+                                 $self->{$attribute} = Set::Object->new();
+                             }
+                             my $set = $self->{$attribute};
+                             ( wantarray ? $set->members : $set )
+                         };
+                         # and add a whole load of other functions too
+                         for my $set_method (qw(includes insert size clear
+                                                remove)) {
+                             # ${attribute}_includes, etc
+                             my $set_method_closure = sub {
+                                 my $self = shift;
+                                 $self->{$attribute} = Set::Object->new()
+                                     unless defined $self->{$attribute};
+                                 return $self->{$attribute}->$set_method(@_);
+                             };
+                             *{$class."::${attribute}_$set_method"} =
+                                 $set_method_closure unless
+                                     (defined &{$class."::${attribute}_$set_method"});
+                         }
+                     } elsif ( $type =~ m/i?array/ ) {
+                         # GET_$attribute (array)
+                         # allow array slices, and return whole array
+                         # in list context
+                         $get_closure = sub {
+                             my $array = ($_[0]->{$attribute} ||= []);
+                             shift;
+                             if ( @_ ) {
+                                 @{$array}[@_];
+                             } else {
+                                 ( wantarray ? @{ $array } : $array )
+                             }
+                         };
+                     } elsif ( $type =~ m/i?hash/ ) {
+                         # GET_$attribute (hash)
+                         # allow hash slices, and return whole hash in
+                         # list context
+                         $get_closure = sub {
+                             my $hash = ($_[0]->{$attribute} ||= {});
+                             shift;
+                             if ( @_ ) {
+                                 @{$hash}{@_}
+                             } else {
+                                 ( wantarray ? %{ $hash } : $hash );
+                             }
+                         };
+                     } else {
+                         # GET_$attribute (scalar)
+                         # return value only
+                         $get_closure = sub { $_[0]->{$attribute}; };
+                     }
+                     *{$class."::get_$attribute"} = $get_closure
+                         unless (defined &{$class."::get_$attribute"});
+                     # SET_$attribute (all)
+                     my $checkit = \$check{$class}->{$attribute};
+                     # required hack for strings - duplicate the code
+                     # to avoid the following string comparison for
+                     # every set
+                     if ( $type eq "string" ) {
+                         $set_closure = sub {
+                             my $self = shift;
+                             my $value = shift;
+                             eval {
+                                 if ( defined $value and length $value ) {
+                                     ${$checkit}->(\$value);
+                                 } elsif ( $required ) {
+                                     die "value is required"
+                                 } elsif ( defined $required ) {
+                                     die "value must be defined"
+                                         unless defined $value;
+                                 }
+                             };
+                             $@ && croak("value failed type check - ${class}->"
+                                         ."set_$attribute('$value') ($@)");
+                             $self->{$attribute} = $value;
+                         };
+                     } else {
+                         $set_closure = sub {
+                             my $self = shift;
+                             my $value = shift;
+                             eval {
+                                 if ( $value ) {
+                                     ${$checkit}->(\$value);
+                                 } elsif ( $required ) {
+                                     die "value is required"
+                                 } elsif ( defined $required ) {
+                                     die "value must be defined"
+                                         unless defined $value;
+                                 }
+                             };
+                             $@ && croak("value failed type check - ${class}->"
+                                     ."set_$attribute('$value') ($@)");
+                             $self->{$attribute} = $value;
+                         };
+                     }
+                     # now export them into the caller's namespace
+                     my ($getter, $setter)
+                         = ("get_$attribute", "set_$attribute");
+                     *{$class."::$getter"} = $get_closure
+                         unless defined &{$class."::$getter"};
+                     *{$class."::$setter"} = $set_closure
+                         unless defined &{$class."::$setter"};
+                     *{$class."::$attribute"} = sub {
+                         my $self = shift;
+                         if ( @_ ) {
+                             warn("The OO Police say change your call "
+                                  ."to ->set_$attribute") if ($^W);
+                             #goto $set_closure;  # NO!  BAD!! :-)
+                             return $self->$setter(@_);
+                         } else {
+                             return $self->$getter(@_);
+                             #goto $get_closure;
+                         }
+                     } unless defined &{$class."::$attribute"};
+                 }
+                 $cleaners{$class}->{$attribute} = $cleaner
+                     if (defined $cleaner);
+                 $init_defaults{$class}->{$attribute} = $default
+                     if (defined $default);
+                 $required_attributes{$class}->{$attribute} = $required
+                     if (defined $required);
+                 $attribute_options{$class}->{$attribute} =
+                     ( $options || {} );
+             }
+         }
+     };
+     $@ && die "$@ while trying to import schema for $class";
+ }
+ =back
+ =head2 Run-time type information
+ It is possible to access the data structures that Class::Tangram uses
+ internally to verify attributes, create objects and so on.
+ This should be considered a B<HIGHLY EXPERIMENTAL> interface to
+ B<INTERNALS> of Class::Tangram.
+ Class::Tangram keeps seven internal hashes:
+ =over
+ =item C<%types>
+ C<$types{$class}-E<gt>{$attribute}> is the tangram type of each attribute,
+ ie "ref", "iset", etc.  See L<Tangram::Type>.
+ =item C<%attribute_options>
+ C<$attribute_options{$class}-E<gt>{$attribute}> is the options hash
+ for a given attribute.
+ =item C<%required_attributes>
+ C<$required_attributes{$class}-E<gt>{$attribute}> is the 'required'
+ option setting for a given attribute.
+ =item C<%check>
+ C<$check{$class}-E<gt>{$attribute}> is a function that will be passed
+ a reference to the value to be checked and either throw an exception
+ (die) or return true.
+ =item C<%cleaners>
+ C<$attribute_options{$class}-E<gt>{$attribute}> is a reference to a
+ destructor function for that attribute.  It is called as an object
+ method on the object being destroyed, and should ensure that any
+ circular references that this object is involved in get cleared.
+ =item C<%abstract>
+ C<$abstract-E<gt>{$class}> is set if the class is abstract
+ =item C<%init_defaults>
+ C<$init_defaults{$class}-E<gt>{$attribute}> represents what an
+ attribute is set to automatically if it is not specified when an
+ object is created. If this is a scalar value, the attribute is set to
+ the value. If it is a function, then that function is called (as a
+ method) and should return the value to be placed into that attribute.
+ If it is a hash ref or an array ref, then that structure is COPIED in
+ to the new object.  If you don't want that, you can do something like
+ this:
+    [...]
+     flat_hash => {
+         attribute => {
+             init_default => sub { { key => "value" } },
+         },
+     },
+    [...]
+ Now, every new object will share the same hash for that attribute.
  =back
+ There are currently four functions that allow you to access parts of
+ this information.
+ =over
+ =item Class::Tangram::attribute_options($class)
+ Returns a hash ref to a data structure from attribute names to the
+ option hash for that attribute.
+ =cut
+ sub attribute_options($) {
+     my $class = shift;
+     return $attribute_options{$class};
+ }
+ =item Class::Tangram::attribute_types($class)
+ Returns a hash ref from attribute names to the tangram type for that
+ attribute.
+ =cut
+ sub attribute_types($) {
+     my $class = shift;
+     return $types{$class};
+ }
+ =item Class::Tangram::required_attributes($class)
+ Returns a hash ref from attribute names to the 'required' option setting for
+ that attribute.  May also be called as a method, as in
+ C<$instance-E<gt>required_attributes>.
+ =cut
+ sub required_attributes($) {
+     my $class = ref $_[0] || $_[0];
+     return $required_attributes{$class};
+ }
+ =item Class::Tangram::init_defaults($class)
+ Returns a hash ref from attribute names to the default intial values for
+ that attribute.  May also be called as a method, as in
+ C<$instance-E<gt>init_defaults>.
+ =cut
+ sub init_defaults($) {
+     my $class = ref $_[0] || $_[0];
+     return $init_defaults{$class};
+ }
+ =item Class::Tangram::known_classes
+ This function returns a list of all the classes that have had their
+ object schema imported by Class::Tangram.
+ =cut
+ sub known_classes {
+     return keys %types;
+ }
+ =item Class::Tangram::is_abstract($class)
+ This function returns true if the supplied class is abstract.
+ =cut
+ sub is_abstract {
+     my $class = shift;
+     $class eq "Class::Tangram" && ($class = shift);
+     exists $cleaners{$class} or import_schema($class);
+ }
+ =item Class->set_init_default(attribute => $value);
+ Sets the default value on an attribute for newly created "Class"
+ objects, as if it had been declared with init_default.  Can be called
+ as a class or an instance method.
+ =cut
+ sub set_init_default {
+     my $invocant = shift;
+     my $class = ref $invocant || $invocant;
+     exists $init_defaults{$class} or import_schema($class);
+     while ( my ($attribute, $value) = splice @_, 0, 2) {
+         $init_defaults{$class}->{$attribute} = $value;
+     }
+ }
+ =back
+ =cut
+ # a little embedded package
+ package Tangram::Transient;
+ BEGIN {
+     eval "use base qw(Tangram::Type)";
+     if ( $@ ) {
+         # no tangram
+     } else {
+         $Tangram::Schema::TYPES{transient} = bless {}, __PACKAGE__;
+     }
+ }
+ sub coldefs { }
+ sub get_exporter { }
+ sub get_importer { }
+ sub get_import_cols {
+ #    print "Get_import_cols:" , Dumper \@_;
+     return ();
+ }
  =head1 SEE ALSO
  L<Tangram::Schema>
-Line 1013 
 B<A guided tour of Tangram, by Sound Obj
+Line 1532 
 B<A guided tour of Tangram, by Sound Obj
   http://www.soundobjectlogic.com/tangram/guided_tour/fs.html
- =head1 BUGS/TODO
+ =head1 DEPENDENCIES
+ The following modules are required to be installed to use
+ Class::Tangram:
- More datetime types.  I originally avoided the DMDateTime type because
+    Set::Object => 1.02
- Date::Manip is self-admittedly the most bloated module on CPAN, and I
+    Pod::Constants => 0.11
- didn't want to be seen encouraging it.  Then I found out about
+    Test::Simple => 0.18
- autosplit :-}.
+    Date::Manip => 5.21
- More AUTOLOAD methods, in particular for container types such as
+ Test::Simple and Date::Manip are only required to run the test suite.
- array, hash, etc.
- This documentation should be easy enough for a fool to understand.
+ If you find Class::Tangram passes the test suite with earlier versions
+ of the above modules, please send me an e-mail.
+ =head2 MODULE RELEASE
+ This is Class::Tangram version 1.12.
+ =head1 BUGS/TODO
  There should be more functions for breaking loops; in particular, a
- standard function called drop_refs($obj), which replaces references to
+ standard function called C<drop_refs($obj)>, which replaces references
- $obj with the appropriate Tangram::RefOnDemand so that an object can
+ to $obj with the appropriate C<Tangram::RefOnDemand> object so that an
- be unloaded via Tangram::Storage->unload() and actually have a hope of
+ object can be unloaded via C<Tangram::Storage->unload()> and actually
- being reclaimed.  Another function that would be handy would be a
+ have a hope of being reclaimed.  Another function that would be handy
- deep "mark" operation for mark & sweep garbage collection.
+ would be a deep "mark" operation for manual mark & sweep garbage
+ collection.
+ Need to think about writing some functions using C<Inline> for speed.
+ One of these days...
+ Allow C<init_default> values to be set in a default import function?
+ ie
+   use MyClassTangramObject -defaults => { foo => "bar" };
  =head1 AUTHOR
  Sam Vilain, <sam@vilain.net>
+ =head2 CREDITS
+  # Some modifications
+  # Copyright Бй 2001 Micro Sharp Technologies, Inc., Vancouver, WA, USA
+  # Author: Karl M. Hegbloom <karlheg@microsharp.com>
+  # Perl Artistic Licence.
+ Many thanks to Charles Owens and David Wheeler for their feedback,
+ ideas, patches and bug testing.
  =cut
 ;
+ __END__
+  # From old SYNOPSIS, I decided it was too long.  A lot of
+  # the information here needs to be re-integrated into the
+  # POD.
+  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;
+  # TIMTOWTDI - this is the condensed manpage version :)
+  my $dbschema = Tangram::Schema->new
+      ({ classes =>
+        [ 'Orange'   => { fields => $Orange::fields },
+          'MyObject' => { fields => $MyObject::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);
+  # Create an orange
+  my $orange = Orange->new(
+                           juiciness => 8,
+                           type => 'Florida',
+                           tag => '',  # required
+                          );
+  # Store it
+  $storage->insert($orange);
+  # This is how you get values out of the objects
+  my $juiciness = $orange->juiciness;
+  # a "ref" must be set to a blessed object, any object
+  my $grower = bless { name => "Joe" }, "Farmer";
+  $orange->set_grower ($grower);
+  # these are all illegal - type checking is fairly strict
+  my $orange = eval { Orange->new; };         print $@;
+  eval { $orange->set_juiciness ("Yum"); };   print $@;
+  eval { $orange->set_segments (31); };       print $@;
+  eval { $orange->set_grower ("Mr. Nice"); }; print $@;
+  # Demonstrate some "required" functionality
+  eval { $orange->set_type (''); };           print $@;
+  eval { $orange->set_type (undef); };        print $@;
+  eval { $orange->set_tag (undef); };         print $@;
+  # this works too, but is slower
+  $orange->get( "juiciness" );
+  $orange->set( juiciness => 123,
+                segments  => 17 );
+  # Re-configure init_default - make each new orange have a
+  # random juiciness
+  $orange->set_init_default( juiciness => sub { int(rand(45)) } );

 Legend:



Removed from v.1.2
 


changed lines


 
Added in v.1.3
 Legend:



Removed from v.1.2
 


changed lines


 
Added in v.1.3
-Removed from v.1.2
+Added in v.1.3

MailToCvsAdmin">MailToCvsAdmin	ViewVC Help
Powered by ViewVC 1.1.26