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.5 2001/10/10 17:41:00 sv Exp $ # Copyright © 2001 Micro Sharp Technologies, Inc., Vancouver, WA, USA # Author: Karl M. Hegbloom <karlheg@microsharp.com> # Perl Artistic Licence. =head1 NAME Class::Tangram - create constructors, accessor and update methods for objects from a Tangram-compatible object specification. =head1 SYNOPSIS package Orange; use base qw(Class::Tangram); use vars qw($schema); use Tangram::Ref; # define the schema (ie, allowed attributes) of this object. See the # Tangram::Schema man page for more information on the syntax here. $schema = { table => "oranges", fields => { int => { juiciness => undef, segments => { # here is a new one - this code reference is called # when this attribute is set; it should die() on # error, as it is wrapped in an eval { } block check_func => sub { die "too many segments" if ($ {$_[0]} > 30); }, # the default for this attribute. init_default => 7, }, }, ref => { grower => undef, }, }, }; Class::Tangram::import_schema("Orange"); package Project; # here's where we build the individual object schemas into a # Tangram::Schema object, which the Tangram::Storage class uses to # know which tables and columns to find objects. use Tangram::Schema; my $dbschema = Tangram::Schema->new ({ classes => [ 'Orange' => $Orange::schema ]}); sub schema { $dbschema }; package main; # See Tangram::Relational for instructions on using "deploy" to # create the database this connects to. You only have to do this if # you want to write the objects to a database. use Tangram::Relational; my ($dsn, $u, $p); my $storage = Tangram::Relational->connect(Project->schema, $dsn, $u, $p); # OK my $orange = Orange->new(juiciness => 8); my $juiciness = $orange->juiciness; # returns 8 # a "ref" must be set to a blessed object my $grower = bless { name => "Joe" }, "Farmer"; $orange->set_grower ($grower); # these are all illegal eval { $orange->set_juiciness ("Yum"); }; print $@; eval { $orange->set_segments (31); }; print $@; eval { $orange->set_grower ("Mr. Nice"); }; print $@; # if you prefer $orange->get( "juiciness" ); $orange->set( juiciness => 123 ); =head1 DESCRIPTION Class::Tangram is a base class originally intended for use with Tangram objects, that gives you free constructors, access methods, update methods, and a destructor that should help in breaking circular references for you. Type checking is achieved by parsing the schema for the object, which is contained within the object class in an exported variable C<$schema>. After writing this I found that it was useful for merely adding type checking and validation to arbitrary objects. There are several modules on CPAN to do that already, but many don't have finely grained type checking, and none of them integrated with Tangram. =cut use strict; use Carp qw(croak cluck); use vars qw($AUTOLOAD $VERSION); $VERSION = "1.04"; local $AUTOLOAD; # $types{$class}->{$attribute} is the tangram type of each attribute my (%types); # $check{$class}->{$attribute}->($value) is a function that will die # if $value is not alright, see check_X functions my (%check); # Destructors for each attribute. They are called as # $cleaners{$class}->{$attribute}->($self, $attribute); my (%cleaners); # init_default values for each attribute. These could be hash refs, # array refs, code refs, or simple scalars. They will be stored as # $init_defaults{$class}->{$attribute} my (%init_defaults); # if a class is abstract, complain if one is constructed. my (%abstract); =head1 METHODS =over 4 =item Class-E<gt>new (attribute1 =E<gt> value, attribute2 =E<gt> value +) sets up a new object of type Class, with attributes set to the values supplied. Can also be used as an object method, in which case it returns a B<copy> of the object, without any deep copying. =cut sub new ($@) { my $invocant = shift; my $class = ref $invocant || $invocant; my @values = @_; # Setup the object my $self = { }; bless $self, $class; exists $check{$class} or import_schema($class); croak "Attempt to instantiate an abstract type" if ($abstract{$class}); if ($invocant ne $class) { # The copy constructor; this could be better :) # this has the side effect of much auto-vivification. %$self = %$invocant; $self->set (@values); # override with @values } else { $self->set (@values); # start with @values # now fill in fields that have defaults for my $attribute (keys %{$init_defaults{$class}}) { next if (exists $self->{$attribute}); my $default = $init_defaults{$class}->{$attribute} unless tied $init_defaults{$class}->{$attribute}; if (ref $default eq "CODE") { # sub { }, attribute gets return value $self->{$attribute} = $init_defaults{$class}->{$attribute}->(); } elsif (ref $default eq "HASH") { # hash ref, copy hash $self->{$attribute} = { %{ $init_defaults{$class}->{$attribute} } }; } elsif (ref $default eq "ARRAY") { # array ref, copy array $self->{$attribute} = [ @{ $init_defaults{$class}->{$attribute} } ]; } else { # something else, an object or a scalar $self->{$attribute} = $init_defaults{$class}->{$attribute}; } } } return $self; } =item $instance->set(attribute => $value, ...) Sets the attributes of the given instance to the given values. croaks if there is a problem with the values. =cut sub set($@) { my ($self, @values) = (@_); # yes, this is a lot to do. yes, it's slow. But I'm fairly # certain that this could be handled efficiently if it were to be # moved inside the Perl interpreter or an XS module $self->isa("Class::Tangram") or croak "type mismatch"; my $class = ref $self; exists $check{$class} or import_schema($class); while (my ($name, $value) = splice @values, 0, 2) { croak "attempt to set an illegal field $name in a $class" if (!defined $check{$class}->{$name}); #local $@; # these handlers die on failure eval { $check{$class}->{$name}->(\$value) }; $@ && croak ("value failed type check - ${class}->{$name}, " ."\"$value\" ($@)"); #should be ok now $self->{$name} = $value; } } =item $instance->get($attribute) Gets the value of $attribute. If the attribute in question is a set, and this method is called in list context, then it returns the MEMBERS of the set (if called in scalar context, it returns the Set::Object container). =cut sub get($$) { my ($self, $field) = (@_); $self->isa("Class::Tangram") or croak "type mismatch"; my $class = ref $self; exists $check{$class} or import_schema($class); croak "attempt to read an illegal field $field in a $class" if (!defined $check{$class}->{$field}); if ($types{$class}->{$field} =~ m/^i?set$/o) { if (!defined $self->{$field}) { $self->{$field} = Set::Object->new(); } if (wantarray) { return $self->{$field}->members; } } return $self->{$field}; } =item $instance->attribute($value) If $value is not given, then this is equivalent to $instance->get("attribute") If $value is given, then this is equivalent to $instance->set("attribute", $value). This usage issues a warning; you should change your code to use the set_attribute syntax for better readability. =item $instance->get_attribute =item $instance->set_attribute($value) Equivalent to $instance->get("attribute") and $instance->set(attribute => $value), respectively. =item $instance->attribute_includes(@objects) =item $instance->attribute_insert(@objects) =item $instance->attribute_size =item $instance->attribute_clear =item $instance->attribute_remove(@objects) Equivalent to calling $instance->attribute->includes(@objects), etc. This only works if the attribute in question is a Set::Object. =cut sub AUTOLOAD ($;$) { my ($self, $value) = (@_); $self->isa("Class::Tangram") or croak "type mismatch"; my $class = ref $self; $AUTOLOAD =~ s/.*://; if ($AUTOLOAD =~ m/^(set_|get_)?([^:]+)$/ and defined $types{$class}->{$2}) { # perl sucks at this type of test if ((defined $1 and $1 eq "set_") or (!defined $1 and defined $value)) { if ($^W && !defined $1) { cluck("The OO police say change your call to " ."\$obj->set_$2"); } return set($self, $2, $value); } else { return get($self, $2); } } elsif (my ($attr, $method) = ($AUTOLOAD =~ m/^(.*)_(includes|insert| size|clear|remove)$/x) and $types{$class}->{$1} =~ m/^i?set$/) { return get($self, $attr)->$method(@_[1..$#_]); } else { croak("unknown method/attribute ${class}->$AUTOLOAD called"); } } =item $instance->getset($attribute, $value) If you're replacing the AUTOLOAD function in your Class::Tangram derived class, but would still like to use the behaviour for one or two fields, then you can define functions for them to fall through to the Class::Tangram method, like so: sub attribute { $_[0]->SUPER::getset("attribute", $_[1]) } =cut sub getset($$;$) { my ($self, $attr, $value) = (@_); $self->isa("Class::Tangram") or croak "type mismatch"; if (defined $value) { return set($self, $attr, $value); } else { return get($self, $attr); } } =item check_X (\$value) This series of functions checks that $value is of the type X, and within applicable bounds. If there is a problem, then it will croak() the error. These functions are not called from the code, but by the set() method on a particular attribute. Available functions are: check_string - checks that the supplied value is less than 255 characters long. =cut sub check_string { croak "string ${$_[0]} too long" if (length ${$_[0]} > 255); } =pod check_int - checks that the value is a (possibly signed) integer =cut my $int_re = qr/^-?\d+$/; sub check_int { croak "not an int" if (${$_[0]} !~ m/$int_re/ms); } =pod check_real - checks that the value is a real number (m/^\d*(\.\d*)?(e\d*)?$/) =cut my $real_re = qr/^-?\d*(\.\d*)?(e-?\d*)?$/; sub check_real { croak "not a real" if (${$_[0]} !~ m/$real_re/ms); } =pod check_obj - checks that the supplied variable is a reference to a blessed object =cut # this pattern matches a regular reference my $obj_re = qr/^(?:HASH|ARRAY|SCALAR)?$/; sub check_obj { croak "not an object reference" if ((ref ${$_[0]}) =~ m/$obj_re/); } =pod check_flat_array - checks that $value is a ref ARRAY =cut sub check_flat_array { croak "not a flat array" if (ref ${$_[0]} ne "ARRAY"); } =pod check_array - checks that $value is a ref ARRAY, and that each element in the array is a reference to a blessed object. =cut sub check_array { croak "array attribute not passed an array ref" if (ref ${$_[0]} ne "ARRAY"); for my $a (@{${$_[0]}}) { croak "member in array not an object reference" if ((ref $a) =~ m/$obj_re/); } } =pod check_set - checks that $value->isa("Set::Object") =cut sub check_set { croak "set type not passed a Set::Object" unless (ref ${$_[0]} and ${$_[0]}->isa("Set::Object")); } =pod check_rawdatetime - checks that $value is of the form YYYY-MM-DD HH:MM:SS =cut # YYYY-MM-DD HH:MM:SS my $rawdatetime_re = qr/^\d{4}-\d{2}-\d{2}\s+\d{1,2}:\d{2}:\d{2}$/; sub check_rawdatetime { croak "invalid SQL rawdatetime" unless (${$_[0]} =~ m/$rawdatetime_re/); } =pod check_time - checks that $value is of the form HH:MM(:SS)? =cut my $time_re = qr/^\d{1,2}:\d{2}(?::\d{2})?$/; sub check_time { croak "invalid SQL time" unless (${$_[0]} =~ m/$time_re/); } =pod check_timestamp - checks that $value is of the form (YYYY-MM-DD )?HH:MM(:SS)? =cut my $timestamp_re = qr/^(?:\d{4}-\d{2}-\d{2}\s+)?\d{1,2}:\d{2}(?::\d{2} +)?$/; sub check_timestamp { croak "invalid SQL timestamp" unless (${$_[0]} =~ m/$timestamp_re/); } =pod check_flat_hash - checks that $value is a ref HASH =cut sub check_flat_hash { croak "not a hash" unless (ref ${$_[0]} eq "HASH"); while (my ($k, $v) = each %${$_[0]}) { croak "hash not flat" if (ref $k or ref $v); } } =pod check_hash - checks that $value is a ref HASH, that every key in the hash is a scalar, and that every value is a blessed object. =cut sub check_hash { croak "not a hash" unless (ref ${$_[0]} eq "HASH"); while (my ($k, $v) = each %${$_[0]}) { croak "hash key not flat" if (ref $k); croak "hash value not an object" if (ref $v !~ m/$obj_re/); } } =pod check_nothing - checks whether Australians like sport =cut sub check_nothing { } =item destroy_X ($instance, $attr) Similar story with the check_X series of functions, these are called during object destruction on every attribute that has a reference that might need breaking. Note: B<these functions all assume that attributes belonging to an object that is being destroyed may be destroyed also>. In other words, do not allow distinct objects to share Set::Object containers or hash references in their attributes, otherwise when one gets destroyed the others will lose their data. Available functions are: destroy_array - empties an array =cut sub destroy_array { my ($self, $attr) = (@_); my $t = tied $self->{$attr}; @{$self->{$attr}} = () unless ($t =~ m,Tangram::CollOnDemand,); delete $self->{$attr}; } =pod destroy_set - calls Set::Object::clear to clear the set =cut sub destroy_set { my ($self, $attr) = (@_); # warnings suck sometimes local $^W = 0; my $t = tied $self->{$attr}; return if ($t =~ m,Tangram::CollOnDemand,); if (ref $self->{$attr} eq "Set::Object") { $self->{$attr}->clear; } delete $self->{$attr}; } =pod destroy_hash - empties a hash =cut sub destroy_hash { my ($self, $attr) = (@_); my $t = tied $self->{$attr}; %{$self->{$attr}} = () unless ($t =~ m,Tangram::CollOnDemand,); delete $self->{$attr}; } =pod destroy_ref - destroys a reference. Contains a hack for Tangram so that if this ref is not loaded, it will not be autoloaded when it is attempted to be accessed. =cut sub destroy_ref { my ($self, $attr) = (@_); # warnings suck sometimes local $^W = 0; # the only reason I bother with all of this is that I experienced # Perl did not always call an object's destructor if you just used # delete. my $t = tied $self->{$attr}; if (defined $t and $t =~ m/OnDemand/) { delete $self->{$attr}; } else { my $ref = delete $self->{$attr}; } } =item parse_X ($attribute, { schema option }) Parses the schema option field, and returns one or two closures that act as a check_X and a destroy_X function for the attribute. This is currently a very ugly hack, parsing the SQL type definition of an object. But it was bloody handy in my case for hacking this in quickly. This is unmanagably unportable across databases. This should be replaced by primitives that go the other way, building the SQL type definition from a more abstract definition of the type. Available functions: parse_string - parses SQL types of: =cut sub parse_string { my ($attribute, $option) = (@_); # simple case; return the check_string function. We don't # need a destructor for a string so don't return one. if (!$option->{sql}) { return \&check_string; } =pod CHAR(N), VARCHAR(N) closure checks length of string is less than N characters =cut if ($option->{sql} =~ m/^\s*(?:var)?char\s*\(\s*(\d+)\s*\)/ix) { my $max_length = $1; return sub { die "string too long for $attribute" if (length ${$_[0]} > $max_length); }; =pod TINYBLOB, BLOB, LONGBLOB TINYTEXT, TEXT, LONGTEXT checks max. length of string to be 255, 65535 or 16777215 chars respectively =cut } elsif ($option->{sql} =~ m/^\s*(tiny|long|medium)? (blob|text)/ix) { my $max_length = ($1 ? ($1 eq "tiny"?255:2**24 - 1) : 2**16 - 1); return sub { die "string too long for $attribute" if (length ${$_[0]} > $max_length); }; =pod SET("members", "of", "set") checks that the value passed is valid as a SQL set type, and that all of the passed values are allowed to be a member of that set =cut } elsif ($option->{sql} =~ m/^\s*set\s*\( (\"[^\"]+\" (?:\s*,\s*\"[^\"]+\")* \s* ) \)\s*$/xi) { my $members = $1; my ($member, %members); while (($member, $members) = ($members =~ m/^[,\s]*\"([^\"]+)\"(.*)$/)) { $members{lc($member)} = 1; } return sub { for my $x (split /,/, ${$_[0]}) { croak ("SQL set badly formed or invalid member $x " ." (SET" . join(",", keys %members). ")") if (not exists $members{lc($x)}); } }; =pod ENUM("possible", "values") checks that the value passed is one of the allowed values. =cut } elsif ($option->{sql} =~ m/^\s*enum\s*\( (\"[^\"]+\" (?:\s*,\s*\"[^\"]+\")* \s* ) \)\s*/xi) { my $values = $1; my ($value, %values); while (($value, $values) = ($values =~ m/^[,\s]*\"([^\"]+)\"(.*)$/)) { $values{lc($value)} = 1; } return sub { croak ("invalid enum value ${$_[0]} must be (" . join(",", keys %values). ")") if (not exists $values{lc(${$_[0]})}); } } else { die ("Please build support for your string SQL type in " ."Class::Tangram (".$option->{sql}.")"); } } # Here is where I map Tangram::Type types to functions. # Format: # type => { # check => \&check_X # parse => \&parse_type # destroy => \&destroy_X # } # my %defaults = ( int => { check => \&check_int }, real => { check => \&check_real }, string => { parse => \&parse_string }, ref => { check => \&check_obj, destroy => \&destroy_r +ef }, array => { check => \&check_array, destroy => \&destroy_a +rray }, iarray => { check => \&check_array, destroy => \&destroy_a +rray }, flat_array => { check => \&check_flat_array }, set => { check => \&check_set, destroy => \&destroy_s +et }, iset => { check => \&check_set, destroy => \&destroy_s +et }, rawdatetime => { check => \&check_rawdatetime }, time => { check => \&check_time }, timestamp => { check => \&check_timestamp }, flat_hash => { check => \&check_flat_hash }, hash => { check => \&check_hash, destroy => \&destroy_h +ash }, perl_dump => { check => \&check_nothing } ); =item import_schema($class) Parses a tangram object schema, in "\$${class}::schema" to the internal representation used to check types values by set(). Called automatically on the first get(), set(), or new() for an object of a given class. This function updates Tangram schema option hashes, with the following keys: check_func - supply/override the check_X function for this attribute. destroy_func - supply/override the destroy_X function for this attribute See the SYNOPSIS section for an example of supplying a check_func in an object schema. =cut sub import_schema($) { my ($class) = (@_); eval { my ($fields, $bases, $abstract); { no strict 'refs'; $fields = ${"${class}::schema"}->{fields}; $bases = ${"${class}::schema"}->{bases}; $abstract = ${"${class}::schema"}->{abstract}; } my $check_class = { }; my $cleaners_class = { }; my $init_defaults_class = { }; my $types_class = { }; # if this is an abstract type, do not allow it to be # instantiated if ($abstract) { $abstract{$class} = 1; } # If there are any base classes, import them first so that the # check, cleaners and init_defaults can be inherited if (defined $bases) { (ref $bases eq "ARRAY") or die "bases not an array ref for $class"; # Note that the order of your bases is significant, that # is if you are using multiple iheritance then the later # classes override the earlier ones. #for my $super ( Class::ISA::super_path($class) ) { for my $super ( @$bases ) { import_schema $super unless (exists $check{$super}); # copy each of the per-class configuration hashes to # this class as defaults. my ($k, $v); $types_class->{$k} = $v while (($k, $v) = each %{ $types{$super} } ); $check_class->{$k} = $v while (($k, $v) = each %{ $check{$super} } ); $cleaners_class->{$k} = $v while (($k, $v) = each %{ $cleaners{$super} } ); $init_defaults_class->{$k} = $v while (($k, $v) = each %{ $init_defaults{$super} } ); } } # iterate over each of the *types* of fields (string, int, ref, etc.) while (my ($type, $v) = each %$fields) { if (ref $v eq "ARRAY") { $v = { map { $_, undef } @$v }; } my $def = $defaults{$type}; # iterate each of the *attributes* of a particular type while (my ($attribute, $option) = each %$v) { $types_class->{$attribute} = $type; # ----- check_X functions ---- if (ref $option eq "HASH" and $option->{check_func}) { # user-supplied check_X function $check_class->{$attribute} = $option->{check_func}; } else { if (not defined $def) { die "No default check function for type $type"; } # check for a type-specific option hash parser if ($def->{parse}) { my ($check, $destroy) = $def->{parse}->($attribute, $option); $check_class->{$attribute} = $check; $cleaners_class->{$attribute} = $destroy if (defined $destroy); } else { # use the default for this type $check_class->{$attribute} = $def->{check}; } } # ----- destroy_X functions if (ref $option eq "HASH" and $option->{destroy_func}) { # user-supplied destroy_X function $cleaners_class->{$attribute} = $option->{destroy_func}; } else { if ($def->{destroy}) { # use the default for this type $cleaners_class->{$attribute} = $def->{destroy}; } } # ----- init_default functions # create empty Set::Object containers as necessary if ($type =~ m/^i?set$/) { $init_defaults_class->{$attribute} = sub { Set::Object->new() }; } if (ref $option eq "HASH" and $option->{init_default}) { $init_defaults_class->{$attribute} = $option->{init_default}; } } } $types{$class} = $types_class; $check{$class} = $check_class; $cleaners{$class} = $cleaners_class; $init_defaults{$class} = $init_defaults_class; }; $@ && die "$@ while trying to import schema for $class"; } =item $instance->quickdump Quickly show the blessed hash of an object, without descending into it. Primarily useful when you have a large interconnected graph of objects so don't want to use the B<x> command within the debugger. It also doesn't have the side effect of auto-vivifying members. This function returns a string, suitable for print()ing. It does not currently escape unprintable characters. =cut sub quickdump($) { my ($self) = (@_); my $r = "REF ". (ref $self). "\n"; for my $k (sort keys %$self) { $r .= (" $k => " . ( tied $self->{$k} || ( ref $self->{$k} ? $self->{$k} : "'".$self->{$k}."'" ) ) . "\n"); } return $r; } =item $instance->DESTROY This function ensures that all of your attributes have their destructors called. It calls the destroy_X function for attributes that have it defined, if that attribute exists in the instance that we are destroying. It calls the destroy_X functions as destroy_X($self, $k) =cut sub DESTROY($) { my ($self) = (@_); my $class = ref $self; # if no cleaners are known for this class, it hasn't been imported # yet. Don't call import_schema, that would be a bad idea in a # destructor. exists $cleaners{$class} or return; # for every attribute that is defined, and has a cleaner function, # call the cleaner function. for my $k (keys %$self) { if (defined $cleaners{$class}->{$k} and exists $self->{$k}) { $cleaners{$class}->{$k}->($self, $k); } } $self->{_DESTROYED} = 1; } =item $instance->clear_refs This clears all references from this object, ie exactly what DESTROY normally does, but calling an object's destructor method directly is bad form. Also, this function has no qualms with loading the class' schema with import_schema() as needed. This is useful for breaking circular references, if you know you are no longer going to be using an object then you can call this method, which in many cases will end up cleaning up most of the objects you want to get rid of. However, it still won't do anything about Tangram's internal reference to the object, which must still be explicitly unlinked with the Tangram::Storage->unload method. =cut sub clear_refs($) { my ($self) = (@_); my $class = ref $self; exists $cleaners{$class} or import_schema($class); # break all ref's, sets, arrays for my $k (keys %$self) { if (defined $cleaners{$class}->{$k} and exists $self->{$k}) { $cleaners{$class}->{$k}->($self, $k); } } $self->{_NOREFS} = 1; } =back =head1 SEE ALSO L<Tangram::Schema> B<A guided tour of Tangram, by Sound Object Logic.> http://www.soundobjectlogic.com/tangram/guided_tour/fs.html =head1 BUGS/TODO More datetime types. I originally avoided the DMDateTime type because Date::Manip is self-admittedly the most bloated module on CPAN, and I didn't want to be seen encouraging it. Then I found out about autosplit :-}. More AUTOLOAD methods, in particular for container types such as array, hash, etc. This documentation should be easy enough for a fool to understand. There should be more functions for breaking loops; in particular, a standard function called drop_refs($obj), which replaces references to $obj with the appropriate Tangram::RefOnDemand so that an object can be unloaded via Tangram::Storage->unload() and actually have a hope of being reclaimed. Another function that would be handy would be a deep "mark" operation for mark & sweep garbage collection. =head1 AUTHOR Sam Vilain, <sam@vilain.net> =cut 69;
In reply to Class::Tangram by mugwumpjism
| For: | Use: | ||
| & | & | ||
| < | < | ||
| > | > | ||
| [ | [ | ||
| ] | ] |