--- nfo/perl/libs/Class/Tangram.pm 2002/10/17 02:34:06 1.2 +++ nfo/perl/libs/Class/Tangram.pm 2002/10/17 02:34:45 1.3 @@ -1,14 +1,7 @@ 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.2 2002/10/17 02:34:06 joko dead $ -# Copyright 2001 Micro Sharp Technologies, Inc., Vancouver, WA, USA -# Author: Karl M. Hegbloom -# Perl Artistic Licence. +# Copyright (c) 2001, 2002 Sam Vilain. All right reserved. This file +# is licensed under the terms of the Perl Artistic license. =head1 NAME @@ -17,104 +10,138 @@ =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 - # 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"); + our $fields => { int => [ qw(foo bar) ], + string => [ qw(baz quux) ] }; - 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; + package main; - my $dbschema = Tangram::Schema->new - ({ classes => [ 'Orange' => $Orange::schema ]}); + my $object = MyObject->new(foo => 2, baz => "hello"); - sub schema { $dbschema }; + print $object->baz(); # prints "hello" - package main; + $object->set_quux("Something"); - # 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); + $object->set_foo("Something"); # dies - not an integer - # OK - my $orange = Orange->new(juiciness => 8); - my $juiciness = $orange->juiciness; # returns 8 +=head1 DESCRIPTION - # a "ref" must be set to a blessed object - my $grower = bless { name => "Joe" }, "Farmer"; - $orange->set_grower ($grower); +Class::Tangram is a tool for defining objects attributes. Simply +define your object's fields/attributes using the same syntax +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 from attribute B (see +L) to either an B of B, or +another B from B to B (or +C). The layout of this structure coincides with the C +portion of a tangram schema (see L). Note: the term +`schema' is used frequently to refer to the C<$fields> structure. - # these are all illegal - eval { $orange->set_juiciness ("Yum"); }; print $@; - eval { $orange->set_segments (31); }; print $@; - eval { $orange->set_grower ("Mr. Nice"); }; print $@; +For example, - # if you prefer - $orange->get( "juiciness" ); - $orange->set( juiciness => 123 ); + package MyObject; + use base qw(Class::Tangram); -=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 or L. + +When the schema for the object is first imported (see L), Class::Tangram defines accessor functions for each of the +attributes defined in the schema. These accessor functions are then +available as C<$object-Efunction> on created objects. By virtue +of inheritance, various other methods are available. -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. +From Class::Tangram 1.12 onwards, no use of perl's C +functionality is used. =cut use strict; use Carp qw(croak cluck); -use vars qw($AUTOLOAD $VERSION); -$VERSION = "1.04"; +use vars qw($VERSION %defaults); -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); @@ -128,20 +155,31 @@ # $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-Enew (attribute1 =E value, attribute2 =E value) -sets up a new object of type Class, with attributes set to the values -supplied. +Sets up a new object of type C, with attributes set to the +values supplied. -Can also be used as an object method, in which case it returns a -B of the object, without any deep copying. +Can also be used as an object method (normal use is as a "class +method"), in which case it returns a B of the object, without +any deep copying. =cut @@ -150,18 +188,19 @@ 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. @@ -171,118 +210,166 @@ else { $self->set (@values); # start with @values + } + + $self->_fill_init_default(); + $self->_check_required(); - # now fill in fields that have defaults - for my $attribute (keys %{$init_defaults{$class}}) { + return $self; + +} - 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} - unless tied $init_defaults{$class}->{$attribute}; + } else { + # something else, an object or a scalar + $self->$setter($default); + } + } +} - 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}; +sub _check_required { + my $self = shift; + my $class = ref $self; + + # make sure field is not undef if 'required' option is set + if (my $required = $required_attributes{$class}) { + + # find the immediate caller outside of this package + my $i = 0; + $i++ while UNIVERSAL::isa($self, scalar(caller($i))||";->"); + + # give Tangram some lenience - it is exempt from the effects + # of the "required" option + unless ( caller($i) =~ m/^Tangram::/ ) { + my @missing; + while ( my ($attribute, $value) = each %$required ) { + push(@missing, $attribute) + if ! exists $self->{$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-Eset_attribute($value)> for +each of the C $value> pairs passed to it. + =cut -sub set($@) { - my ($self, @values) = (@_); +sub set { + 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) { - croak "attempt to set an illegal field $name in a $class" - if (!defined $check{$class}->{$name}); + while (my ($name, $value) = splice @_, 0, 2) { - #local $@; + my $setter = "set_".$name; - # these handlers die on failure - eval { $check{$class}->{$name}->(\$value) }; - $@ && croak ("value failed type check - ${class}->{$name}, " - ."\"$value\" ($@)"); + croak "attempt to set an illegal field $name in a $class" + unless $self->can($setter); - #should be ok now - $self->{$name} = $value; + $self->$setter($value); } } -=item $instance->get($attribute) +=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). +Gets the value of C<$attribute>. This simply calls +C<$instance-Eget_attribute>. If multiple attributes are listed, +then a list of the attribute values is returned in order. Note that +you get back the results of the scalar context C call +in this case. =cut -sub get($$) { - my ($self, $field) = (@_); - $self->isa("Class::Tangram") or croak "type mismatch"; +sub get { + my $self = shift; + 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) { - if (!defined $self->{$field}) { - $self->{$field} = Set::Object->new(); - } - if (wantarray) { - return $self->{$field}->members; + my $multiget = (scalar(@_) != 1); + + my @return; + while ( my $field = shift ) { + my $getter = "get_".$field; + 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 -this is equivalent to $instance->get("attribute") +If C<$value> is not given, then +this is equivalent to C<$instance-Eget_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. +If C<$value> is given, then this is equivalent to +C<$instance-Eset_attribute($value)>. This usage issues a warning +if warnings are on; you should change your code to use the +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 -=> $value), respectively. +The normative way of getting and setting attributes. If you wish to +override the behaviour of an object when getting or setting an +attribute, override these functions. They will be called when you use +C<$instance-Eattribute>, C<$instance-Eget()>, constructors, +etc. =item $instance->attribute_includes(@objects) @@ -294,114 +381,186 @@ =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. +This suite of functions applies to attributes that are sets (C +or C). It could in theory also apply generally to all +collections - ie also arrays (C or C), and hashes +(C, C). This will be implemented subject to user demand. + +=back + +B The above functions can be overridden, but they may not be +called with the C<$self-ESUPER::> superclass chaining method. +This is because they are not defined within the scope of +Class::Tangram, only your package. =cut -sub AUTOLOAD ($;$) { - my ($self, $value) = (@_); - $self->isa("Class::Tangram") or croak "type mismatch"; +=head1 ATTRIBUTE TYPE CHECKING - 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"); - } -} +Class::Tangram provides type checking of attributes when attributes +are set - either using the default C functions, or +created via the C constructor. -=item $instance->getset($attribute, $value) +The checking has default behaviour for each type of attribute (see +L), and can be extended arbitrarily via a +per-attribute C, described below. Critical attributes can +be marked as such with the C flag. -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: +The specification of this type checking is placed in the class schema, +in the per-attribute B. This is a Class::Tangram +extension to the Tangram schema structure. - sub attribute { $_[0]->SUPER::getset("attribute", $_[1]) } +=over -=cut +=item check_func -sub getset($$;$) { - my ($self, $attr, $value) = (@_); - $self->isa("Class::Tangram") or croak "type mismatch"; +A function that is called with a B to the new value in +C<$_[0]>. It should call C if the value is bad. Note that +this check_func will never be passed an undefined value; this is +covered by the "required" option, below. - if (defined $value) { - return set($self, $attr, $value); - } else { - return get($self, $attr); - } +In the example schema (above), the attribute C has a +C that prevents setting the value to anything greater than +30. Note that it does not prevent you from setting the value to +something that is not an integer; if you define a C, 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 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: + +=over + +=item init_default + +This value specifies the default value of the attribute when +it is created with C. 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-Eclear_refs()>), then define this. It is called as +C<$sub-E($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 -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. +This series of internal functions are built-in C functions +defined for all of the standard Tangram attribute types. + +=over -Available functions are: +=item check_string - check_string - checks that the supplied value is less - than 255 characters long. +checks that the supplied value is less 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 - signed) integer +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); + croak "not an integer" + if (${$_[0]} !~ m/$int_re/o); } -=pod +=item check_real - check_real - checks that the value is a real number - (m/^\d*(\.\d*)?(e\d*)?$/) +checks that the value is a real number, by stringifying it and +matching it against (C). Inefficient? +Yes. Patches welcome. =cut my $real_re = qr/^-?\d*(\.\d*)?(e-?\d*)?$/; sub check_real { - croak "not a real" - if (${$_[0]} !~ m/$real_re/ms); + croak "not a real number" + if (${$_[0]} !~ m/$real_re/o); } -=pod +=item check_obj - check_obj - checks that the supplied variable is a - reference to a blessed object +checks that the supplied variable is a reference to a blessed object =cut @@ -409,26 +568,28 @@ 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 +checks that $value is a ref ARRAY and that all elements are unblessed +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 - each element in the array is a reference to - a blessed object. +checks that $value is a ref ARRAY, and that each element in the array +is a reference to a blessed object. =cut @@ -437,68 +598,88 @@ 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 HH:MM:SS +checks that $value is of the form YYYY-MM-DD, or YYYYMMDD, or YYMMDD. =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/); +my $rawdate_re = qr/^(?: \d{4}-\d{2}-\d{2} + | (?:\d\d){3,4} + )$/x; +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})?$/; -sub check_time { - croak "invalid SQL time" - unless (${$_[0]} =~ m/$time_re/); +# YYYY-MM-DD HH:MM:SS +my $rawtime_re = qr/^\d{1,2}:\d{2}(?::\d{2})?$/; +sub check_rawtime { + 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 +14 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 - (YYYY-MM-DD )?HH:MM(:SS)? +checks that $value is of the form YYYYMMDDHH:MM:SS, or those allowed +for rawdatetime. =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/); +sub check_dmdatetime { + croak "invalid SQL rawdatetime dude" + unless (${$_[0]} =~ m/^\d{10}:\d\d:\d\d$|$rawdatetime_re/o); } -=pod +=item check_flat_hash - check_flat_hash - - checks that $value is a ref HASH +checks that $value is a ref HASH and all values are scalars. Does NOT +currently check that all values are of the correct type (int vs real +vs string, etc) =cut @@ -511,11 +692,10 @@ } } -=pod +=item check_hash - 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. +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 @@ -530,14 +710,16 @@ } } -=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 @@ -548,78 +730,71 @@ 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) = (@_); - - # warnings suck sometimes - local $^W = 0; + my $self = shift; + my $attr = shift; 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 - Tangram so that if this ref is not loaded, - it will not be autoloaded when it is - attempted to be accessed. +destroys a reference. =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}; - } + my $self = shift; + delete $self->{shift}; } +=back + =item parse_X ($attribute, { schema option }) Parses the schema option field, and returns one or two closures that @@ -627,19 +802,39 @@ 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. +quickly. This is probably unmanagably unportable across databases; +but send me bug reports on it anyway, and I'll try and make the +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. @@ -647,11 +842,9 @@ 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 @@ -662,251 +855,79 @@ if (length ${$_[0]} > $max_length); }; -=pod +=item TINYBLOB, BLOB, LONGBLOB - TINYBLOB, BLOB, LONGBLOB - TINYTEXT, TEXT, LONGTEXT - checks max. length of string to be 255, - 65535 or 16777215 chars respectively +checks max. length of string to be 255, 65535 or 16777215 chars +respectively. Also works with "TEXT" instead of "BLOB" =cut - } elsif ($option->{sql} =~ m/^\s*(tiny|long|medium)? - (blob|text)/ix) { + } 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); + 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 of the - passed values are allowed to be a member - of that 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; - } + } elsif (my ($members) = $option->{sql} =~ + m/^\s*set\s*$sql_list/oi) { + + my %members; + $members{lc($1 || $2)} = 1 + while ( $members =~ m/\G[,\s]*$quoted_part/cog ); + 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} =~ - 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; - } + } elsif (my ($values) = $option->{sql} =~ + m/^\s*enum\s*$sql_list/oi ) { + + my %values; + $values{lc($1 || $2)} = 1 + while ( $values =~ m/\G[,\s]*$quoted_part/gc); + 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}; - } - } +=back - # ----- 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}; - } - } +=back - # ----- 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; - }; +=back - $@ && die "$@ while trying to import schema for $class"; -} +=head2 Quick Object Dumping and Destruction +=over =item $instance->quickdump @@ -921,7 +942,7 @@ =cut sub quickdump($) { - my ($self) = (@_); + my $self = shift; my $r = "REF ". (ref $self). "\n"; for my $k (sort keys %$self) { @@ -949,7 +970,7 @@ =cut sub DESTROY($) { - my ($self) = (@_); + my $self = shift; my $class = ref $self; @@ -987,8 +1008,7 @@ =cut sub clear_refs($) { - my ($self) = (@_); - + my $self = shift; my $class = ref $self; exists $cleaners{$class} or import_schema($class); @@ -1002,9 +1022,508 @@ $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{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 interface to +B of Class::Tangram. + +Class::Tangram keeps seven internal hashes: + +=over + +=item C<%types> + +C<$types{$class}-E{$attribute}> is the tangram type of each attribute, +ie "ref", "iset", etc. See L. + +=item C<%attribute_options> + +C<$attribute_options{$class}-E{$attribute}> is the options hash +for a given attribute. + +=item C<%required_attributes> + +C<$required_attributes{$class}-E{$attribute}> is the 'required' +option setting for a given attribute. + +=item C<%check> + +C<$check{$class}-E{$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{$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{$class}> is set if the class is abstract + +=item C<%init_defaults> + +C<$init_defaults{$class}-E{$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-Erequired_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-Einit_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 @@ -1013,29 +1532,128 @@ 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 -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 :-}. + Set::Object => 1.02 + Pod::Constants => 0.11 + Test::Simple => 0.18 + Date::Manip => 5.21 -More AUTOLOAD methods, in particular for container types such as -array, hash, etc. +Test::Simple and Date::Manip are only required to run the test suite. -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 -$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. +standard function called C, which replaces references +to $obj with the appropriate C object so that an +object can be unloaded via Cunload()> and actually +have a hope of being reclaimed. Another function that would be handy +would be a deep "mark" operation for manual mark & sweep garbage +collection. + +Need to think about writing some functions using C for speed. +One of these days... + +Allow C values to be set in a default import function? + +ie + + use MyClassTangramObject -defaults => { foo => "bar" }; =head1 AUTHOR Sam Vilain, +=head2 CREDITS + + # Some modifications + # Copyright 2001 Micro Sharp Technologies, Inc., Vancouver, WA, USA + # Author: Karl M. Hegbloom + # Perl Artistic Licence. + +Many thanks to Charles Owens and David Wheeler for their feedback, +ideas, patches and bug testing. + =cut 69; + +__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)) } );