Tangram-2.10/0000755000175000017500000000000010412420117011513 5ustar samvsamvTangram-2.10/t/0000755000175000017500000000000010412420117011756 5ustar samvsamvTangram-2.10/t/rt/0000755000175000017500000000000010412420117012403 5ustar samvsamvTangram-2.10/t/rt/RT.pm0000644000175000017500000002541310412412630013274 0ustar samvsamv # an example schema, modeled after Request Tracker. package RT; BEGIN { use base qw(Exporter); our @EXPORT_OK = qw($schema); } our $schema = { sql => { type_col => "t2_type", }, classes => [ RT::Attachment => { fields => { # back-refs: Transaction iset => { Children => { class => "RT::Attachment", back => "Parent", aggreg => 1, }, }, string => { MessageId => { sql => "varchar(160)" }, Subject => { sql => "varchar(255)" }, Filename => { sql => "varchar(255)" }, ContentType => { sql => "varchar(80)" }, ContentEncoding => { sql => "varchar(80)" }, Content => { sql => "LONGTEXT" }, Headers => { sql => "LONGTEXT" }, }, ref => { Creator => undef, }, dmdatetime => [ qw(Created) ], }, }, RT::Queue => { fields => { string => { Name => { sql => "varchar(200)" }, Description => { sql => "varchar(255)" }, CorrespondAddress => { sql => "varchar(120)" }, CommentAddress => { sql => "varchar(120)" }, }, int => [ qw(InitialPriority FinalPriority DefaultDueIn Disabled) ], ref => { LastUpdatedBy => undef, Creator => undef, }, # FIXME - need an on-demand loader that can load partial # contents of containers, this mapping is awful. # In reality, you would never actually load relationships # like "Tickets", you'd use the relationship to query. iset => { Scrips => { class => "RT::Scrip", aggreg => 1, back => "Queue", }, Tickets => { class => "RT::Ticket", aggreg => 1, back => "Queue", }, Templates => { class => "RT::Template", aggreg => 1, back => "Queue", }, }, iarray => { CustomFields => { class => "RT::CustomField", aggreg => 1, back => "Queue", }, }, dmdatetime => [ qw(Created LastUpdated) ], }, }, RT::Link => { fields => { string => { Base => { sql => "varchar(240)" }, Target => { sql => "varchar(240)" }, Type => { sql => "varchar(20)" }, }, int => [ # FIXME - are these links? qw(LocalTarget LocalBase) ], ref => { LastUpdatedBy => undef, }, dmdatetime => [ qw(Created LastUpdated) ], }, }, RT::Principal => { fields => { string => { PrincipalType => { sql => "varchar(16)" }, }, ref => { # to users or groups, depending ObjectId => undef, }, iset => { ACLs => { class => "RT::ACL", aggreg => 1, back => "Principal", }, }, int => [ qw(Disabled) ], }, }, RT::Group => { fields => { string => { Name => { sql => "varchar(200)" }, Description => { sql => "varchar(255)" }, Domain => { sql => "varchar(64)" }, Type => { sql => "varchar(64)" }, }, # FIXME - is this actually a ref? int => [ qw(Instance) ], set => { Members => { class => "RT::User", table => "GroupMembers", }, }, }, }, RT::ScripCondition => { fields => { string => { Name => { sql => "varchar(200)" }, Description => { sql => "varchar(255)" }, ExecModule => { sql => "varchar(60)" }, Argument => { sql => "varchar(255)" }, ApplicableTransTypes => { sql => "varchar(60)" }, }, ref => { LastUpdatedBy => undef, Creator => undef, }, dmdatetime => [ qw(Created LastUpdated) ], }, }, RT::Transaction => { fields => { #back-refs: Ticket ref => { EffectiveTicket => undef, Creator => undef, }, int => { TimeTaken => undef, }, string => { Type => { sql => "varchar(20)" }, Field => { sql => "varchar(40)" }, OldValue => { sql => "varchar(255)" }, NewValue => { sql => "varchar(255)" }, Data => { sql => "varchar(255)" }, }, dmdatetime => [ qw(Created) ], iset => { Attachments => { class => "RT::Attachment", back => "Transaction", aggreg => 1, }, }, }, }, RT::Scrip => { fields => {#back-refs: Queue string => { Description => { sql => "varchar(255)" }, Stage => { sql => "varchar(32)" }, ConditionRules => { sql => "text" }, ActionRules => { sql => "text" }, CustomIsApplicableCode => { sql => "text" }, CustomPrepareCode => { sql => "text" }, CustomCommitCode => { sql => "text" }, }, ref => { Template => undef, LastUpdatedBy => undef, Creator => undef, ScripCondition => undef, ScripAction => undef, }, dmdatetime => [ qw(Created LastUpdated) ], }, }, RT::ACL => { fields => {#back-refs: Principal string => { #"User" "Group", "Owner", "Cc" "AdminCc", # "Requestor", "Requestor" PrincipalType => { sql => "varchar(25)" }, RightName => { sql => "varchar(25)" }, # FIXME - probably unnecessary ObjectType => { sql => "varchar(25)" }, }, ref => { Object => undef, # Principal with a user DelegatedBy => undef, # another ACL DelegatedFrom => undef, }, }, }, # this table represents a de-normalisation of a tree. Because # trees just aren't normal. RT::CachedGroupMember => { fields => { ref => { Group => undef, # RT::Principal Member => undef, # RT::Principal Via => undef, # RT::CachedGroupMember # RT::Prinicpal # this points to the group that the member is # a member of, for ease of deletes. ImmediateParent => undef, }, int => { #if this cached group member is a member of this # group by way of a disabled group or this group is # disabled, this will be set to 1 this allows us to # not find members of disabled subgroups when # listing off group members recursively. Also, # this allows us to have the ACL system elide # members of disabled groups Disabled => undef, }, }, }, RT::User => { fields => { string => { Name => { sql => "varchar(200)" }, Password => { sql => "varchar(40)" }, Comments => { sql => "BLOB" }, Signature => { sql => "BLOB" }, EmailAddress => { sql => "varchar(120)" }, FreeformContactInfo => { sql => "BLOB" }, Organization => { sql => "varchar(200)" }, RealName => { sql => "varchar(120)" }, NickName => { sql => "varchar(16)" }, Lang => { sql => "varchar(16)" }, EmailEncoding => { sql => "varchar(16)" }, WebEncoding => { sql => "varchar(16)" }, ExternalContactInfoId => { sql => "varchar(100)" }, ContactInfoSystem => { sql => "varchar(30)" }, ContactInfoSystem => { sql => "varchar(30)" }, ExternalAuthId => { sql => "varchar(100)" }, AuthSystem => { sql => "varchar(30)" }, Gecos => { sql => "varchar(16)" }, HomePhone => { sql => "varchar(30)" }, WorkPhone => { sql => "varchar(30)" }, MobilePhone => { sql => "varchar(30)" }, PagerPhone => { sql => "varchar(30)" }, Address1 => { sql => "varchar(200)" }, Address2 => { sql => "varchar(200)" }, City => { sql => "varchar(100)" }, State => { sql => "varchar(100)" }, Zip => { sql => "varchar(16)" }, Country => { sql => "varchar(50)" }, Timezone => { sql => "varchar(50)" }, PGPKey => { sql => "TEXT" }, }, ref => { LastUpdatedBy => undef, Creator => undef, }, dmdatetime => [ qw(Created LastUpdated) ], }, }, RT::Ticket => { fields => { #backrefs: Queue int => [ qw(EffectiveId IssueStatement Resolution InitialPriority FinalPriority Priority TimeEstimated TimeWorked TimeLeft Disabled ) ], string => { Type => { sql => "varchar(16)" }, Subject => { sql => "varchar(200)" }, Status => { sql => "varchar(10)" }, }, dmdatetime => [ qw(Told Starts Started Due Resolved) ], ref => { Owner => undef, LastUpdatedBy => undef, Creator => undef, }, dmdatetime => [ qw(Created LastUpdated) ], }, }, # RT::ScripAction => { fields => { string => { Name => { sql => "varchar(200)" }, Description => { sql => "varchar(255)" }, ExecModule => { sql => "varchar(60)" }, Argument => { sql => "varchar(255)" }, }, ref => { LastUpdatedBy => undef, Creator => undef, }, dmdatetime => [ qw(Created LastUpdated) ], }, }, # RT::Template => { fields => { #backrefs: Queue string => { Name => { sql => "varchar(200)" }, Description => { sql => "varchar(255)" }, Type => { sql => "varchar(16)" }, Language => { sql => "varchar(16)" }, Content => { sql => "BLOB" }, }, iset => { Translations => { class => "RT::Template", #aggreg => 1, back => "TranslationOf", }, }, ref => { LastUpdatedBy => undef, Creator => undef, }, dmdatetime => [ qw(Created LastUpdated) ], }, }, # RT::TicketCustomFieldValue => { fields => { # backrefs: Ticket string => { Name => { Content => "varchar(255)" } }, ref => { CustomField => undef, LastUpdatedBy => undef, Creator => undef, }, dmdatetime => [ qw(Created LastUpdated) ], }, }, # RT::CustomField => { fields => { # backrefs: Queue string => { Name => { sql => "varchar(200)" }, Description => { sql => "varchar(255)" }, Type => { sql => "varchar(200)" }, Language => { sql => "varchar(16)" }, Content => { sql => "BLOB" }, }, ref => { LastUpdatedBy => undef, Creator => undef, }, dmdatetime => [ qw(Created LastUpdated) ], int => [ qw(Disabled) ], iarray => { Values => { class => "RT::CustomFieldValue", back => "CustomField", aggreg => 1, }, }, }, }, # RT::CustomFieldValue => { fields => { # backrefs: CustomField string => { Name => { sql => "varchar(200)" }, Description => { sql => "varchar(255)" }, }, ref => { LastUpdatedBy => undef, Creator => undef, }, dmdatetime => [ qw(Created LastUpdated) ], }, }, # RT::Attribute => { fields => { string => { Name => { sql => "varchar(255)" }, Description => { sql => "varchar(255)" }, Content => { sql => "TEXT" }, ContentType => { sql => "varchar(16)" }, # FIXME - not necessary? ObjectType => { sql => "varchar(64)" }, }, ref => { LastUpdatedBy => undef, Creator => undef, Object => undef, }, dmdatetime => [ qw(Created LastUpdated) ], }, }, RT::Session => { fields => { ref => { LoggedInUser => undef, }, idbif => { -poof => # there goes another one! }, dmdatetime => { LastUpdated => { sql => "TIMESTAMP" } }, }, }, ], }; 1; Tangram-2.10/t/rt/RT.pod0000644000175000017500000003346310412412630013446 0ustar samvsamv=head1 NAME t/eg/RT.pm - example schema, based on Request Tracker =head1 SYNOPSIS use RT qw($schema); use Tangram; my $storage = Tangram::Storage->connect (Tangram::Schema->new($schema), $dsn, $u, $p, ); =head1 DESCRIPTION This package is a re-modelling of the Request Tracker 3.0.9 database schema to Tangram. See the F file in the distribution for more information. =head2 Request Tracker Request Tracker is a trouble ticketing system. See L for more. The site, L, runs on RT. Request Tracker, as an application, is a Mason application written using an abstraction library called L. =head1 METHOD The method for this is fairly simple, once you know how Tangram maps classes to tables. Interested readers are urged to first read L. First, The MySQL schema was manually converted to a Tangram schema, table by table. This process took about 60-90 minutes. Where possible, obvious foreign key relationships and foreign key with `SortOrder' columns were converted to Tangram::IntrSet and Tangram::IntrArray relationship, respectively. One table, GroupMembers, was done away with entirely. In several places, there is use of a "Type" column. It is suspected that this often could have been done away with - as all L fields by default can point to any class, this sort of carry-on is seldom necessary. =head1 APPENDICES =head2 Appendix A - RT database schema The following SQL file was used for the conversion, and # {{{ Attachments CREATE TABLE Attachments ( id INTEGER NOT NULL AUTO_INCREMENT, TransactionId integer NOT NULL , Parent integer NOT NULL DEFAULT 0 , MessageId varchar(160) NULL , Subject varchar(255) NULL , Filename varchar(255) NULL , ContentType varchar(80) NULL , ContentEncoding varchar(80) NULL , Content LONGTEXT NULL , Headers LONGTEXT NULL , Creator integer NOT NULL DEFAULT 0 , Created DATETIME NULL , PRIMARY KEY (id) ) TYPE=InnoDB; CREATE INDEX Attachments2 ON Attachments (TransactionId) ; CREATE INDEX Attachments3 ON Attachments (Parent, TransactionId) ; # }}} # {{{ Queues CREATE TABLE Queues ( id INTEGER NOT NULL AUTO_INCREMENT, Name varchar(200) NOT NULL , Description varchar(255) NULL , CorrespondAddress varchar(120) NULL , CommentAddress varchar(120) NULL , InitialPriority integer NOT NULL DEFAULT 0 , FinalPriority integer NOT NULL DEFAULT 0 , DefaultDueIn integer NOT NULL DEFAULT 0 , Creator integer NOT NULL DEFAULT 0 , Created DATETIME NULL , LastUpdatedBy integer NOT NULL DEFAULT 0 , LastUpdated DATETIME NULL , Disabled int2 NOT NULL DEFAULT 0 , PRIMARY KEY (id) ) TYPE=InnoDB; CREATE UNIQUE INDEX Queues1 ON Queues (Name) ; CREATE INDEX Queues2 ON Queues (Disabled) ; # }}} # {{{ Links CREATE TABLE Links ( id INTEGER NOT NULL AUTO_INCREMENT, Base varchar(240) NULL , Target varchar(240) NULL , Type varchar(20) NOT NULL , LocalTarget integer NOT NULL DEFAULT 0 , LocalBase integer NOT NULL DEFAULT 0 , LastUpdatedBy integer NOT NULL DEFAULT 0 , LastUpdated DATETIME NULL , Creator integer NOT NULL DEFAULT 0 , Created DATETIME NULL , PRIMARY KEY (id) ) TYPE=InnoDB; CREATE UNIQUE INDEX Links1 ON Links (Base, Target, Type) ; CREATE INDEX Links2 ON Links (Base, Type) ; CREATE INDEX Links3 ON Links (Target, Type) ; CREATE INDEX Links4 ON Links (Type,LocalBase); # }}} # {{{ Principals CREATE TABLE Principals ( id INTEGER AUTO_INCREMENT not null, PrincipalType VARCHAR(16) not null, ObjectId integer, # foreign key to Users or Groups, depending Disabled int2 NOT NULL DEFAULT 0 , PRIMARY KEY (id) ) TYPE=InnoDB; CREATE INDEX Principals2 ON Principals (ObjectId); # }}} # {{{ Groups CREATE TABLE Groups ( id INTEGER NOT NULL AUTO_INCREMENT, Name varchar(200) NULL , Description varchar(255) NULL , Domain varchar(64), Type varchar(64), Instance integer, PRIMARY KEY (id) ) TYPE=InnoDB; CREATE INDEX Groups1 ON Groups (Domain,Instance,Type,id); CREATE INDEX Groups2 On Groups (Type, Instance); # }}} # {{{ ScripConditions CREATE TABLE ScripConditions ( id INTEGER NOT NULL AUTO_INCREMENT, Name varchar(200) NULL , Description varchar(255) NULL , ExecModule varchar(60) NULL , Argument varchar(255) NULL , ApplicableTransTypes varchar(60) NULL , Creator integer NOT NULL DEFAULT 0 , Created DATETIME NULL , LastUpdatedBy integer NOT NULL DEFAULT 0 , LastUpdated DATETIME NULL , PRIMARY KEY (id) ) TYPE=InnoDB; # }}} # {{{ Transactions CREATE TABLE Transactions ( id INTEGER NOT NULL AUTO_INCREMENT, EffectiveTicket integer NOT NULL DEFAULT 0 , Ticket integer NOT NULL DEFAULT 0 , TimeTaken integer NOT NULL DEFAULT 0 , Type varchar(20) NULL , Field varchar(40) NULL , OldValue varchar(255) NULL , NewValue varchar(255) NULL , Data varchar(255) NULL , Creator integer NOT NULL DEFAULT 0 , Created DATETIME NULL , PRIMARY KEY (id) ) TYPE=InnoDB; CREATE INDEX Transactions1 ON Transactions (Ticket); CREATE INDEX Transactions2 ON Transactions (EffectiveTicket); # }}} # {{{ Scrips CREATE TABLE Scrips ( id INTEGER NOT NULL AUTO_INCREMENT, Description varchar(255), ScripCondition integer NOT NULL DEFAULT 0 , ScripAction integer NOT NULL DEFAULT 0 , ConditionRules text NULL , ActionRules text NULL , CustomIsApplicableCode text NULL , CustomPrepareCode text NULL , CustomCommitCode text NULL , Stage varchar(32) NULL , Queue integer NOT NULL DEFAULT 0 , Template integer NOT NULL DEFAULT 0 , Creator integer NOT NULL DEFAULT 0 , Created DATETIME NULL , LastUpdatedBy integer NOT NULL DEFAULT 0 , LastUpdated DATETIME NULL , PRIMARY KEY (id) ) TYPE=InnoDB; # }}} # {{{ ACL CREATE TABLE ACL ( id INTEGER NOT NULL AUTO_INCREMENT, PrincipalType varchar(25) NOT NULL, #"User" "Group", "Owner", "Cc" "AdminCc", "Requestor", "Requestor" PrincipalId integer NOT NULL , #Foreign key to principals RightName varchar(25) NOT NULL , ObjectType varchar(25) NOT NULL , ObjectId integer NOT NULL default 0, DelegatedBy integer NOT NULL default 0, #foreign key to principals with a userid DelegatedFrom integer NOT NULL default 0, #foreign key to ACL PRIMARY KEY (id) ) TYPE=InnoDB; CREATE INDEX ACL1 on ACL(RightName, ObjectType, ObjectId,PrincipalType,PrincipalId); # }}} # {{{ GroupMembers CREATE TABLE GroupMembers ( id INTEGER NOT NULL AUTO_INCREMENT, GroupId integer NOT NULL DEFAULT 0, MemberId integer NOT NULL DEFAULT 0, #Foreign key to Principals PRIMARY KEY (id) ) TYPE=InnoDB; CREATE UNIQUE INDEX GroupMembers1 on GroupMembers (GroupId, MemberId); # }}} # {{{ GroupMembersCache create table CachedGroupMembers ( id int auto_increment, GroupId int, # foreign key to Principals MemberId int, # foreign key to Principals Via int, #foreign key to CachedGroupMembers. (may point to $self->id) ImmediateParentId int, #foreign key to prinicpals. # this points to the group that the member is # a member of, for ease of deletes. Disabled int2 NOT NULL DEFAULT 0 , # if this cached group member is a member of this group by way of a disabled # group or this group is disabled, this will be set to 1 # this allows us to not find members of disabled subgroups when listing off # group members recursively. # Also, this allows us to have the ACL system elide members of disabled groups PRIMARY KEY (id) ) TYPE=InnoDB; CREATE INDEX DisGrouMem on CachedGroupMembers (GroupId,MemberId,Disabled); # }}} # {{{ Users CREATE TABLE Users ( id INTEGER NOT NULL AUTO_INCREMENT, Name varchar(200) NOT NULL , Password varchar(40) NULL , Comments blob NULL , Signature blob NULL , EmailAddress varchar(120) NULL , FreeformContactInfo blob NULL , Organization varchar(200) NULL , RealName varchar(120) NULL , NickName varchar(16) NULL , Lang varchar(16) NULL , EmailEncoding varchar(16) NULL , WebEncoding varchar(16) NULL , ExternalContactInfoId varchar(100) NULL , ContactInfoSystem varchar(30) NULL , ExternalAuthId varchar(100) NULL , AuthSystem varchar(30) NULL , Gecos varchar(16) NULL , HomePhone varchar(30) NULL , WorkPhone varchar(30) NULL , MobilePhone varchar(30) NULL , PagerPhone varchar(30) NULL , Address1 varchar(200) NULL , Address2 varchar(200) NULL , City varchar(100) NULL , State varchar(100) NULL , Zip varchar(16) NULL , Country varchar(50) NULL , Timezone varchar(50) NULL , PGPKey text NULL, Creator integer NOT NULL DEFAULT 0 , Created DATETIME NULL , LastUpdatedBy integer NOT NULL DEFAULT 0 , LastUpdated DATETIME NULL , PRIMARY KEY (id) ) TYPE=InnoDB; CREATE UNIQUE INDEX Users1 ON Users (Name) ; CREATE INDEX Users4 ON Users (EmailAddress); # }}} # {{{ Tickets CREATE TABLE Tickets ( id INTEGER NOT NULL AUTO_INCREMENT, EffectiveId integer NOT NULL DEFAULT 0 , Queue integer NOT NULL DEFAULT 0 , Type varchar(16) NULL , IssueStatement integer NOT NULL DEFAULT 0 , Resolution integer NOT NULL DEFAULT 0 , Owner integer NOT NULL DEFAULT 0 , Subject varchar(200) NULL DEFAULT '[no subject]' , InitialPriority integer NOT NULL DEFAULT 0 , FinalPriority integer NOT NULL DEFAULT 0 , Priority integer NOT NULL DEFAULT 0 , TimeEstimated integer NOT NULL DEFAULT 0 , TimeWorked integer NOT NULL DEFAULT 0 , Status varchar(10) NULL , TimeLeft integer NOT NULL DEFAULT 0 , Told DATETIME NULL , Starts DATETIME NULL , Started DATETIME NULL , Due DATETIME NULL , Resolved DATETIME NULL , LastUpdatedBy integer NOT NULL DEFAULT 0 , LastUpdated DATETIME NULL , Creator integer NOT NULL DEFAULT 0 , Created DATETIME NULL , Disabled int2 NOT NULL DEFAULT 0 , PRIMARY KEY (id) ) TYPE=InnoDB; CREATE INDEX Tickets1 ON Tickets (Queue, Status) ; CREATE INDEX Tickets2 ON Tickets (Owner) ; CREATE INDEX Tickets6 ON Tickets (EffectiveId, Type) ; # }}} # {{{ ScripActions CREATE TABLE ScripActions ( id INTEGER NOT NULL AUTO_INCREMENT, Name varchar(200) NULL , Description varchar(255) NULL , ExecModule varchar(60) NULL , Argument varchar(255) NULL , Creator integer NOT NULL DEFAULT 0 , Created DATETIME NULL , LastUpdatedBy integer NOT NULL DEFAULT 0 , LastUpdated DATETIME NULL , PRIMARY KEY (id) ) TYPE=InnoDB; # }}} # {{{ Templates CREATE TABLE Templates ( id INTEGER NOT NULL AUTO_INCREMENT, Queue integer NOT NULL DEFAULT 0 , Name varchar(200) NOT NULL , Description varchar(255) NULL , Type varchar(16) NULL , Language varchar(16) NULL , TranslationOf integer NOT NULL DEFAULT 0 , Content blob NULL , LastUpdated DATETIME NULL , LastUpdatedBy integer NOT NULL DEFAULT 0 , Creator integer NOT NULL DEFAULT 0 , Created DATETIME NULL , PRIMARY KEY (id) ) TYPE=InnoDB; # }}} # {{{ TicketCustomFieldValues CREATE TABLE TicketCustomFieldValues ( id INTEGER NOT NULL AUTO_INCREMENT, Ticket int NOT NULL , CustomField int NOT NULL , Content varchar(255) NULL , Creator integer NOT NULL DEFAULT 0 , Created DATETIME NULL , LastUpdatedBy integer NOT NULL DEFAULT 0 , LastUpdated DATETIME NULL , PRIMARY KEY (id) ) TYPE=InnoDB; CREATE INDEX TicketCustomFieldValues1 ON TicketCustomFieldValues (CustomField,Ticket,Content); # }}} # {{{ CustomFields CREATE TABLE CustomFields ( id INTEGER NOT NULL AUTO_INCREMENT, Name varchar(200) NULL , Type varchar(200) NULL , Queue integer NOT NULL DEFAULT 0 , Description varchar(255) NULL , SortOrder integer NOT NULL DEFAULT 0 , Creator integer NOT NULL DEFAULT 0 , Created DATETIME NULL , LastUpdatedBy integer NOT NULL DEFAULT 0 , LastUpdated DATETIME NULL , Disabled int2 NOT NULL DEFAULT 0 , PRIMARY KEY (id) ) TYPE=InnoDB; CREATE INDEX CustomFields1 on CustomFields (Disabled, Queue); # }}} # {{{ CustomFieldValues CREATE TABLE CustomFieldValues ( id INTEGER NOT NULL AUTO_INCREMENT, CustomField int NOT NULL , Name varchar(200) NULL , Description varchar(255) NULL , SortOrder integer NOT NULL DEFAULT 0 , Creator integer NOT NULL DEFAULT 0 , Created DATETIME NULL , LastUpdatedBy integer NOT NULL DEFAULT 0 , LastUpdated DATETIME NULL , PRIMARY KEY (id) ) TYPE=InnoDB; CREATE INDEX CustomFieldValues1 ON CustomFieldValues (CustomField); # }}} # {{{ Attributes CREATE TABLE Attributes ( id INTEGER NOT NULL AUTO_INCREMENT, Name varchar(255) NULL , Description varchar(255) NULL , Content text, ContentType varchar(16), ObjectType varchar(64), ObjectId integer, # foreign key to anything Creator integer NOT NULL DEFAULT 0 , Created DATETIME NULL , LastUpdatedBy integer NOT NULL DEFAULT 0 , LastUpdated DATETIME NULL , PRIMARY KEY (id) ) TYPE=InnoDB; CREATE INDEX Attributes1 on Attributes(Name); CREATE INDEX Attributes2 on Attributes(ObjectType, ObjectId); # }}} # {{{ Sessions # sessions is used by Apache::Session to keep sessions in the database. # We should have a reaper script somewhere. CREATE TABLE sessions ( id char(32) NOT NULL, a_session LONGTEXT, LastUpdated TIMESTAMP, PRIMARY KEY (id) ); # }}} =cut Tangram-2.10/t/misc/0000755000175000017500000000000010412420117012711 5ustar samvsamvTangram-2.10/t/misc/new_types.t0000644000175000017500000000201610412412630015113 0ustar samvsamv#!/usr/bin/perl -w # For bug: http://hottub.perlfect.com/pipermail/tangram-t2-maintainers/2003-November/000108.html use lib "t"; use TestNeeds qw(Set::Object); require "t/Capture.pm"; require "t/misc/RefImage.pm"; use strict; use Test::More tests => 1; use Tangram qw(:compat_quiet); use Tangram::Relational; use Tangram::Schema; my $schema = Tangram::Schema->new( classes => { 'Document' => { id => 1, fields => { ref_image => { image => { to => [ 'Image' ] } } }, bases => [ 'Base' ], table => 'Document', }, 'Base' => { id => 2, fields => { }, abstract => 1, table => 'Base', }, } ); my $output = new Capture(); $output->capture_print(); eval { Tangram::Relational->deploy($schema); }; is( $@, "", "schema with new type inheriting from Tangram::Ref doesn't die" ); my $result = $output->release_stdout(); Tangram-2.10/t/misc/RefImage.pm0000644000175000017500000000022510412412630014726 0ustar samvsamvpackage Tangram::RefImage; use Tangram qw(:compat_quiet); use base qw(Tangram::Ref); $Tangram::Schema::TYPES{ref_image} = Tangram::RefImage->new(); Tangram-2.10/t/misc/bughunt.t0000644000175000017500000000422610412412630014557 0ustar samvsamv#!/usr/bin/perl -w # For bug: https://rt.cpan.org/NoAuth/Bug.html?id=2637 use lib "t"; use TestNeeds qw(Test::More Set::Object); require "t/Capture.pm"; use strict; use Test::More tests => 4; use Tangram qw(:compat_quiet); use Tangram::Relational; use Tangram::Schema; use Tangram::Scalar; use Tangram::Ref; use Tangram::IntrArray; my @tests = ( "iarray (Control)" => [ NaturalPerson => { fields => { string => [ qw( firstName name ) ], int => [ qw( age ) ], ref => { partner => { null => 1 } }, iarray => { children => 'NaturalPerson' }, }, }, ], "iarray (w/Package seperator)" => [ 'Natural::Person' => { fields => { string => [ qw( firstName name ) ], int => [ qw( age ) ], ref => { partner => { null => 1 } }, iarray => { children => 'Natural::Person' }, }, }, ], "iarray (w/Package seperator, long form)" => [ 'UnNatural::Person' => { fields => { string => [ qw( firstName name ) ], int => [ qw( age ) ], ref => { partner => { null => 1 } }, iarray => { children => { class => 'UnNatural::Person', } }, }, }, ], "iarray (w/Package seperator, long form + coll/slot)" => [ 'Natural::Bloke' => { fields => { string => [ qw( firstName name ) ], int => [ qw( age ) ], ref => { partner => { null => 1 } }, iarray => { children => { class => 'Natural::Bloke', coll => "foo", slot => "bar", } }, }, }, ], ); while (my ($test_name, $test_classes) = splice @tests, 0, 2) { my $schema = Tangram::Schema->new ( classes => $test_classes, normalize => sub { my ($name, $type) = @_; $name =~ s/\:\:/_/g; return $name; }, ); my $output = new Capture(); $output->capture_print(); Tangram::Relational->deploy($schema); my $result = $output->release_stdout(); $result =~ s{INSERT INTO Tangram.*}{}; unlike ($result, qr/::/, "Normalise applied - $test_name"); } Tangram-2.10/t/Makefile0000644000175000017500000000015110412412630013414 0ustar samvsamv all: ( ls misc/*.t | sort; \ ls springfield/*.t | sort; \ ls musicstore/*.t | sort ) > test_manifest Tangram-2.10/t/no_tests.t0000644000175000017500000000006010412412630013776 0ustar samvsamv print "1..0 # SKIP: TEST SUITE IS DISABLED\n"; Tangram-2.10/t/DBConfig.pm0000644000175000017500000000176110412412630013735 0ustar samvsamv package DBConfig; use DBI; use Tangram qw(:core :compat_quiet); local $/; my $config = $ENV{TANGRAM_CONFIG} || 't/CONFIG'; open CONFIG, "$config" or die "Cannot open $config, reason: $!"; my ($tx, $subsel, $ttype); ($cs, $user, $passwd, $tx, $subsel, $ttype) = split "\n", ; if ($tx =~ m/(\d)/) { $no_tx = !$1; } if ($subsel =~ m/(\d)/) { $no_subselects = !$1; } if ($ttype =~ m/table_type\s*=\s*(.*)/) { $table_type = $1; } $vendor = (split ':', $cs)[1];; $dialect = "Tangram::$vendor"; # deduce dialect from DBI driver eval "use $dialect"; ($dialect = 'Tangram::Relational'), eval("use $dialect") if $@; print $Tangram::TRACE "Vendor driver $dialect not found - using ANSI SQL ($@)\n" if $@ and $Tangram::TRACE; print $Tangram::TRACE "Using dialect $dialect\n" if $Tangram::TRACE; our $AUTOLOAD; sub AUTOLOAD { shift if UNIVERSAL::isa($_[0], __PACKAGE__); $AUTOLOAD =~ s{.*::}{}; return $$AUTOLOAD; } sub cparm { return ($cs, $user, $passwd); } 1; Tangram-2.10/t/TestNeeds.pm0000644000175000017500000000155510412412630014221 0ustar samvsamv package TestNeeds; use Data::Dumper; sub import { my $package = shift; my $caller = caller(); my @missing; while ( my $package = shift ) { my $import = ""; if ( @_ and ref $_[0] ) { local($Data::Dumper::Purity) = 1; $import = Data::Dumper::Dumper(${(shift)}); } elsif ( @_ and $_[0] =~ m/^[0-9\.\-][\w\-\.]*$/) { $import = shift; } eval "package $caller; use $package $import;"; push @missing, $package, $import, $@ if $@; } if ( @missing ) { print("1..0 # Skip missing/broken dependancies"); if ( 0 and -t STDOUT ) { print "\n"; while ( my ($pkg, $args, $err) = splice @missing, 0, 3 ) { print STDERR ("ERROR - pre-requisite $pkg " .($args ? "$args " : "") ."failed to load ($err)\n"); } } else { print "; ".join(", ", grep { !($i++ % 3) } @missing)."\n"; } exit(0); } } 1; Tangram-2.10/t/test_manifest0000644000175000017500000000153410412412630014552 0ustar samvsamvmisc/new_opers.t misc/bughunt.t misc/new_types.t springfield/00-deploy.t springfield/01-mappings.t springfield/02-cursor.t springfield/03-queries.t springfield/04-tx.t springfield/05-unload.t springfield/06-reload.t springfield/07-weakref.t springfield/15-datetime.t springfield/20-perldump.t springfield/21-flatarray.t springfield/22-flathash.t springfield/30-ref.t springfield/31-set.t springfield/32-iset.t springfield/33-array.t springfield/34-iarray.t springfield/35-hash.t springfield/36-ihash.t springfield/37-prefetch.t springfield/38-stateless.t springfield/39-save.t springfield/40-dump.t springfield/41-storable.t springfield/42-idbif.t springfield/70-mysql.t springfield/80-mi.t springfield/81-poly.t springfield/82-aggregate.t springfield/zz-retreat.t musicstore/00-deploy.t musicstore/01-simple.t musicstore/03-reschema.t musicstore/zz-retreat.t Tangram-2.10/t/springfield/0000755000175000017500000000000010412420117014264 5ustar samvsamvTangram-2.10/t/springfield/38-stateless.t0000644000175000017500000000152510412412630016714 0ustar samvsamv # wtf is this testing anyway? use strict; use lib 't/springfield'; use Springfield; Springfield::begin_tests(5); my $plant_id; { my $storage = Springfield::connect_empty; $plant_id = $storage->insert( NuclearPlant->new( employees => [ NaturalPerson->new( firstName => 'Homer' ) ] ) ); $storage->disconnect; } Springfield::leaktest; { my $storage = Springfield::connect; my $plant = $storage->load( $plant_id ); Springfield::test( @{ $plant->{employees} } == 1 && $plant->{employees}[0]{firstName} eq 'Homer' ); $storage->disconnect; } Springfield::leaktest; { my $storage = Springfield::connect; my ($plant) = $storage->select( 'NuclearPlant' ); Springfield::test( @{ $plant->{employees} } == 1 && $plant->{employees}[0]{firstName} eq 'Homer' ); $storage->disconnect; } Springfield::leaktest; 1; Tangram-2.10/t/springfield/33-array.t0000644000175000017500000002464010412412630016021 0ustar samvsamv# -*- perl -*- use strict; # for emacs debugger #use lib "../blib/lib"; #use lib "."; use lib "t/springfield"; use Springfield qw(stdpop %id leaked @kids); # This is set to 1 by iarray.t use vars qw( $intrusive ); BEGIN { my $tests = ($intrusive ? 49 : 57); eval "use Test::More tests => $tests;"; die $@ if $@; } #$intrusive = 1; #$Tangram::TRACE = \*STDOUT; my $children = $intrusive ? 'ia_children' : 'children'; sub NaturalPerson::children { my ($self) = @_; join(' ', map { $_->{firstName} || '' } @{ $self->{$children} } ) } sub marge_test { my $storage = shift; SKIP: unless ($intrusive) { #skip("n/a to Intrusive Tests", 1) if $intrusive; is( $storage->load( $id{Marge} )->children, 'Bart Lisa Maggie', "Marge's children all found" ); } } #===================================================================== # TESTING BEGINS #===================================================================== # insert the test data stdpop($children); is(leaked, 0, "Nothing leaked yet!"); # Test that updates notice changes to collections { my $storage = Springfield::connect; my $homer = $storage->load( $id{Homer} ); ok($homer, "Homer still exists!"); is($homer->children, 'Bart Lisa Maggie', "array auto-vivify 1" ); marge_test( $storage ); @{ $homer->{$children} }[0, 2] = @{ $homer->{$children} }[2, 0]; $storage->update( $homer ); $storage->disconnect; } is(leaked, 0, "leaktest"); { my $storage = Springfield::connect; my $homer = $storage->load( $id{Homer} ); is($homer->children, 'Maggie Lisa Bart', "array update test 1"); marge_test( $storage ); pop @{ $homer->{$children} }; $storage->update( $homer ); $storage->disconnect; } ############################################### # insert { my $storage = Springfield::connect; my $homer = $storage->load($id{Homer}) or die; is( $homer->children, 'Maggie Lisa', "array update test 2 (pop)" ); shift @{ $homer->{$children} }; $storage->update($homer); $storage->disconnect; } is(leaked, 0, "leaktest"); { my $storage = Springfield::connect; my $homer = $storage->load($id{Homer}) or die; is( $homer->children, 'Lisa', "array update test 2 (shift)" ); $storage->disconnect; } is(leaked, 0, "leaktest"); { my $storage = Springfield::connect; my $homer = $storage->load($id{Homer}) or die; shift @{ $homer->{$children} }; $storage->update($homer); $storage->disconnect; } is(leaked, 0, "leaktest"); { my $storage = Springfield::connect; my $homer = $storage->load($id{Homer}) or die; is( $homer->children, "", "array update test 3 (all gone)"); push @{ $homer->{$children} }, $storage->load( $id{Bart} ); $storage->update($homer); $storage->disconnect; } is(leaked, 0, "leaktest"); { my $storage = Springfield::connect; my $homer = $storage->load($id{Homer}) or die; is( $homer->children, 'Bart', "array insert test 1" ); push ( @{ $homer->{$children} }, $storage->load( @id{qw(Lisa Maggie)} ) ); $storage->update($homer); $storage->disconnect; } is(leaked, 0, "leaktest"); { my $storage = Springfield::connect; my $homer = $storage->load( $id{Homer} ); is( $homer->children, 'Bart Lisa Maggie', "array insert test 2" ); marge_test( $storage ); $storage->disconnect; } is(leaked, 0, "leaktest"); { my $storage = Springfield::connect; my $homer = $storage->load( $id{Homer} ); is( $homer->children, 'Bart Lisa Maggie', "still there" ); marge_test( $storage ); $storage->unload(); undef $homer; is(leaked, 0, "leaktest (unload)"); $storage->disconnect; } ########### # back-refs SKIP: if ($intrusive) { skip("Intr types test only", 2) unless $intrusive; my $storage = Springfield::connect; my $bart = $storage->load( $id{Bart} ); is($bart->{ia_parent}{firstName}, 'Homer', "array back-refs" ); marge_test( $storage ); $storage->disconnect; } is(leaked, 0, "leaktest"); ########## # prefetch # FIXME - add documentation to Tangram::Storage for prefetch { my $storage = Springfield::connect; my @prefetch = $storage->prefetch( 'NaturalPerson', $children ); my $homer = $storage->load( $id{Homer} ); is( $homer->children, 'Bart Lisa Maggie', "prefetch test returned same results"); marge_test( $storage ); $storage->disconnect(); } is(leaked, 0, "leaktest"); { my $storage = Springfield::connect; my $person = $storage->remote('NaturalPerson'); my @prefetch = $storage->prefetch( 'NaturalPerson', $children ); my $homer = $storage->load( $id{Homer} ); is( $homer->children, 'Bart Lisa Maggie', "prefetch test returned same results"); marge_test( $storage ); $storage->disconnect(); } is(leaked, 0, "leaktest"); ######### # queries my $parents = $intrusive ? 'Homer' : 'Homer Marge'; my $pops = $intrusive ? 'Abraham Homer' : 'Abraham Homer Marge'; { my $storage = Springfield::connect; my ($parent, $child) = $storage->remote(qw( NaturalPerson NaturalPerson )); ##local($Tangram::TRACE) = \*STDERR; my @results = $storage->select ( $parent, $parent->{$children}->includes( $child ) & $child->{firstName} eq 'Bart' ); is(join( ' ', sort map { $_->{firstName} } @results ), $parents, "Query (array->includes(t2) & t2->{foo} eq Bar)" ); $storage->disconnect(); } is(leaked, 0, "leaktest"); SKIP: { skip "SQLite doesn't like IN having a non hard-coded list", 1 if DBConfig->dialect =~ /sqlite/i; my $storage = Springfield::connect; my ($parent, $child1, $child2) = $storage->remote(qw( NaturalPerson NaturalPerson NaturalPerson )); #local($Tangram::TRACE) = \*STDERR; my @results = $storage->select ( $parent, $parent->{$children}->includes_or( $child1, $child2 ) # note the caveat - both these conditions must hold for one # row, although this may not be the one selected; ie, if I # replace "Homer" with "Montgomery", I get *NO* results - # RDBMSes suck :-) & $child1->{firstName} eq 'Bart' & $child2->{firstName} eq 'Homer' ); is(join( ' ', sort map { $_->{firstName} } @results ), $pops, "Query (includes_or with two remotes)" ); $storage->disconnect(); } is(leaked, 0, "leaktest"); #diag("-"x69); { my $storage = Springfield::connect; my ($parent, $child) = $storage->remote(qw( NaturalPerson NaturalPerson )); my @males = $storage->select ( $child, $child->{firstName} eq 'Bart' | $child->{firstName} eq 'Homer' ); #local($Tangram::TRACE) = \*STDERR; my @results = $storage->select ( $parent, $parent->{$children}->includes_or( @males ) ); is(join( ' ', sort map { $_->{firstName} } @results ), $pops, "Query (includes_or with two objects)" ); $storage->disconnect(); } is(leaked, 0, "leaktest"); #diag("-"x69); SKIP:{ skip "SQLite doesn't like IN having a non hard-coded list", 1 if DBConfig->dialect =~ /sqlite/i; skip "Oracle doesn't like DISTINCT on CLOBs; we need a new test suite ;)", 1 if DBConfig->dialect =~ /oracle/i; my $storage = Springfield::connect; my ($parent, $child ) = $storage->remote(qw( NaturalPerson NaturalPerson )); my @male = $storage->select ( $parent, $parent->{firstName} eq 'Bart' ); #local($Tangram::TRACE) = \*STDERR; my @results = $storage->select ( $parent, filter => ($parent->{$children}->includes_or( @male, $child ) & ($child->{firstName} eq "Homer")), distinct => 1, ); is(join( ' ', sort map { $_->{firstName} } @results ), $pops, "Query (includes_or with one objects & one remote)" ); $storage->disconnect(); } is(leaked, 0, "leaktest"); { my $storage = Springfield::connect; my $parent = $storage->remote( 'NaturalPerson' ); my $bart = $storage->load( $id{Bart} ); my @results = $storage->select ( $parent, $parent->{$children}->includes( $bart ) ); is(join( ' ', sort map { $_->{firstName} } @results ), $parents, 'Query (array->includes($dbobj))' ); $storage->disconnect(); } is(leaked, 0, "leaktest"); ############# # aggreg => 1 { my $storage = Springfield::connect_empty; my @children = (map { NaturalPerson->new( firstName => $_ ) } @kids); my $homer = NaturalPerson->new ( firstName => 'Homer', $children => [ map { NaturalPerson->new( firstName => $_ ) } @kids ] ); my $abe = NaturalPerson->new( firstName => 'Abe', $children => [ $homer ] ); $id{Abe} = $storage->insert($abe); $storage->disconnect(); } is(leaked, 0, "leaktest"); SKIP: { my $storage = Springfield::connect; $storage->erase( $storage->load( $id{Abe} ) ); my @pop = $storage->select('NaturalPerson'); is(@pop, 0, "aggreg deletes children via arrays"); #skip( "n/a to Intrusive Tests", 1 ) if $intrusive; unless ($intrusive) { is($storage->connection()->selectall_arrayref ("SELECT COUNT(*) FROM a_children")->[0][0], 0, "Link table cleared successfully after remove"); } $storage->disconnect(); } is(leaked, 0, "leaktest"); ############################################################################# # Tx SKIP: { skip "No transactions configured/supported", ($intrusive ? 9 : 11) if $Springfield::no_tx; stdpop($children); # check rollback of DB tx is(leaked, 0, "leaktest"); { my $storage = Springfield::connect; my $homer = $storage->load( $id{Homer} ); $storage->tx_start(); shift @{ $homer->{$children} }; $storage->update( $homer ); $storage->tx_rollback(); $storage->disconnect; } is(leaked, 0, "leaktest"); # storage should still contain 3 children { my $storage = Springfield::connect; my $homer = $storage->load( $id{Homer} ); is( $homer->children, 'Bart Lisa Maggie', "rollback 1" ); marge_test( $storage ); $storage->disconnect; } is(leaked, 0, "leaktest"); # check that DB and collection state remain in synch in case of rollback { my $storage = Springfield::connect; my $homer = $storage->load( $id{Homer} ); $storage->tx_start(); shift @{ $homer->{$children} }; $storage->update( $homer ); $storage->tx_rollback(); $storage->update( $homer ); $storage->disconnect; } # Bart should no longer be Homer's child { my $storage = Springfield::connect; my $homer = $storage->load( $id{Homer} ); is( $homer->children, 'Lisa Maggie', "auto-commit on disconnect" ); marge_test( $storage ); $storage->disconnect; } is(leaked, 0, "leaktest"); } 1; Tangram-2.10/t/springfield/41-storable.t0000644000175000017500000000275210412412630016515 0ustar samvsamv#!/usr/bin/perl -w use strict; use Test::More tests => 4; use_ok("Tangram::Dump"); use Data::Dumper; use lib 't/springfield'; use Springfield; use Set::Object qw(is_overloaded blessed); SKIP:{ #skip "Storable broken on Pg - see lib/Tangram/Pg.pod", 3 #if $Springfield::vendor eq "Pg"; my $homer_id; { my $storage = Springfield::connect_empty(); my $homer = NaturalPerson->new( firstName => 'Homer', name => 'Simpson', ); my $marge = NaturalPerson->new( firstName => 'Marge', name => 'Simpson' ); $homer->{partner} = $marge; $marge->{partner} = $homer; $homer_id = $storage->insert($homer); delete $homer->{partner}; delete $marge->{partner}; } is(leaked, 0, "leaktest"); # now test putting it in the database... { my $storage = Springfield::connect; my $homer = $storage->load($homer_id); $homer->{thought} = { me => $homer, marge => $homer->{partner}, beer => "good", beer_from => "fridge", beer_fetched_by => \\$homer->{partner}, # fails leaktest ... more investigation required #family => Set::Object->new($homer, #$homer->{partner}) }; $storage->update($homer); delete $homer->{partner}; delete $homer->{thought}; } is(leaked, 0, "leaktest"); { my $storage = Springfield::connect; my $homer = $storage->load($homer_id); my $marge = $homer->{partner}; is($homer->{thought}->{marge}, $marge, "Storable can store Tangram objects!"); } } Tangram-2.10/t/springfield/03-queries.t0000644000175000017500000001443210412413341016353 0ustar samvsamv# -*- perl -*- # Portions Copyright (c) 2002-2004, Sam Vilain. All rights reserved. # This program is free software; you may use it and/or modify it under # the same terms as Perl itself. use strict; use lib "t/springfield"; use Springfield; # $Tangram::TRACE = \*STDOUT; use Test::More tests => 23; #-------------------- # setup tests { my $storage = Springfield::connect_empty; my $homer = NaturalPerson->new( firstName => 'Homer', name => 'Simpson' ); my $marge = NaturalPerson->new( firstName => 'Marge', name => 'Simpson' ); $marge->{partner} = $homer; $homer->{partner} = $marge; $storage->insert( $homer ); $storage->insert( NaturalPerson->new( firstName => 'Montgomery', name => 'Burns' ) ); delete $homer->{partner}; $storage->disconnect(); } is(&leaked, 0, "leaktest"); #-------------------- # filter on string field { my $storage = Springfield::connect; my ($person) = $storage->remote(qw( NaturalPerson )); my @results = $storage->select ( $person, $person->{name} eq 'Simpson' ); is(join( ' ', sort map { $_->{firstName} } @results ), 'Homer Marge', "filter on string field"); $storage->disconnect(); } is(&leaked, 0, "leaktest"); #-------------------- # logical and { my $storage = Springfield::connect; my ($person) = $storage->remote(qw( NaturalPerson )); my @results = $storage->select ( $person, ($person->{firstName} eq 'Homer') & ($person->{name} eq 'Simpson' ) ); is( @results, 1, "Logical and"); is ( $results[0]{firstName}, 'Homer', "Logical and" ); $storage->disconnect(); } is(&leaked, 0, "leaktest"); #-------------------- # join on a ref link { my $storage = Springfield::connect; my ($person, $partner) = $storage->remote(qw( NaturalPerson NaturalPerson )); my @results = $storage->select ( $person, ($person->{partner} == $partner) & ($partner->{firstName} eq 'Marge') ); is( @results, 1, "Logical and"); is ( $results[0]{firstName}, 'Homer', "Logical and" ); $storage->disconnect(); } is(&leaked, 0, "leaktest"); #-------------------- # two birds with one stone; test that Tangram doesn't go disconnecting # DBI handles that it was passed! my $dbh = DBI->connect($cs, $user, $passwd) or die "DBI->connect failed; $DBI::errstr"; #-------------------- # now, test IS NOT NULL query { my $storage = Springfield::connect(undef, { dbh => $dbh }); my ($person) = $storage->remote(qw( NaturalPerson )); my @results = $storage->select( $person, $person->{partner} != undef ); is(join( ' ', sort map { $_->{firstName} } @results ), 'Homer Marge', "!= undef test"); $storage->disconnect(); } is(&leaked, 0, "leaktest"); #-------------------- # test outer joins; only really make sense with retrieve SKIP:{ skip "SQLite can't do nested joins", 1 if DBConfig->dialect =~ /sqlite/i; skip "MySQL known to return incorrect results for nested joins", 1 if DBConfig->dialect =~ /mysql/i; skip "MySQL known to return incorrect results for nested joins", 1 if DBConfig->dialect =~ /mysql/i; # first, setup some test data { my $storage = Springfield::connect(undef, { dbh => $dbh }); my @people = $storage->select("NaturalPerson"); $storage->insert (LegalPerson->new(name => "Springfield Nuclear Power Plant", colour => "Fluourescant Green", )); for ( @people ) { $_->{colour} = "Yellow"; } $storage->update(@people); } { my $storage = Springfield::connect(undef, { dbh => $dbh }); #local($Tangram::TRACE) = \*STDERR; my ($person, $partner) = $storage->remote(qw( NaturalPerson NaturalPerson )); # FIXME - polymorphic outer joins don't work. This query # might actually return wrong results. A rethink is required. my $cursor = $storage->cursor ( $person, retrieve => [ $partner->{firstName}, $partner->{colour}, ], order => [ $person->{firstName} ], outer_filter => ( ($person->{partner} == $partner) & ($partner->{firstName} == "Marge") ), ); my @results; while ( my $person = $cursor->current ) { push @results, ($person->{firstName}.":" .join(":",map { $_||""} $cursor->residue)); $cursor->next(); } #diag(Data::Dumper::Dumper(\@results)); is_deeply(\@results, [ qw( Homer:Marge:Yellow Marge:: Montgomery:: ) ], "outer join"); $storage->disconnect(); } } is(&leaked, 0, "leaktest"); # here is the test for Tangram not disconnecting - this should work. eval { my $sth = $dbh->prepare("select count(*) from Tangram") or die $DBI::errstr; $sth->execute(); my @res = $sth->fetchall_arrayref; }; ok(!$DBI::err, "Disconnect didn't disconnect a supplied DBI handle"); #-------------------- # BEGIN ks.perl@kurtstephens.com 2002/10/16 # Test non-commutative operator argument swapping { my $storage = Springfield::connect; my ($person) = $storage->remote(qw( NaturalPerson )); # local $Tangram::TRACE = \*STDERR; my @results = $storage->select ( $person, ( 1 <= $person->{person_id} ) & ( $person->{person_id} <= 2 ) ); is(@results, 2, "non-commutative operator argument swapping" ); $storage->disconnect(); } is(&leaked, 0, "leaktest"); # END ks.perl@kurtstephens.com 2002/10/16 # test selecting some columns with no filter or object { my $storage = Springfield::connect; my ($person) = $storage->remote(qw( NaturalPerson )); #local $Tangram::TRACE = \*STDERR; my @results = $storage->select ( undef, retrieve => [ $person->{id} ], order => [ $person->{id} ], ); is(@results, 3, "no filter or object (get all IDs)" ); # now try to load them - this does really kooky stuff with # polymorphic selects (seemingly makes one select per subclass) my @objects = $storage->select ( $person, $person->{id}->in(@results), ); is(@objects, 3, "selected results"); isa_ok($_, "Person", "selected item") foreach (@objects); # test that class_id works for classes not in schema (an empty # subclass test) @UndeadPerson::ISA = qw(NaturalPerson); is($storage->class_id("UndeadPerson"), $storage->class_id("NaturalPerson"), "Storage can handle Undead objects"); $storage->disconnect(); } is(&leaked, 0, "leaktest"); $dbh->disconnect(); Tangram-2.10/t/springfield/01-mappings.t0000644000175000017500000000750410412412630016514 0ustar samvsamv# -*- cperl-mode -*- use strict; use lib 't/springfield'; use Springfield; use Test::More tests => 70; package Vehicle; sub new { my $self = bless { }, shift; } sub make { my $class = shift; my $self = bless { }, $class; @$self{ $self->fields } = @_; return $self; } sub state { my $self = shift; join ' ', ref($self), @$self{ $self->fields }; } package Boat; use base qw( Vehicle ); sub fields { qw( name knots ) } package Plane; use base qw( Vehicle ); sub fields { qw( name altitude ) } package HydroPlane; use base qw( Boat Plane ); sub fields { qw( name knots altitude whatever ) } package main; sub check { my ($storage, $test_name, $class, @states) = @_; my @objs; eval { @objs = $storage->select($class); }; is($@, "", "$test_name: selecting $class objects doesn't die"); is(@objs, @states, "$test_name: correct # of $class objects"); if (@objs == @states) { my %states; @states{ @states } = (); delete @states{ map { $_->state } @objs }; is(keys %states, 0, "$test_name: objects correspond exactly"); } else { SKIP:{ skip("$test_name: carried error", 1); } } } sub test_mapping { my ($v, $b, $p, $h) = @_; my $test_name = "$v$b$p$h"; my $schema = Tangram::Relational->schema ( { control => 'Vehicles', classes => [ Vehicle => { table => $v, abstract => 1, fields => { string => [ 'name' ] } }, Boat => { table => $b, bases => [ qw( Vehicle ) ], fields => { int => [ 'knots' ] }, }, Plane => { table => $p, bases => [ qw( Vehicle ) ], fields => { int => [ 'altitude' ] }, }, HydroPlane => { table => $h, bases => [ qw( Boat Plane ) ], fields => { string => [ 'whatever' ] }, }, ] } ); use YAML; #diag(Dump $schema); SKIP: { my $dbh = DBI->connect($Springfield::cs, $Springfield::user, $Springfield::passwd, { PrintError => 0 }); # $Tangram::TRACE = \*STDOUT; eval { $Springfield::dialect->retreat($schema, $dbh) }; eval { $Springfield::dialect->deploy($schema, $dbh); }; is($@, "", "$test_name: deploy succeeded") or skip "$test_name: deploy failed", 13; $dbh->disconnect(); my $storage = Springfield::connect($schema); # use Data::Dumper; print Dumper $storage->{engine}->get_polymorphic_select($schema->classdef('Boat')); die; # my $t = HydroPlane->make(qw(Hydro 5 200 foo)); print Dumper $t; die; eval { $storage->insert( Boat->make(qw( Erika 2 )), Plane->make(qw( AF-1 20000 )), HydroPlane->make(qw(Hydro 5 200 foo)) ); }; is($@, "", "$test_name: Inserting objects doesn't die"); check($storage, $test_name, 'Boat', 'Boat Erika 2', 'HydroPlane Hydro 5 200 foo'); check($storage, $test_name, 'Plane', 'Plane AF-1 20000', 'HydroPlane Hydro 5 200 foo'); check($storage, $test_name, 'HydroPlane', 'HydroPlane Hydro 5 200 foo'); check($storage, $test_name, 'Vehicle', 'Boat Erika 2', 'Plane AF-1 20000', 'HydroPlane Hydro 5 200 foo'); $storage->disconnect(); } } test_mapping('V', 'V', 'V', 'V'); test_mapping('V', 'V', 'V', 'H'); test_mapping('V', 'B', 'V', 'V'); test_mapping('V', 'V', 'P', 'V'); test_mapping('V', 'B', 'P', 'V'); __END__ { my $schema = $dialect ->schema( { control => 'Mappings', classes => [ Fruit => { abstract => 1 }, Apple => { bases => [ 'Fruit' ] }, AppleTree => { fields => { iset => { fruits => 'Apple' } } } ] } ); $Tangram::TRACE = \*STDOUT; $dialect->retreat($schema, $cs, $user, $passwd, { PrintError => 0 }); $dialect->deploy($schema, $cs, $user, $passwd, { PrintError => 0 }); my $storage = $dialect->connect($schema, $cs, $user, $passwd); $storage->insert( bless { fruits => Set::Object->new( bless { }, 'Apple' ) }, 'AppleTree' ); $storage->disconnect(); } Tangram-2.10/t/springfield/07-weakref.t0000644000175000017500000000465710412412630016336 0ustar samvsamv# -*- cperl -*- use strict; use lib 't/springfield'; use Springfield; use Data::Lazy; use Scalar::Util qw(refaddr); BEGIN { eval "use Scalar::Util"; eval "use WeakRef" if $@; if ($@) { eval 'use Test::More skip_all => "No WeakRef / Scalar::Util"'; exit; } else { eval 'use Test::More tests => 4;'; } } my $VERBOSE; if ( @ARGV and $ARGV[0] eq "-v" ) { $VERBOSE = 1; $SpringfieldObject::VERBOSE = 1; } # $Tangram::TRACE = \*STDOUT; my $tests = 3; { my $storage = Springfield::connect_empty; $storage->insert( NaturalPerson->new( firstName => 'Homer' )); is(leaked, 0, "WeakRef works"); $storage->disconnect(); } { my $storage = Springfield::connect; { my ($homer) = $storage->select('Person'); is($SpringfieldObject::pop, 1, "Objects not lost until they fall out of scope"); } is(leaked, 0, "WeakRef still works"); $storage->disconnect(); } sub sameid { my $obj; for (1..2) { $obj = {}; diag("got ".sprintf("0x%.8x",refaddr($obj)) .", looking for ".sprintf("0x%.8x",$_[0]||0)) if $VERBOSE; last if refaddr($obj) == ($_[0] ||= refaddr($obj)); $obj = undef; } $obj; } sub homer { my ($homer) = $_[0]->select('Person'); return $homer; } SKIP: { my $storage = Springfield::connect; my ($sameid,$refaddr, $test) = (undef, 0, undef); { homer($storage); } $storage->{schema}{make_object} = sub { my $x = $sameid; bless $x, (shift); $SpringfieldObject::pop++; return $sameid; }; diag("leaked is: ".leaked) if $VERBOSE; # note - this loop is fragile, but worksforme on perl 5.8.4, Ubuntu # hoary on amd64. Reports of other successes welcome. LOOP: for my $x ( 1..5 ) { { $refaddr = 0 unless $x > 2; diag("undef(\$sameid = $sameid)") if $VERBOSE; undef($sameid); undef($test); diag("done undef") if $VERBOSE; $test = sameid($refaddr) or next; tie $sameid, 'Data::Lazy' => sub { $test }; diag("test is: ".$test) if $VERBOSE; diag("sameid is: ".$sameid) if $VERBOSE; if ( $x <= 2 ) { homer($storage); } else { diag("wohoo! I got ".sprintf("0x%.8x",refaddr($sameid) )) if $VERBOSE; diag ("calling last") if $VERBOSE; last LOOP; } } diag("leaked is: ".leaked) if $VERBOSE; } skip "failed to get an object with the same refid", 1 unless $sameid; is($storage->id($sameid), undef, "hmm!"); $storage->disconnect(); } Tangram-2.10/t/springfield/70-mysql.t0000644000175000017500000000070310412412630016043 0ustar samvsamv use lib "t/springfield"; use Springfield; tests_for_dialect('mysql'); begin_tests(1); { my $storage = Springfield::connect_empty(); $storage->insert( NaturalPerson->new( firstName => 'Homer', age => 37 ), NaturalPerson->new( firstName => 'Marge', age => 34 ) ); my $p = $storage->remote('NaturalPerson'); my @results = $storage->select($p, $p->{age}->bitwise_and(1)); test @results == 1 && $results[0]{firstName} eq 'Homer'; } Tangram-2.10/t/springfield/20-perldump.t0000644000175000017500000000120510412412630016517 0ustar samvsamv use lib "t/springfield"; use Springfield; begin_tests(1); my $id; { my $storage = Springfield::connect_empty(); $id = $storage ->insert( NaturalPerson->new( firstName => 'Homer', brains => { likes => [ qw( beer food ) ], dislikes => [ qw( Flanders taxes ) ], } ) ); $storage->disconnect(); } { my $storage = Springfield::connect(); my $homer = $storage->load($id); test( join('|', sort keys %{ $homer->{brains} }) eq 'dislikes|likes' && "@{ $homer->{brains}{likes} }" eq 'beer food' && "@{ $homer->{brains}{dislikes} }" eq 'Flanders taxes' ); $storage->disconnect(); } Tangram-2.10/t/springfield/34-iarray.t0000644000175000017500000000012110412412630016157 0ustar samvsamv use vars qw( $intrusive ); $intrusive = 1; require 't/springfield/33-array.t'; Tangram-2.10/t/springfield/zz-retreat.t0000644000175000017500000000072110412412630016561 0ustar samvsamv#!/usr/bin/perl -w use strict; use Test::More tests => 2; use lib "t/springfield"; BEGIN { use_ok "Springfield"; }; local $/; SKIP: { my $dbh = DBI->connect( $Springfield::cs, $Springfield::user, $Springfield::passwd ) or skip "could not connect to database", 1; $dbh->{RaiseError} = 1; $Springfield::dialect->retreat($Springfield::schema, $dbh); pass("retreat completed without raising errors"); $dbh->disconnect; } Tangram-2.10/t/springfield/35-hash.t0000644000175000017500000000301410412412630015620 0ustar samvsamv# -*- perl -*- use strict; use lib 't/springfield'; use Springfield; use Test::More tests => 4; use vars qw( $intrusive ); my $opinions = $intrusive ? 'ih_opinions' : 'h_opinions'; (my $other = $opinions) =~ s{^(i)?}{($1 ? "" : "i")}e; #$Tangram::TRACE = \*STDOUT; sub graph { my $homer = NaturalPerson->new( firstName => 'Homer', name => 'Simpson', $opinions => { work => Opinion->new(statement => 'bad'), food => Opinion->new(statement => 'good'), beer => Opinion->new(statement => 'better') }, # this is for is_deeply... $other => undef, ); } { my $storage = Springfield::connect_empty(); my $homer = graph(); $storage->insert($homer); $storage->disconnect(); } is(leaked, 0, "leaktest"); { my $storage = Springfield::connect(); my ($homer) = $storage->select('NaturalPerson'); # Test::More can be awfully pedantic at times :) my $homer_eg = graph(); my $opinions_h = $homer_eg->{$opinions}; my $ih_parent; if ($intrusive) { $ih_parent = $homer_eg; } while (my($k,$v)= each %$opinions_h) { $v->{ih_parent} = $ih_parent; } is_deeply([ sort keys %{ $homer->{$opinions}} ], [ sort keys %{$opinions_h} ], "Hash returned intact"); is_deeply([ sort map { $_->{statement} } values %{ $homer->{$opinions}} ], [ sort map { $_->{statement} } values %{ $opinions_h } ], "Hash returned intact"); # smash circular references... while (my($k,$v)= each %$opinions_h) { $v->{ih_parent} = undef; } $storage->disconnect(); } is(leaked, 0, "leaktest"); Tangram-2.10/t/springfield/05-unload.t0000644000175000017500000000130410412412630016154 0ustar samvsamv use strict; use lib 't/springfield'; use Springfield; # $Tangram::TRACE = \*STDOUT; Springfield::begin_tests(3); { my $storage = Springfield::connect_empty; $storage->insert( NaturalPerson->new( firstName => 'Homer' )); $storage->unload(); Springfield::leaktest; $storage->disconnect(); } { my $storage = Springfield::connect_empty; $storage->insert( my $homer = NaturalPerson->new( firstName => 'Homer' )); my $marge_id = $storage->insert( my $marge = NaturalPerson->new( firstName => 'Marge' )); $storage->unload($homer); undef $homer; Springfield::test($SpringfieldObject::pop == 1); $storage->unload($marge_id); undef $marge; Springfield::leaktest; $storage->disconnect(); } Tangram-2.10/t/springfield/06-reload.t0000644000175000017500000000144610412412630016150 0ustar samvsamv # I'm not sure exactly what aspect of `reload' this is testing... use strict; use lib 't/springfield'; use Springfield; # $Tangram::TRACE = \*STDOUT; Springfield::begin_tests(5); { my $storage = Springfield::connect_empty; $storage->insert( NaturalPerson->new( firstName => 'Marge', name => 'Bouvier' ) ); $storage->disconnect; } Springfield::leaktest; { my $storage = Springfield::connect; my ($marge) = $storage->select('NaturalPerson'); testcase($marge->{name} eq 'Bouvier'); $marge->{name} = 'Simpson'; $marge->{children} = [ NaturalPerson->new( firstName => 'Bart', name => 'Simpson' ) ]; $storage->update($marge); $storage->reload($marge); testcase($marge->{name} eq 'Simpson'); testcase(@{ $marge->{children} } == 1); $storage->disconnect; } Springfield::leaktest; 1; Tangram-2.10/t/springfield/30-ref.t0000644000175000017500000000363310412412630015453 0ustar samvsamv use lib "t/springfield"; use Springfield; my %id; Springfield::begin_tests(11); { $storage = Springfield::connect_empty; my $homer = NaturalPerson->new( firstName => 'Homer' ); my $marge = NaturalPerson->new( firstName => 'Marge' ); $homer->{partner} = $marge; $id{Marge} = $storage->insert($marge); $id{Homer} = $storage->insert($homer); $storage->disconnect(); } Springfield::leaktest; { $storage = Springfield::connect(); my ($p1, $p2) = $storage->remote(qw( NaturalPerson NaturalPerson )); my ($homer, $other) = $storage->select( $p1, ($p1->{partner} == $p2) & ($p2->{firstName} eq 'Marge') ); Springfield::test( $homer && !$other ); $storage->disconnect(); } Springfield::leaktest; { $storage = Springfield::connect(); my $marge = $storage->load( $id{Marge} ); my ($p1) = $storage->remote(qw( NaturalPerson )); my ($marge2, $other) = $storage->select( $p1, $p1 == $marge ); Springfield::test( $marge2 && !$other ); $storage->disconnect(); } Springfield::leaktest; { $storage = Springfield::connect(); my $marge = $storage->load( $id{Marge} ); my ($p1, $p2) = $storage->remote(qw( NaturalPerson NaturalPerson )); my $ff = $p1 == $p1; my ($homer, $other) = $storage->select( $p1, $p1->{partner} == $marge ); Springfield::test( $homer && !$other ); $storage->disconnect(); } Springfield::leaktest; { $storage = Springfield::connect_empty(); $ids{Homer} = $storage->insert( NaturalPerson->new( name => 'Homer', credit => Credit->new( limit => 1000 ) ) ); my @credits = $storage->select('Credit'); Springfield::test( @credits == 1 ); $storage->disconnect(); } Springfield::leaktest; { $storage = Springfield::connect(); my $homer = $storage->load( $ids{Homer} ); print $homer->{credit}, "\n"; $storage->erase( $homer ); my @credits = $storage->select('Credit'); Springfield::test( @credits == 0 ); $storage->disconnect(); } Springfield::leaktest; Tangram-2.10/t/springfield/32-iset.t0000644000175000017500000000011710412412630015637 0ustar samvsamv use vars qw( $intrusive ); $intrusive = 1; require 't/springfield/31-set.t'; Tangram-2.10/t/springfield/21-flatarray.t0000644000175000017500000001035510412412630016663 0ustar samvsamv# -*- perl -*- ergo sum use strict; use lib 't/springfield'; use Springfield; use Test::More tests => 24; { my $storage = Springfield::connect_empty(); my $homer = NaturalPerson->new( firstName => 'Homer', name => 'Simpson', interests => [ qw( beer food ) ] ); $storage->insert($homer); $storage->disconnect(); } is(leaked, 0, "Nothing leaked"); { my $storage = Springfield::connect(); my ($homer) = $storage->select('NaturalPerson'); is("@{ $homer->{interests} }", 'beer food', "Flat array store/retrieve"); $storage->disconnect(); } is(leaked, 0, "Nothing leaked"); { my $storage = Springfield::connect(); my ($homer) = $storage->select('NaturalPerson'); push @{ $homer->{interests} }, 'sex'; $storage->update($homer); $storage->disconnect(); } is(leaked, 0, "Nothing leaked"); { my $storage = Springfield::connect(); my ($homer) = $storage->select('NaturalPerson'); is("@{ $homer->{interests} }", 'beer food sex', "Array change flushed successfully"); pop @{ $homer->{interests} }; $storage->update($homer); $storage->disconnect(); } is(leaked, 0, "Nothing leaked"); { my $storage = Springfield::connect(); my ($homer) = $storage->select('NaturalPerson'); is("@{ $homer->{interests} }", 'beer food', "Array change flushed again successfully"); unshift @{ $homer->{interests} }, 'sex'; $storage->update($homer); $storage->disconnect(); } is(leaked, 0, "Nothing leaked"); { my $storage = Springfield::connect(); my ($homer) = $storage->select('NaturalPerson'); is("@{ $homer->{interests} }", 'sex beer food', "Array change flushed yet again successfully"); delete $homer->{interests}; $storage->update($homer); $storage->disconnect(); } is(leaked, 0, "Nothing leaked"); { my $storage = Springfield::connect(); my ($homer) = $storage->select('NaturalPerson'); is("@{ $homer->{interests} }", '', "Removing array flushes from DB"); $homer->{interests} = [ qw( beer food ) ]; $storage->update($homer); $storage->insert( NaturalPerson->new( firstName => 'Marge', name => 'Simpson', interests => [ qw( kids household cooking cleaning ) ] ) ); $storage->disconnect(); } is(leaked, 0, "Nothing leaked"); # exists, includes { my $storage = Springfield::connect(); my ($remote) = $storage->remote('NaturalPerson'); my @results = $storage->select($remote, $remote->{interests}->includes('beer')); is(@results, 1, "Got back one result only"); is($results[0]->{firstName}, 'Homer', "Select by array entry"); $storage->disconnect(); } is(leaked, 0, "Nothing leaked"); { SKIP: { my $storage = Springfield::connect(); $storage->disconnect, skip "Sub-select tests disabled", 2, if $storage->{no_subselects}; my ($remote) = $storage->remote('NaturalPerson'); my @results = $storage->select($remote, $remote->{interests}->exists('beer')); is(@results, 1, "I'll wash all the dishes,"); is($results[0]->{firstName}, 'Homer', "And you go have a beer"); $storage->disconnect(); } } is(leaked, 0, "Nothing leaked"); # prefetch { my $storage = Springfield::connect(); my ($remote) = $storage->remote('NaturalPerson'); $storage->prefetch($remote, 'interests'); my ($homer) = $storage->select($remote, $remote->{firstName} eq 'Homer'); { local ($storage->{db}); is("@{ $homer->{interests} }", 'beer food', "Prefetch test - no prefetch filter"); } $storage->disconnect(); } is(leaked, 0, "Nothing leaked - here 1"); { my $storage = Springfield::connect(); my ($remote) = $storage->remote('NaturalPerson'); $storage->prefetch($remote, 'interests', $remote->{firstName} eq 'Homer'); my ($homer) = $storage->select($remote, $remote->{firstName} eq 'Homer'); { local ($storage->{db}); is("@{ $homer->{interests} }", 'beer food', "Another prefetch test - prefetch filter" ); } $storage->disconnect(); } THEEND: is(leaked, 0, "Nothing leaked - here 2"); { my $storage = Springfield::connect(); $storage->erase( $storage->select('NaturalPerson')); $storage->disconnect(); $storage = Springfield::connect(); is( $storage->connection()->selectall_arrayref("SELECT COUNT(*) FROM NaturalPerson_interests")->[0][0], 0, "All interests cleaned up correctly" ); $storage->disconnect(); } is(leaked, 0, "Nothing leaked"); Tangram-2.10/t/springfield/15-datetime.t0000644000175000017500000000451610412412630016477 0ustar samvsamv#!/usr/bin/perl use strict; use lib 't/springfield'; use Springfield; BEGIN { eval "use Date::Manip qw(ParseDate);"; if ($@) { eval 'use Test::More skip_all => "Date::Manip not installed";'; } else { eval 'use Test::More tests => 11;'; } } my $do_rawtests = ($dialect =~ m/^Tangram::mysql$/); #tests_for_dialect(qw( mysql Pg )); #$Tangram::TRACE = \*STDOUT; my %ids; { my $storage = Springfield::connect_empty; my $jll = NaturalPerson->new ( firstName => 'Jean-Louis', ($do_rawtests ?( birthDate => '1963-8-13', birthTime => '11:34:17', birth => '1963-8-13 11:34:17', ) : ()), incarnation => ParseDate('1963-8-13 11:34:17'), ); $ids{jll} = $storage->insert($jll); my $chloe = NaturalPerson->new ( firstName => 'Chloe', ($do_rawtests ? (birth => '1993-7-28 13:10:00') : () ), incarnation => ParseDate('1993-7-28 13:10:00'), ); $ids{chloe} = $storage->insert($chloe); $storage->disconnect; } is(leaked, 0, "leaktest"); { my $storage = Springfield::connect; my $jll = $storage->load( $ids{jll} ); SKIP:{ skip "RAW date/time tests not worth it", 6 unless $do_rawtests; like($jll->{birthTime}, qr/11/, "raw time [1]"); like($jll->{birthTime}, qr/34/, "raw time [2]"); like($jll->{birthTime}, qr/17/, "raw time [3]"); like($jll->{birthDate}, qr/1963/, "raw date [1]"); like($jll->{birthDate}, qr/13/, "raw date [2]"); like($jll->{birthDate}, qr/8/, "raw date [3]"); } my $rp = $storage->remote(qw( NaturalPerson )); # FIXME - this is pretty much a hack for now. It doesn't seem # straightforward to overload Tangram::DMDateTime::binop to be # able to wrap the arg later on. This works for now! my @results = $storage->select ( $rp, $rp->{incarnation} > $storage->to_dbms('date', '1990-01-01T12:00:00') ); is(@results, 1, "Select by date compare"); is($storage->id( $results[0] ), $ids{chloe}, "got right object back" ); like( $results[0]->{incarnation}, qr/^\d{10}:\d\d:\d\d$/, "Dates returned in ISO8601 form" ); # if (optional_tests('epoch; no Time::Local', # eval { require 'Time::Local' }, 1)) { # Springfield::test($jll->{birthDate} =~ /1963/ # && $jll->{birthDate} =~ /13/ # && $jll->{birthDate} =~ /8/ # ); # } $storage->disconnect; } is(leaked, 0, "leaktest"); 1; Tangram-2.10/t/springfield/00-deploy.t0000644000175000017500000000121210412412630016157 0ustar samvsamv#!/usr/bin/perl -w use strict; use lib "t"; use TestNeeds qw(Test::More Set::Object); use Test::More tests => 2; use lib "t/springfield"; BEGIN { use_ok "Springfield"; }; local $/; SKIP: { my $dbh = DBI->connect( $Springfield::cs, $Springfield::user, $Springfield::passwd ) or skip "could not connect to database", 1; do { local $dbh->{PrintError}; local $dbh->{RaiseError}; $Springfield::dialect->retreat($Springfield::schema, $dbh); }; $dbh->{RaiseError} = 1; $Springfield::dialect->deploy($Springfield::schema, $dbh); pass("deploy completed without raising errors"); $dbh->disconnect; } Tangram-2.10/t/springfield/Springfield.pm0000644000175000017500000002653710412412630017106 0ustar samvsamvuse strict; use lib "t"; use Tangram qw(:compat_quiet); use Tangram::RawDate; use Tangram::RawTime; use Tangram::RawDateTime; use Tangram::FlatArray; use Tangram::FlatHash; use Tangram::PerlDump; use Tangram::Storable; use Tangram::IDBIF; package Springfield; use Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %id @kids @opinions $no_date_manip); eval 'use Tangram::Type::Date::Manip'; $no_date_manip = $@; @ISA = qw( Exporter ); @EXPORT = qw( &optional_tests $schema testcase &leaktest &leaked &test &begin_tests &tests_for_dialect $dialect $cs $user $passwd stdpop %id @kids @opinions); @EXPORT_OK = @EXPORT; use vars qw($cs $user $passwd $dialect $vendor $schema); use vars qw($no_tx $no_subselects $table_type); use lib "t"; use DBConfig; { my ($tx, $subsel, $ttype); ($cs, $user, $passwd) = DBConfig->cparm; $no_tx = DBConfig->no_tx; $no_subselects = DBConfig->no_subselects; $table_type = DBConfig->table_type; $vendor = DBConfig->vendor; $dialect = DBConfig->dialect; } sub list_if { shift() ? @_ : () } $schema = ( { #set_id => sub { my ($obj, $id) = @_; $obj->{id} = $id }, #get_id => sub { shift()->{id} }, sql => { cid_size => 3, # Allow InnoDB style tables ( $table_type ? ( table_type => $table_type ) : () ), dumper => "Data::Dumper", }, class_table => 'Classes', classes => [ Person => { abstract => 1, fields => { string => { colour => undef, }, }, }, NaturalPerson => { bases => [ qw( Person ) ], fields => { string => { firstName => undef, name => undef, }, int => [ qw( age person_id ) ], # ks.perl@kurtstephens.com 2003/10/16 ref => { partner => undef, credit => { aggreg => 1 }, }, # only test the RAW columns with PostgreSQL and MySQL ($vendor =~ m/^(Pg|mysql)/ ? (rawdate => [ qw( birthDate ) ], rawtime => [ qw( birthTime ) ], rawdatetime => [ qw( birth ) ], ):()), ($no_date_manip ? () : ( dmdatetime => [ qw( incarnation ) ] )), #($no_time_piece ? () : ( timepiece => [ qw( timepiece ) ] )), #($no_date_manip ? () : ( dmdatetime => [ qw( incarnation ) ] )), array => { children => { class => 'NaturalPerson', table => 'a_children', aggreg => 1, }, belongings => { class => 'Item', aggreg => 1, deep_update => 1 }, a_opinions => { class => 'Opinion', table => 'a_opinions', } }, ihash => { ih_opinions => { class => 'Opinion', back => "ih_parent", } }, hash => { h_opinions => { class => 'Opinion', table => 'h_opinions', } }, iarray => { ia_children => { class => 'NaturalPerson', coll => 'ia_ref', slot => 'ia_slot', back => 'ia_parent', aggreg => 1, }, ia_opinions => { class => 'Opinion', } }, set => { s_children => { class => 'NaturalPerson', table => "s_children", #__ aggreg => 1, }, #s_parents => #{ #class => 'NaturalPerson', #table => 's_children', #coll => "item", #item => "coll", #}, s_opinions => { class => 'Opinion', table => 's_opinions', #__ } }, iset => { is_children => { class => 'NaturalPerson', coll => 'is_ref', slot => 'is_slot', back => 'is_parent', aggreg => 1, }, is_opinions => { class => 'Opinion', } }, flat_array => [ qw( interests ) ], flat_hash => [ qw( opinions ) ], perl_dump => [ qw( brains ) ], ( $vendor !~ m/^Peegee$/ ? (storable => [ qw( thought ) ]) : () ), }, }, Opinion => { fields => { string => [ qw( statement ) ], }, }, LegalPerson => { bases => [ qw( Person ) ], table => "Person", fields => { string => [ qw( name ) ], ref => { manager => { null => 1 } }, }, }, EcologicalRisk => { abstract => 1, fields => { int => [ qw( curies ) ], }, }, NuclearPlant => { bases => [ qw( LegalPerson EcologicalRisk ) ], fields => { array => { employees => { class => 'NaturalPerson', table => 'employees' } }, }, }, Credit => { fields => { #int => { limit => { col => 'theLimit' } }, int => { limit => 'theLimit' }, } }, Item => { fields => { string => [ qw(name) ], ref => { owner => { deep_update => 1 } } } }, Faerie => { fields => { idbif => { -poof => # there goes another one! undef # { dumper => "Storable" } }, string => [ qw(name) ], }, }, FaerieHairy => { fields => { string => [ qw(name) ], idbif => { friends => undef, enemies => undef, #-options => { dumper => "Storable" }, } }, }, Sprite => { table => qw(Faerie), bases => [ qw(Faerie) ], fields => { string => [ qw(foo) ], }, }, Nymph => { table => qw(FaerieHairy), bases => [ qw(FaerieHairy) ], fields => { idbif => [ qw(buddies) ], }, }, ], } ); if ( $ENV{"NORMALIZE_TEST"} ) { $schema->{normalize} = sub { local($_)=shift; print STDERR "topic is $_\n"; s/NaturalPerson/NP/; s/$/_n/; return $_; }; } $schema = Tangram::Schema->new($schema); sub connect { my $schema = shift || $Springfield::schema; my $opts = shift || {}; my $storage = $dialect->connect($schema, $cs, $user, $passwd, $opts) || die; $no_tx = $storage->{no_tx} unless defined $no_tx; $no_subselects = $storage->{no_subselects}; return $storage; } sub empty { my $storage = shift || Springfield::connect; my $schema = shift || $Springfield::schema; my $conn = $storage->{db}; foreach my $classdef (values %{ $schema->{classes} }) { $conn->do("DELETE FROM $classdef->{table}") or die unless $classdef->{stateless}; } $conn->do('DELETE FROM a_children'); $conn->do('DELETE FROM s_children'); } sub connect_empty { my $schema = shift || $Springfield::schema; my $storage = Springfield::connect($schema); empty($storage, $schema); return $storage; } use vars qw( $test ); sub begin_tests { print "1..", shift, "\n"; $test = 1; } sub _caller { my @caller = caller(1); return "$caller[1] line $caller[2]"; } sub test { my $ok = shift; print 'not ' unless $ok; print 'ok ', $test++; print " - "._caller()."\n"; my ($fun, $file, $line) = caller; print "$file($line) : error\n" unless $ok; } *testcase = \&test; sub leaktest { if ($SpringfieldObject::pop == 0) { print "ok $test - leaktest "._caller()."\n"; } else { my ($fun, $file, $line) = caller; print "not ok $test - leaktest "._caller()."\n"; print "$file($line) : error: $SpringfieldObject::pop object(s) leaked\n"; } $SpringfieldObject::pop = 0; ++$test; } sub leaked { return $SpringfieldObject::pop; } sub tx_tests { my ($tests, $code) = @_; if ($no_tx) { print STDERR "tests $test-", $test + $tests - 1, " (transactions) skipped on this platform "; test(1) while $tests--; } else { &$code; } } sub optional_tests { my ($what, $proceed, $tests) = @_; $test ||= 1; unless ($proceed) { print STDERR "tests $test-", $test + $tests - 1, " ($what) skipped on this platform "; test(1) while $tests--; } return $proceed; } sub tests_for_dialect { my %dialect; @dialect{@_} = (); return if exists $dialect{ (split ':', $cs)[1] }; begin_tests(1); optional_tests($dialect, 0, 1); exit; } #use Data::Dumper; #print Dumper $schema; #deploy; @kids = qw( Bart Lisa Maggie ); sub stdpop { my $storage = Springfield::connect_empty; my $children = shift || "children"; $NaturalPerson::person_id = 0; # ks.perl@kurtstephens.com 2003/10/16 my @children = (map { NaturalPerson->new( firstName => $_ ) } @kids); $children[0]->{age} = 10; $children[1]->{age} = 8; $children[2]->{age} = 1; @id{ @kids } = $storage->insert( @children ); # *cough* hack *cough* main::like("@id{@kids}", qr/^\d+ \d+ \d+$/, "Got ids back OK") if defined &main::like; my %ops = ( "beer" => Opinion->new(statement => "good"), "donuts" => Opinion->new(statement => "mmm.."), "heart disease" => Opinion->new(statement => "Heart What?")); @opinions = map { $_->{statement} } values %ops; my $homer; { $homer = NaturalPerson->new ( age => 38, firstName => 'Homer', ($children =~ m/children/ ? ($children =~ m/s_/ ? ( $children => Set::Object->new(@children) ) : ( $children => [ @children ] ) ) : () ), ($children =~ m/opinion/ ? ($children =~ m/h_/ ? ($children => { %ops }) : ($children =~ m/a_/ ? ($children => [ values %ops ]) : ($children => Set::Object->new( values %ops ) ) ) ) : () ) ); } $id{Homer} = $storage->insert($homer); main::isnt($id{Homer}, 0, "Homer inserted OK") if defined &main::isnt; my $marge = NaturalPerson->new( firstName => 'Marge', age => 37, ); # cannot have >1 parent with a one to many relationship! if ($children =~ m/children/) { if ($children =~ m/^i/) { } elsif ($children =~ m/s_/) { $marge->{$children} = Set::Object->new(@children); } else { $marge->{$children} = [ @children ] } } $id{Marge} = $storage->insert($marge); main::isnt($id{Marge}, 0, "Marge inserted OK") if defined &main::isnt; my $abraham = NaturalPerson->new( firstName => 'Abraham', age => 62, ($children =~ m/children/ ? ($children =~ m/s_/ ? ( $children => Set::Object->new($homer) ) : ( $children => [ $homer ] ) ) : () ), ); $id{Abraham} = $storage->insert($abraham); $storage->disconnect; } package SpringfieldObject; use vars qw( $pop $VERBOSE ); sub new { my $pkg = shift; ++$pop; my $foo = bless { $pkg->defaults, @_ }, $pkg; print STDERR "# I am alive! $foo\n" if $VERBOSE; return $foo; } sub defaults { return (); } sub DESTROY { # die if exists shift->{id}; print STDERR "# I am dying! $_[0]\n" if $VERBOSE; --$pop; } package Person; use vars qw(@ISA); @ISA = qw( SpringfieldObject ); sub as_string { die 'subclass responsibility'; } #use overload '""' => sub { shift->as_string }, fallback => 1; package NaturalPerson; use vars qw(@ISA); @ISA = qw( Person ); # BEGIN ks.perl@kurtstephens.com 2003/10/16 our $person_id = 0; # END ks.perl@kurtstephens.com 2003/10/16 sub defaults { 'person_id' => ++ $person_id, # ks.perl@kurtstephens.com 2003/10/16 a_children => [], ia_children => [], s_children => Set::Object->new, is_children => Set::Object->new, h_opinions => {} } sub as_string { my ($self) = @_; local $^W; # why? get use of undefined value otherwise exists($self->{name}) && exists($self->{firstName}) && "$self->{firstName} $self->{name}" || $self->{firstName} || $self->{name} } package LegalPerson; use vars qw(@ISA); @ISA = 'Person'; sub as_string { return shift->{name}; } package NuclearPlant; use vars qw(@ISA); @ISA = qw( LegalPerson ); package Opinion; use vars qw(@ISA); @ISA = qw( SpringfieldObject ); package Credit; use vars qw(@ISA); @ISA = qw( SpringfieldObject ); package Item; use vars qw(@ISA); @ISA = qw( SpringfieldObject ); package Faerie; use vars qw(@ISA); @ISA = qw( SpringfieldObject ); package FaerieHairy; use vars qw(@ISA); @ISA = qw( SpringfieldObject ); 1; Tangram-2.10/t/springfield/31-set.t0000644000175000017500000001622410412412630015473 0ustar samvsamv# -*- perl -*- use strict; use lib 't/springfield'; use Springfield qw(%id); use vars qw( $intrusive ); my $children = $intrusive ? 'is_children' : 's_children'; my @kids = qw( Bart Lisa Maggie ); sub NaturalPerson::children { my ($self) = @_; my @children = sort { $a->{firstName} cmp $b->{firstName} } $self->{$children}->members; return wantarray ? @children : join(' ', map { $_->{firstName} } @children ); } sub marge_test { my $storage = shift; Springfield::test( $intrusive || $storage->load( $id{Marge} )->children eq 'Bart Lisa Maggie' ); } sub stdpop { #local($Tangram::TRACE) = \*STDERR; my $storage = Springfield::connect_empty; my @children = map { NaturalPerson->new( firstName => $_ ) } @kids; @id{ @kids } = $storage->insert( @children ); # my $homer = NaturalPerson->new( firstName => 'Homer', $children => Set::Object->new( @children ) ); $id{Homer} = $storage->insert($homer); # my $marge = NaturalPerson->new( firstName => 'Marge' ); $marge->{$children} = Set::Object->new( @children ) unless $intrusive; $id{Marge} = $storage->insert($marge); # $storage->disconnect; ##<>; } Springfield::begin_tests(43); stdpop(); Springfield::leaktest; { my $storage = Springfield::connect; my $homer = $storage->load( $id{Homer} ); Springfield::test( $homer->children eq 'Bart Lisa Maggie' ); marge_test( $storage ); $homer->{$children}->remove( $storage->load( $id{Bart} ) ); $storage->update( $homer ); $storage->disconnect; } ############################################### # insert { my $storage = Springfield::connect; my $homer = $storage->load($id{Homer}) or die; Springfield::test( $homer->children eq 'Lisa Maggie' ); marge_test( $storage ); $homer->{$children}->clear(); $storage->update($homer); $storage->disconnect; } Springfield::leaktest; { my $storage = Springfield::connect; my $homer = $storage->load($id{Homer}) or die; Springfield::test( $homer->children eq '' ); marge_test( $storage ); my $bart; $homer->{$children}->insert ( $bart = ($intrusive ? NaturalPerson->new(firstName => "Bart") : $storage->load($id{Bart}) )); $storage->update($homer); $id{Bart} = $storage->id($bart); $storage->disconnect; } Springfield::leaktest; { my $storage = Springfield::connect; my $homer = $storage->load($id{Homer}) or die; Springfield::test( $homer->children eq 'Bart' ); marge_test( $storage ); my ($lisa, $maggie); $homer->{$children}->insert ( ($lisa, $maggie) = ($intrusive ? ( map { NaturalPerson->new(firstName => $_) } qw( Lisa Maggie ) ) : ( $storage->load(@id{qw(Lisa Maggie)}) ), ) ); $storage->update($homer); @id{qw(Lisa Maggie)} = $storage->id($lisa, $maggie); $storage->disconnect; } Springfield::leaktest; { my $storage = Springfield::connect; my $homer = $storage->load( $id{Homer} ); Springfield::test( $homer->children eq 'Bart Lisa Maggie' ); marge_test( $storage ); $storage->disconnect; } Springfield::leaktest; { my $storage = Springfield::connect; my $homer = $storage->load( $id{Homer} ); Springfield::test( $homer->children eq 'Bart Lisa Maggie' ); marge_test( $storage ); $storage->reset(); undef $homer; Springfield::leaktest; $storage->disconnect; } { my $storage = Springfield::connect; my @prefetch = $storage->prefetch( 'NaturalPerson', $children ); my $homer = $storage->load( $id{Homer} ); Springfield::test( $homer->children eq 'Bart Lisa Maggie' ); marge_test( $storage ); $storage->disconnect; } Springfield::leaktest; { my $storage = Springfield::connect; my $bart = $storage->load( $id{Bart} ); Springfield::test( !$intrusive || $bart->{is_parent}{firstName} eq 'Homer' ); marge_test( $storage ); $storage->disconnect; } Springfield::leaktest; { my $storage = Springfield::connect; my $person = $storage->remote('NaturalPerson'); my @prefetch = $storage->prefetch( $person, $children, $person->{firstName} eq 'Homer' ); my $homer = $storage->load( $id{Homer} ); Springfield::test( $homer->children eq 'Bart Lisa Maggie' ); marge_test( $storage ); $storage->disconnect; } Springfield::leaktest; ######### # queries my $parents = $intrusive ? 'Homer' : 'Homer Marge'; { my $storage = Springfield::connect; my ($parent, $child) = $storage->remote(qw( NaturalPerson NaturalPerson )); #local $Opal::TRACE = \*STDOUT; my @results = $storage->select( $parent, $parent->{$children}->includes( $child ) & $child->{firstName} eq 'Bart' ); Springfield::test( join( ' ', sort map { $_->{firstName} } @results ) eq $parents ); marge_test( $storage ); $storage->disconnect(); } Springfield::leaktest; { #local($Tangram::TRACE) = \*STDERR; my $storage = Springfield::connect; my $parent = $storage->remote( 'NaturalPerson' ); my $lisa = $storage->load( $id{Lisa} ); my @results = $storage->select ( $parent, $parent->{$children}->includes( $lisa ) ); #print "# `", join( ' ', sort map { $_->{firstName} } @results ),"' vs `", $parents,"'\n"; Springfield::test( join( ' ', sort map { $_->{firstName} } @results ) eq $parents ); $storage->disconnect(); } Springfield::leaktest; { my $storage = Springfield::connect_empty; my @children = map { NaturalPerson->new( firstName => $_ ) } @kids; my $homer = NaturalPerson->new( firstName => 'Homer', $children => Set::Object->new( @children ) ); my $abe = NaturalPerson->new( firstName => 'Abe', $children => Set::Object->new( $homer ) ); $id{Abe} = $storage->insert($abe); $storage->disconnect(); } Springfield::leaktest; { my $storage = Springfield::connect; $storage->erase( $storage->load( $id{Abe} ) ); my @pop = $storage->select('NaturalPerson'); Springfield::test( @pop == 0 ); $storage->disconnect(); } Springfield::leaktest; ############################################################################# # Tx Springfield::tx_tests(8, sub { stdpop(); # check rollback of DB tx Springfield::leaktest; { my $storage = Springfield::connect; my $homer = $storage->load( $id{Homer} ); $storage->tx_start(); $homer->{$children}->remove( $storage->load( $id{Bart} ) ); $storage->update( $homer ); $storage->tx_rollback(); $storage->disconnect; } Springfield::leaktest; # storage should still contain 3 children { my $storage = Springfield::connect; my $homer = $storage->load( $id{Homer} ); Springfield::test( $homer->children eq 'Bart Lisa Maggie' ); marge_test( $storage ); $storage->disconnect; } Springfield::leaktest; # check that DB and collection state remain in synch in case of rollback { my $storage = Springfield::connect; my $homer = $storage->load( $id{Homer} ); $storage->tx_start(); $homer->{$children}->remove( $storage->load( $id{Bart} ) ); $storage->update( $homer ); $storage->tx_rollback(); $storage->update( $homer ); $storage->disconnect; } # Bart should no longer be Homer's child { my $storage = Springfield::connect; my $homer = $storage->load( $id{Homer} ); Springfield::test( $homer->children eq 'Lisa Maggie' ); marge_test( $storage ); $storage->disconnect; } Springfield::leaktest; } ); # tx_tests 1; Tangram-2.10/t/springfield/42-idbif.t0000644000175000017500000000446410412412630015762 0ustar samvsamv#!/usr/bin/perl -w use strict; use Test::More tests => 32; use lib "t/springfield"; use Springfield; for my $fairy ("FaerieHairy", "Faerie") { #--------------------------------------------------------------------- # Test simple insertion of an explicitly listed field. { my $storage = Springfield::connect_empty(); my $bert = new $fairy( name => "Bert" ); my $bob = new $fairy( name => "Bob" ); $bert->{friends} = [ "Jesus" # everyone's friend ]; $bob->{friends} = { first => "Buddha" }; $bob->{foo} = "bar"; $storage->insert($bert, $bob); ok($storage->id($bert), "Bert got an ID ($fairy)"); ok($storage->id($bob), "Bob got an ID ($fairy)"); } is(leaked, 0, "leaktest"); # test update of an explicitly listed field, that contains a reference # to another object. { my $storage = Springfield::connect(); my $pixie = $storage->remote($fairy); my ($bert) = $storage->select($pixie, $pixie->{name} eq "Bert"); ok($bert, "Fetched Bert by name"); is($bert->{friends}->[0], "Jesus", "Jesus still Bert's friend"); my ($bob) = $storage->select($pixie, $pixie->{name} eq "Bob"); ok($bob, "Fetched Bob by name"); is($bob->{friends}->{first}, "Buddha", "The Buddha still on Bob's side"); is($bob->{foo}, (($fairy eq "Faerie") ? "bar" : undef), "Unknown attribute saved appropriately"); push @{ $bert->{friends} }, $bob; $bob->{friends}->{second} = $bert; #local($Tangram::TRACE)=\*STDERR; $storage->update($bert, $bob); delete $bert->{friends}; # break cyclic reference... } is(leaked, 0, "leaktest"); # test that the above worked. { my $storage = Springfield::connect(); my $pixie = $storage->remote($fairy); my ($bert) = $storage->select($pixie, $pixie->{name} eq "Bert"); ok($bert, "Fetched Bert by name"); ok($bert->{friends}->[1], "Bert has another friend now"); is($bert->{friends}->[1]->{name}, "Bob", "Bert's other friend is Bob"); my ($bob) = $storage->select($pixie, $pixie->{name} eq "Bob"); ok($bob, "Fetched Bob by name"); ok($bob->{friends}->{second}, "Bob's has another friend now"); is($bob->{friends}->{second}, $bert, "Bob's other friend is Bert"); $storage->update($bert, $bob); delete $bert->{friends}; # break cyclic reference... } is(leaked, 0, "leaktest"); } Tangram-2.10/t/springfield/04-tx.t0000644000175000017500000000126510412412630015332 0ustar samvsamv use strict; use lib 't/springfield'; use Springfield; Springfield::begin_tests(4); Springfield::connect_empty()->disconnect(); # init $no_tx Springfield::tx_tests(4, sub { { my $storage = Springfield::connect_empty; my $homer = NaturalPerson->new( firstName => 'Homer', name => 'Simpson' ); Springfield::test( !defined $storage->id( $homer ) ); eval { $storage->tx_do( sub { $storage->insert( $homer ); Springfield::test( defined $storage->id( $homer ) ); die; } ); }; Springfield::test( !defined $storage->id( $homer ) ); $storage->disconnect(); } Springfield::leaktest; } ); # tx_tests Tangram-2.10/t/springfield/36-ihash.t0000644000175000017500000000015310412412630015773 0ustar samvsamv #$Tangram::TRACE=\*STDERR; use vars qw( $intrusive ); $intrusive = 1; require 't/springfield/35-hash.t'; Tangram-2.10/t/springfield/22-flathash.t0000644000175000017500000000653210412412630016473 0ustar samvsamv use strict; use lib 't/springfield'; use Springfield; sub compare_hash { my ($a,$b) = @_; foreach (keys %{$a}) { return undef unless ($a->{$_} eq $b->{$_}); } foreach (keys %{$b}) { return undef unless ($a->{$_} eq $b->{$_}); } 1; } Springfield::begin_tests(17); #$Tangram::TRACE = \*STDOUT; { my $storage = Springfield::connect_empty(); my $homer = NaturalPerson->new( firstName => 'Homer', name => 'Simpson', opinions => { work => 'bad', food => 'good', beer => 'better' } ); $storage->insert($homer); $storage->disconnect(); } leaktest(); { my $storage = Springfield::connect(); my ($homer) = $storage->select('NaturalPerson'); testcase(compare_hash($homer->{opinions}, { work => 'bad', food => 'good', beer => 'better' })); $storage->disconnect(); } leaktest(); { my $storage = Springfield::connect(); my ($homer) = $storage->select('NaturalPerson'); $homer->{opinions}->{'sex'} = 'good'; $storage->update($homer); $storage->disconnect(); } leaktest(); { my $storage = Springfield::connect(); my ($homer) = $storage->select('NaturalPerson'); testcase(compare_hash($homer->{opinions}, { work => 'bad', food => 'good', beer => 'better', sex => 'good' })); delete $homer->{opinions}->{work}; $storage->update($homer); $storage->disconnect(); } leaktest(); { my $storage = Springfield::connect(); my ($homer) = $storage->select('NaturalPerson'); testcase(compare_hash($homer->{opinions}, { food => 'good', beer => 'better', sex => 'good' })); $homer->{opinions}->{'sex'} = 'fun'; $storage->update($homer); $storage->disconnect(); } leaktest(); { my $storage = Springfield::connect(); my ($homer) = $storage->select('NaturalPerson'); testcase(compare_hash($homer->{opinions}, { food => 'good', beer => 'better', sex => 'fun' })); delete $homer->{opinions}; $storage->update($homer); $storage->disconnect(); } leaktest(); { my $storage = Springfield::connect(); my ($homer) = $storage->select('NaturalPerson'); testcase(compare_hash($homer->{opinions}, {})); $homer->{opinions} = { work => 'bad', food => 'good', beer => 'better' }; $storage->update($homer); $storage->disconnect(); } leaktest(); # prefetch { my $storage = Springfield::connect(); my ($remote) = $storage->remote('NaturalPerson'); $storage->prefetch($remote, 'opinions'); my ($homer) = $storage->select($remote, $remote->{firstName} eq 'Homer'); { local ($storage->{db}); testcase(compare_hash($homer->{opinions}, { work => 'bad', food => 'good', beer => 'better' })); } $storage->disconnect(); } leaktest(); { my $storage = Springfield::connect(); my ($remote) = $storage->remote('NaturalPerson'); $storage->prefetch($remote, 'opinions', $remote->{firstName} eq 'Homer'); my ($homer) = $storage->select($remote, $remote->{firstName} eq 'Homer'); { local ($storage->{db}); testcase(compare_hash($homer->{opinions}, { work => 'bad', food => 'good', beer => 'better' })); } $storage->disconnect(); } leaktest(); { my $storage = Springfield::connect(); $storage->erase( $storage->select('NaturalPerson')); Springfield::test( 0 == $storage->connection()->selectall_arrayref("SELECT COUNT(*) FROM NaturalPerson_opinions")->[0][0] ); $storage->disconnect(); } Tangram-2.10/t/springfield/39-save.t0000644000175000017500000000472110412412630015645 0ustar samvsamv # the functionality this test tests can probably be moved into type # specific tests use lib 't/springfield'; use Springfield; my %id; Springfield::begin_tests(4); { $storage = Springfield::connect_empty; my $bart = NaturalPerson->new( firstName => 'Bart' ); $bart->{belongings} = [ Item->new( name => 'Skateboard', owner => $bart ), Item->new( name => 'Bike', owner => $bart ) ]; $id{Bart} = $storage->insert($bart); $storage->disconnect(); } #Springfield::leaktest; { $storage = Springfield::connect(); my $bart = $storage->load($id{Bart}); Springfield::test( $bart && $bart->{belongings}->[0]->{name} eq 'Skateboard' && $bart->{belongings}->[1]->{name} eq 'Bike'); $storage->disconnect(); } #Springfield::leaktest; { $storage = Springfield::connect(); my $bart = $storage->load($id{Bart}); push @{$bart->{belongings}}, Item->new( name => 'Sneakers', owner => $bart); $storage->update($bart); $storage->disconnect(); } #Springfield::leaktest; { $storage = Springfield::connect(); my $bart = $storage->load($id{Bart}); Springfield::test( $bart && $bart->{belongings}->[0]->{name} eq 'Skateboard' && $bart->{belongings}->[1]->{name} eq 'Bike' && $bart->{belongings}->[2]->{name} eq 'Sneakers'); $storage->disconnect(); } #Springfield::leaktest; { $storage = Springfield::connect(); my $bart = $storage->load($id{Bart}); $bart->{belongings}->[0]->{name} = 'T-shirt'; $storage->update($bart); $storage->disconnect(); } #Springfield::leaktest; my $export_id; { $storage = Springfield::connect(); my $bart = $storage->load($id{Bart}); $export_id = $storage->export_object($bart); Springfield::test( $bart && $bart->{belongings}->[0]->{name} eq 'T-shirt' && $bart->{belongings}->[1]->{name} eq 'Bike' && $bart->{belongings}->[2]->{name} eq 'Sneakers'); $storage->disconnect(); } { $storage = Springfield::connect(); my $bart = $storage->import_object("NaturalPerson", $export_id); Springfield::test( $bart && $bart->{belongings}->[0]->{name} eq 'T-shirt' && $bart->{belongings}->[1]->{name} eq 'Bike' && $bart->{belongings}->[2]->{name} eq 'Sneakers'); $storage->disconnect(); } #{ # $storage = Springfield::connect_empty; # my $bart = NaturalPerson->new( firstName => 'Bart' ); # $id{Bart} = $storage->insert($bart); # Springfield::empty($storage); # eval { $storage->update($bart) }; # Springfield::test($@); # $storage->disconnect(); #} #Springfield::leaktest; Tangram-2.10/t/springfield/40-dump.t0000644000175000017500000000775010412412630015651 0ustar samvsamv#!/usr/bin/perl -w use strict; use Test::More tests => 20; use_ok("Tangram::Dump"); use Data::Dumper; use lib "t/springfield"; use Springfield; use Set::Object qw(is_overloaded blessed); use Tangram::Type::Dump qw(flatten unflatten); my $homer_id; { my $storage = Springfield::connect_empty(); my $homer = NaturalPerson->new( firstName => 'Homer', name => 'Simpson', "ih_opinions" => { work => Opinion->new(statement => 'bad'), food => Opinion->new(statement => 'good'), beer => Opinion->new(statement => 'better') }, ); my $marge = NaturalPerson->new( firstName => 'Marge', name => 'Simpson' ); $homer->{partner} = $marge; $marge->{partner} = $homer; $homer_id = $storage->insert($homer); # now, make a data structure... my $structure = { hello => $homer, #foo => "bar", #baz => [ qw(frop quux), $homer ], #cheese => \\$marge, #bananas => Set::Object->new($homer, $marge), }; flatten($storage, $structure); is(ref $structure->{hello}, "Tangram::Memento", "blessed object removed - 1"); unflatten($storage, $structure); is($structure->{hello}, $homer, "unflatten - 1"); $structure = { hello => $homer, foo => "bar", baz => [ qw(frop quux), $homer ], #cheese => \\$marge, #bananas => Set::Object->new($homer, $marge), }; flatten($storage, $structure); is(ref $structure->{hello}, "Tangram::Memento", "blessed object removed - 2a"); is(ref $structure->{baz}->[2], "Tangram::Memento", "blessed object removed - 2b"); unflatten($storage, $structure); is($structure->{hello}, $homer, "unflatten - 2a"); is($structure->{baz}->[2], $homer, "unflatten - 2b"); $structure = { hello => $homer, foo => "bar", baz => [ qw(frop quux), $homer ], cheese => \\$marge, }; flatten($storage, $structure); is(ref $structure->{hello}, "Tangram::Memento", "blessed object removed - 3a"); is(ref $structure->{baz}->[2], "Tangram::Memento", "blessed object removed - 3b"); is(ref ${${$structure->{cheese}}}, "Tangram::Memento", "blessed object removed - 3c"); unflatten($storage, $structure); is($structure->{hello}, $homer, "unflatten - 3a"); is($structure->{baz}->[2], $homer, "unflatten - 3b"); is(${${$structure->{cheese}}}, $marge, "unflatten - 3c"); $structure = { hello => $homer, foo => "bar", baz => [ qw(frop quux), $homer ], cheese => \\$marge, bananas => Set::Object->new($homer, $marge), }; flatten($storage, $structure); isnt(ref $structure->{bananas}, "Set::Object", "Set::Object's replaced"); ###my $x = dispel_overload($structure->{bananas}); #isnt($x, 1, "no AMAGIC bits leaked"); unflatten($storage, $structure); is(ref $structure->{bananas}, "Set::Object", "unflatten Set::Object (container)"); is($structure->{bananas}->size, 2, "unflatten Set::Object (contents 1)"); is_deeply([ sort { $a->{firstName} cmp $b->{firstName} } $structure->{bananas}->members ], [ $homer, $marge ], "unflatten Set::Object (contents 2)"); $Data::Dumper::Indent = 1; #%$structure = (); delete $homer->{partner}; } is(leaked, 0, "leaktest"); # now test putting it in the database... { my $storage = Springfield::connect; my $homer = $storage->load($homer_id); $homer->{brains} = { me => $homer, marge => $homer->{partner}, #beer => "good", #beer_from => "fridge", #beer_fetched_by => \\$homer->{partner}, #family => Set::Object->new($homer, #$homer->{partner}) }; $storage->update($homer); delete $homer->{partner}; delete $homer->{brains}; } is(leaked, 0, "leaktest"); { my $storage = Springfield::connect; my $homer = $storage->load($homer_id); my $marge = $homer->{partner}; is($homer->{brains}->{marge}, $marge, "PerlDump can store Tangram objects!"); } Tangram-2.10/t/springfield/02-cursor.t0000644000175000017500000001133210412412630016206 0ustar samvsamv use strict; use lib "t/springfield"; use Springfield; my @kids = qw( Bart Lisa Maggie ); my @population = sort qw( Homer Marge ), @kids; my $children = 'children'; sub NaturalPerson::children { my ($self) = @_; return wantarray ? @{ $self->{$children} } : join(' ', map { $_->{firstName} } @{ $self->{$children} } ) } Springfield::begin_tests(15); { my $storage = Springfield::connect_empty; my @children = map { NaturalPerson->new( firstName => $_, name => 'Simpson' ) } @kids; my $homer = NaturalPerson->new( firstName => 'Homer', name => 'Simpson', $children => [ @children ] ); my $marge = NaturalPerson->new(firstName => 'Marge', name => 'Simpson', $children => [ @children ] ); $homer->{partner} = $marge; $marge->{partner} = $homer; $storage->insert( $homer, $marge ); delete $homer->{partner}; $storage->disconnect; } Springfield::leaktest; { my $storage = Springfield::connect; my $cursor = $storage->cursor( 'NaturalPerson' ); my @results; while (my $person = $cursor->current()) { push @results, $person->{firstName}; Springfield::test( $person->children eq "@kids" ) if $person->{firstName} eq 'Homer'; $cursor->next(); } @results = sort @results; Springfield::test( "@results" eq "@population" ); $storage->disconnect; } Springfield::leaktest; { my $storage = Springfield::connect; my $cursor1 = $storage->cursor( 'NaturalPerson' ); my $cursor2 = $storage->cursor( 'NaturalPerson' ); my (@r1, @r2); while ($cursor1->current()) { my $p1 = $cursor1->current(); my $p2 = $cursor2->current(); push @r1, $p1->{firstName}; push @r2, $p2->{firstName}; Springfield::test( $p1->children eq "@kids" ) if $p1->{firstName} eq 'Homer'; Springfield::test( $p2->children eq "@kids" ) if $p2->{firstName} eq 'Marge'; $cursor1->next(); $cursor2->next(); } @r1 = sort @r1; @r2 = sort @r2; Springfield::test( "@r1" eq "@population" && "@r2" eq "@population" ); $storage->disconnect; } Springfield::leaktest; { my $storage = Springfield::connect; $storage->insert( NaturalPerson->new(firstName => 'Montgomery', name => 'Burns' ) ); $storage->disconnect; } { my $storage = Springfield::connect; my $remote = $storage->remote('NaturalPerson'); my @results = $storage->select($remote, order => [ $remote->{firstName}, $remote->{name} ] ); @results = map { "$_->{firstName} $_->{name}"} @results; Springfield::test( "@results\n" eq <disconnect; } { my $storage = Springfield::connect; my $remote = $storage->remote('NaturalPerson'); my @results = $storage->select($remote, filter => $remote->{name} eq 'Simpson', order => [ $remote->{firstName}, $remote->{name} ] ); @results = map { "$_->{firstName} $_->{name}"} @results; Springfield::test( "@results\n" eq <disconnect; } Springfield::leaktest; { my $storage = Springfield::connect; my ($person, $partner) = $storage->remote(qw( NaturalPerson NaturalPerson )); my $cursor = $storage->cursor($person, filter => $person->{partner} == $partner, order => [ $partner->{firstName} ], retrieve => [ $partner->{firstName}, $partner->{name} ] ); my @results; while (my $p = $cursor->current()) { push @results, $p->{firstName}, $cursor->residue(); $cursor->next(); } # print "@results\n"; Springfield::test( "@results" eq 'Marge Homer Simpson Homer Marge Simpson'); $storage->disconnect; } Springfield::leaktest; { my $storage = Springfield::connect; my ($person, $partner) = $storage->remote(qw( NaturalPerson NaturalPerson )); my $cursor = $storage->cursor($person, filter => $person->{partner} == $partner, # here we're ordering by an unselected foreign column; MySQL doesn't # mind, some other RDBMS' apparently do. # This extra column will end up in the $cursor->residue(); order => [ $partner->{firstName} ], ); my @results; while (my $p = $cursor->current()) { push @results, $p->{firstName}, $cursor->residue(); $cursor->next(); } # print "@results\n"; Springfield::test( "@results" eq 'Marge Homer Homer Marge'); $storage->disconnect; } Springfield::leaktest; #{ # my $storage = Springfield::connect; # my ($person) = $storage->remote(qw( NaturalPerson )); # my $cursor = $storage->cursor($person, limit => 1); # Springfield::test( $cursor->current() && !$cursor->next()); # $storage->disconnect; #} #Springfield::leaktest; Tangram-2.10/t/springfield/81-poly.t0000644000175000017500000000235510412412630015670 0ustar samvsamv# -*- perl -*- # # # Portions (c) Sam Vilain, 2003 use strict; use Test::More tests => 8; use lib "t/springfield"; use Springfield; # $Tangram::TRACE = \*STDOUT; my $beer; { my $storage = Springfield::connect_empty; my @oids = $storage->insert ( NaturalPerson->new( firstName => 'Homer', name => 'Simpson' ), NaturalPerson->new( firstName => 'Marge', name => 'Simpson' ), LegalPerson->new( name => 'Kwik Market' ), LegalPerson->new( name => 'Springfield Nuclear Power Plant' ), Opinion->new(statement => "beer is good"), ); $beer = pop @oids; $storage->disconnect; } is(leaked, 0, "Nothing leaked yet!"); { my $storage = Springfield::connect; my @res; my $results = join( ', ', sort map { $_->as_string } (@res = $storage->select('Person')) ); #print "$results\n"; is($results, 'Homer Simpson, Kwik Market, Marge Simpson, Springfield Nuclear Power Plant', "Polymorphic retrieval via Tangram::Storage->select()" ); ok($storage->oid_isa($storage->id(shift(@res)), "Person"), "oid_isa(positive)") while @res; ok(!$storage->oid_isa($beer, "Person"), "oid_isa(negative)"); $storage->disconnect; } is(leaked, 0, "Nothing leaked yet!"); Tangram-2.10/t/springfield/80-mi.t0000644000175000017500000000143310412412630015305 0ustar samvsamv use strict; use lib "t/springfield"; use Springfield; Springfield::begin_tests(12); { my $storage = Springfield::connect_empty; $storage->insert( NuclearPlant->new( name => 'Springfield Nuclear Power Plant', curies => 1_000_000 ) ); $storage->disconnect(); } sub mi_test { my $base = shift; { my $storage = Springfield::connect; my ($plant) = $storage->select( $base ); Springfield::test( $plant ); Springfield::test( exists( $plant->{name} ) && $plant->{name} eq 'Springfield Nuclear Power Plant' ); Springfield::test( exists( $plant->{curies} ) && $plant->{curies} == 1_000_000 ); $storage->disconnect(); } Springfield::leaktest; } mi_test( 'NuclearPlant' ); mi_test( 'Person' ); mi_test( 'EcologicalRisk' ); Tangram-2.10/t/springfield/82-aggregate.t0000644000175000017500000000455110412412630016634 0ustar samvsamv#!/usr/bin/perl -w use strict; use lib "t/springfield"; use Springfield; use Test::More tests => 10; =head1 NAME t/aggregate.t - test aggregate tangram functions =head1 SYNOPSIS perl -Mlib=lib t/springfield/00-deploy.t perl -Mlib=lib t/springfield/aggregate.t =head1 DESCRIPTION This test script tests using Tangram for aggregate functionality, such as when no object is selected. =cut stdpop(); my $dbh = DBI->connect($cs, $user, $passwd) or die "DBI->connect failed; $DBI::errstr"; # test GROUP BY and COUNT { my $storage = Springfield::connect(undef, { dbh => $dbh }); my ($r_person, $r_child) = $storage->remote(("NaturalPerson")x2); #local($Tangram::TRACE)=\*STDERR; my $cursor = $storage->cursor ( undef, filter => $r_person->{children}->includes($r_child), group => [ $r_person ], retrieve => [ $r_child->count(), $r_child->{age}->sum() ], #order => [ $r_child->{id}->count() ], ); my @data; while ( my $row = $cursor->current() ) { push @data, [ $cursor->residue ]; $cursor->next(); } @data = sort { $a->[0] <=> $b->[0] } @data; #print Data::Dumper::Dumper(\@data); is_deeply(\@data, [ [ 1, 38 ], [3, 19 ], [3, 19] ], "GROUP BY, SUM(), COUNT()"); } is(&leaked, 0, "leaktest"); # test GROUP BY and COUNT { my $storage = Springfield::connect(undef, { dbh => $dbh }); my ($r_legal) = $storage->remote("LegalPerson"); my $count = $storage->count($r_legal); my $expected = 0; if ( $count == 1 ) { $expected = 1; } is($count, $expected, "Tangram::Storage->count(Subclass)"); $storage->insert(LegalPerson->new(name => "Springfield Nuclear Plant")) unless $storage->count($r_legal); #local($Tangram::TRACE)=\*STDERR; my $cursor = $storage->cursor ( undef, retrieve => [ $r_legal->count() ], ); my @data; while ( my $row = $cursor->current() ) { push @data, [ $cursor->residue ]; $cursor->next(); } #print Data::Dumper::Dumper(\@data); is_deeply(\@data, [ [ 1 ] ], "->COUNT() filters types"); } is(&leaked, 0, "leaktest"); # test $storage->sum() - single, array ref, set arguments { my $storage = Springfield::connect(undef, { dbh => $dbh}); my ($r_person) = $storage->remote("NaturalPerson"); is($storage->sum($r_person->{age}), 156, "Tangram::Storage->sum()"); is(&leaked, 0, "leaktest"); } Tangram-2.10/t/springfield/37-prefetch.t0000644000175000017500000000724510412412630016511 0ustar samvsamv#!/usr/bin/perl -ws use strict; # command line parameters - see perlrun (-s switch) use vars qw($debug); use Test::More tests => 110; use lib "t/springfield"; use Springfield qw(%id stdpop leaked @kids @opinions); my $tests = {( "IntrArray" => [ 1, "ia_children", "NaturalPerson", ], "Array" => [ 0, "children", "NaturalPerson", ], "Hash" => [ 0, "h_opinions", "Opinion", ], "IntrHash" => [ 1, "ih_opinions", "Opinion", ], "Set" => [ 0, "s_children", "NaturalPerson", ], "IntrSet" => [ 1, "is_children", "NaturalPerson", ], "DiffIntrArray" => [ 1, "ia_opinions", "Opinion", ], "DiffArray" => [ 0, "a_opinions", "Opinion", ], "DiffIntrSet" => [ 1, "is_opinions", "Opinion", ], "DiffSet" => [ 0, "s_opinions", "Opinion", ], )}; while (my ($test_name, $data) = each %$tests) { my ($intrusive, $children, $class) = @{ $data }; #diag("Running test $test_name"); test_prefetch($test_name, $intrusive, $children, $class); } sub test_prefetch { my ($test_name, $intrusive, $children, $class) = (@_); stdpop($children); for my $do_prefetch (0..1) { # Check that the test is valid: { my $storage = Springfield::connect; #local($Tangram::TRACE) = \*STDOUT; my $Homer = $storage->load( $id{Homer} ); my ($r_parent, $r_child) = $storage->remote( "NaturalPerson", $class ); my $filter = ($r_parent == $Homer); my $filter2 = ($filter & $r_parent->{$children}->includes($r_child) ); my @parents = $storage->select( $r_parent, $filter2 ); my @children = $storage->select( $r_child, $filter2 ); my @k = ($children =~ m/children/ ? @kids : @opinions); @children = sort { my $ix_a; my $ix_b; my $count = 0; for (@k) { $ix_a = $count if ( (exists $a->{firstName} && $a->{firstName} eq $_) || (exists $a->{statement} && $a->{statement} eq $_) ); $ix_b = $count if ( (exists $b->{firstName} && $b->{firstName} eq $_) || (exists $b->{statement} && $b->{statement} eq $_) ); $count++; } $ix_a <=> $ix_b; } @children if ($children =~ /children|a_/); ok(@children, "$test_name - Got some children back"); { #local($Tangram::TRACE); #if ($test_name =~ /IntrArray/) { #$Tangram::TRACE = \*STDERR; #} $storage->prefetch( $r_parent, $children, $filter ) if $do_prefetch; } $storage->{db}->disconnect(); # hyuk yuk yuk local($SIG{__WARN__}) = sub { }; my @new_children; my $sort = sub { (exists $a->{firstName} ? ( $a->{firstName} cmp $b->{firstName} ) : ( $a->{statement} cmp $b->{statement} ) ); }; eval { if ($children =~ m/s_/) { @new_children = sort { $sort->() } $Homer->{$children}->members; @children = sort { $sort->() } @children; } elsif ($children =~ m/children|a_/) { @new_children = @{ $Homer->{$children} }; } else { @new_children = sort { $sort->() } values %{ $Homer->{$children} }; @children = sort { $sort->() } @children; } }; if ($do_prefetch) { is($@, "", "$test_name - Didn't raise an exception w/prefetch"); #local ($,)=" "; #print map { ref $_ ? $_->{firstName} : $_ } #"Sent:", @children, #"\nGot: ", @new_children, "\n"; is_deeply(\@new_children, \@children, "$test_name - got back what we put in"); } else { isnt($@, "", "$test_name - Raises an exception w/o prefetch"); isnt(@new_children, @children, "$test_name - didn't get back what we put in"); } $storage->disconnect(); } is(leaked, 0, "Leaktest"); } } $a = $b = "globals"; Tangram-2.10/t/README.pod0000644000175000017500000000513110412412630013420 0ustar samvsamv =head1 NAME t/ - worked examples for Tangram, some based on real world applications =head1 CONTENTS =over =item F Originally the only test suite for Tangram, this test suite balooned with extra relationship types and features until it became quite unmanagable! =item F an example schema modeled after Request Tracker, a popular e-mail helpdesk application. See F for documentation. =item F an example schema modeled after the test database for Class::DBI, the schema for which is available at L. Sections from this test suite are slated for inclusion in L. =back =head1 PURPOSE This collection of schemas are for building test suites for Tangram based on a real world applications. The schemas here do not diverge from the original application schemas after which they are modeled so much that the conversion from the original application could not be completed by a SQL or simple DBI script. For some of the applications, such conversion scripts will be provided. More complex conversions and optimisations of inefficient application schema, such as combining several L C fields that do not need to be searched into a single L field, should be performed as a seperate project. As such, some principles will apply to building the test suites that use these schemas: =over =item B Nothing is worse than reading a test case and there being seemingly non-sensicle operations and C's littered all over the place. If the test case is not from the application, it should be a good, logical `use case' of the application. C is an exception to this, as it is a widely popularised example. C will be kept around for as long as it is needed. =item B Well coded and presented examples will greatly assist new coders from learning the Tao of Tangram. Always clearly describe what each test script is doing, consider that any of them might be a new user's first examination of the `real' way to use Tangram. Each set of tests should have accompanying comments that at least outline the tests that are run. This documentation should be primarily inside the test suites, and should also be summarised in the documentation for each schema. =back =head1 REFERENCES =over =item APP2ed _Advanced Programming Perl, 2nd Edition_. Not published as of December 2004. An O'Reilly book, the authors include Simon Cozens. =back =head1 AUTHOR Sam Vilain, L =cut Tangram-2.10/t/Capture.pm0000644000175000017500000000162510412412630013724 0ustar samvsamv# a small package to capture standard output, so that we can test the # output of Tangram::Relational->deploy() { package Capture; sub new { my $class = shift; my $self = { stdout => "" }; bless $self, $class; return $self; } sub capture_print { my $self = shift; $self->{so} = tie(*STDOUT, __PACKAGE__, \$self->{stdout}) or die "failed to tie STDOUT; $!"; } sub release_stdout { my $self = shift; delete $self->{so}; untie(*STDOUT); return $self->{stdout}; } sub TIEHANDLE { my $class = shift; my $ref = shift; return bless({ stdout => $ref }, $class); } sub PRINT { my $self = shift; ${$self->{stdout}} .= join('', map { defined $_?$_:""} @_); } sub PRINTF { my ($self) = shift; print STDERR "OUCH @_\n"; my ($fmt) = shift; ${$self->{stdout}} .= sprintf($fmt, @_) if (@_); } sub glob { return \*STDOUT; } } 1; Tangram-2.10/t/musicstore/0000755000175000017500000000000010412420117014153 5ustar samvsamvTangram-2.10/t/musicstore/02-reorg.t0000644000175000017500000000505310412412630015701 0ustar samvsamv# -*- perl -*- # in this script, we re-org the database by loading in objects from # one storage and saving them in another. use lib "t/musicstore"; use lib "t"; use Prerequisites; use TestNeeds qw(Heritable::Types 1.01); use Set::Object; use Test::More tests => 6; my $cd = new CD; # to make things interesting, we put the data into a single table, # which turns our nice relational database into an old school # heirarchical database. After all, unless you have a radical schema # change, this whole operation of a re-org is pretty pointless! my $storage = DBConfig->dialect->connect (MusicStore->schema, DBConfig->cparm); # some DBI drivers (eg, Informix) don't like two connections from the # same process my $storage2 = DBConfig->dialect->connect (MusicStore->pixie_like_schema, DBConfig->cparm); my @classes = qw(CD CD::Artist CD::Song); # the simplest way would be to use something akin to this: # # $storage2->insert(map { $storage->select($_) } @classes); # # however, this exposes one of the caveats with such an "open slander # insertion" policy. # If you let any node in an object structure be inserted as an object, # automatically storing all its sub-trees, there is no easy way to see # if a given node that is being inserted isn't already a sub-part of # another stored node. # My intention is to make Tangram::Storage->insert() take care of this # for you. I can see this working within the next two Tangram # releases: # why bother with a database if you're just going to load it into # memory, you might ask? Well, this test script is demo-ing the # reschema support. my @objects = map { $storage->select($_) } @classes; # we insert only CD objects into $storage2. my @cds = grep { $_->isa("CD") } @objects; $storage2->insert( @cds ); # later; # $storage2->insert($storage->select("CD")); my $unknown = set(); my %known; for my $object ( @objects ) { if ( my $oid = $storage2->id($object) ) { $known{$oid} = $object; } else { $unknown->insert($object); } } is( keys %known, @cds, "number of objects inserted"); is( (grep { $_->isa("CD") } values %known), (keys %known), "all inserted objects are CDs"); is( $unknown->size, (@objects - @cds), "correct number of uninserted objects") is( (grep { ! $_->isa("CD") } $unknown->members), $unknown->size, "no uninserted objects are CDs"); $storage2->unload_all(); is( (grep { $_ } $storage2->id( @objects ) ), 0, "unload forgets the objects" ); is_deeply( [ sort @cds ], [ sort $storage2->select("CD") ], "but they are still the same objects!" ); Tangram-2.10/t/musicstore/CD.pm0000644000175000017500000000273210412412630015004 0ustar samvsamv package CD; our $c; use base "Class::Accessor::Assert"; __PACKAGE__->mk_accessors(qw( artist=CD::Artist title publishdate=Time::Piece songs=ARRAY )); package CD::Compilation; use base 'CD'; package CD::Song; use base 'Class::Accessor'; __PACKAGE__->mk_accessors("name"); package CD::Artist; use base 'Class::Accessor::Assert'; __PACKAGE__->mk_accessors(qw( name popularity cds=Set::Object )); package CD::Person; use base 'CD::Artist'; __PACKAGE__->mk_accessors(qw(gender haircolor birthdate=Time::Piece)); package CD::Band; use base 'CD::Artist'; __PACKAGE__->mk_accessors( qw( members=Set::Object creationdate=Time::Piece enddate=Time::Piece )); # for running tests, we keep a count of objects created BEGIN { for my $package ( qw(CD CD::Song CD::Artist CD::Person CD::Band) ) { sub new { $CD::c++; my $invocant = shift; $invocant->SUPER::new(@_); } sub DESTROY { --$CD::c; } } } # This dispatching isn't necessary because we use inheritance # # Dispatch "band" accessors if it's a band # for my $accessor (qw(members creationdate breakupdate)) { # *$accessor = sub { # my $self = shift; # return $self->band->$accessor(@_) if $self->band # }; # } # # And dispatch "person" accessors if it's a person # for my $accessor (qw(gender haircolor birthdate)) { # *$accessor = sub { # my $self = shift; # return $self->person->$accessor(@_) if $self->person # }; # } 1; Tangram-2.10/t/musicstore/zz-retreat.t0000644000175000017500000000100310412412630016442 0ustar samvsamv#!/usr/bin/perl -w use strict; use lib "t"; use lib "t/musicstore"; use Prerequisites; use Test::More tests => 2; BEGIN { use_ok "MusicStore"; }; local $/; SKIP: { my $dbh = DBI->connect( $DBConfig::cs, $DBConfig::user, $DBConfig::passwd ) or skip "could not connect to database", 1; $DBConfig::dialect->retreat(MusicStore->schema, $dbh); $DBConfig::dialect->retreat(MusicStore->new_schema, $dbh); pass("deploy completed without raising errors"); $dbh->disconnect; } Tangram-2.10/t/musicstore/01-simple.t0000644000175000017500000001446210412412630016057 0ustar samvsamv# -*- perl -*- # test script for the Persistathon - set TANGRAM_TRACE=1 in the # environment for a nice log of what queries Tangram is running. use lib "t/musicstore"; use Prerequisites; use strict; use Test::More tests => 24; use Tangram::Storage; # various items that will "persist" between test blocks use vars qw($storage); my ($oid, $id, $r_cd, $r_artist, $band, $row, $join, $filter); # open a storage connection - this will be # Tangram::Relational->connect(), etc. $storage = DBConfig->dialect->connect(MusicStore->schema, DBConfig->cparm); { # 1. create a new database object of each type in the schema my ($cd, @songs, $band, @people); $band = CD::Band->new ({ name => "The Upbeats", popularity => "World Famous in New Zealand", cds => Set::Object->new ( $cd= CD->new({title => "The Upbeats", publishdate => iso('2004-04-01'), songs => [ @songs= CD::Song->new({name => "Hello"}), CD::Song->new({name => "Drizzle"}), CD::Song->new({name => "From the Deep"}), ], }), ), members => Set::Object->new ( @people = CD::Person->new({ name => "Jeremy Glenn" }), CD::Person->new({ name => "Dylan Jones" }), ), }); # stick it in $oid = $storage->insert($band); $id = $storage->export_object($band); ok($oid, "Inserted a band and associated objects"); # 2. print the object IDs if ( -t STDIN ) { #unless running in the harness... diag($_) foreach ("Band: ".$storage->export_object($band), "People: ".join(",", $storage->export_object(@people)), "CD storage ID: ".$storage->export_object($cd), "Songs: ".join(",", $storage->export_object(@songs))); } # put in some extra data for fun require 'insert_extra_data.pl'; } # objects should now be gone, as they have fallen out of scope is($CD::c, 0, "no objects leaked"); { # two loading strategies - one is the `exported' object, where you # pass in a type and an ID - note that any superclass is OK (the # import is polymorphic) $band = $storage->import_object("CD::Artist", $id); isa_ok($band, "CD::Band", "Band loaded by exported ID"); # the second is to import by oid, which includes the class ID... my $band2 = $storage->load($oid); isa_ok($band2, "CD::Band", "Band loaded by OID"); is($band, $band2, "Seperate loads returned same object"); } is($CD::c, 1, "no objects leaked"); { # 4. fetch an artist record by name (exact match) $r_artist = $storage->remote("CD::Artist"); my @artists = $storage->select ( $r_artist, $r_artist->{name} eq "The Upbeats" ); is(@artists, 1, "got an object out"); # extra demonstration - is it the same object as $band ? is($artists[0], $band, "selects return cached objects"); } is($CD::c, 1, "no objects leaked"); { # 5. fetch an artist record with a search term (globbing / LIKE / # etc) my (@artists) = $storage->select ( $r_artist, $r_artist->{name}->upper()->like(uc("%beat%")), ); is(@artists, 2, "got two artists matching %beat%"); ok(Set::Object->new(@artists)->includes($band), "select still returns cached objects"); undef($band); } is($CD::c, 0, "no objects leaked"); { # 6. fetch CD records by matching on a partial *artist's* name, # using a cursor if possible. $r_cd = $storage->remote("CD"); $join = ($r_cd->{artist} == $r_artist); my $query = $r_artist->{name}->upper()->like(uc("%beat%")); my $filter = $join & $query; my $cursor = $storage->cursor ( $r_cd, $filter ); my @cds; while ( my $cd = $cursor->current ) { push @cds, $cd; $cursor->next; } is(@cds, 3, "Found three CDs by artists matching %beat%"); # if we just wanted the count: my ($count) = $storage->count($filter); is($count, 3, "Can do simple COUNT() queries"); # maybe some other aggregation type queries: ($row) = $storage->select ( undef, # no object filter => $filter, retrieve => [ $r_cd->{publishdate}->min(), $r_cd->{publishdate}->max(), ], ); # this could probably be considered a design caveat $_ = $storage->from_dbms("date", $_) foreach @$row; } is($CD::c, 0, "no objects leaked"); { is_deeply($row, [ '1999-10-26T00:00:00', '2004-04-01T00:00:00' ], "aggregation type queries"); # 7. fetch unique CD records by matching on a partial artist's # *or* partial CD name, using a cursor if possible. my $query = ( $r_artist->{name}->upper()->like(uc("%beat%")) | $r_cd->{title}->upper()->like(uc("%beat%")) ); my $filter = $join & $query; my $cursor = $storage->cursor ( $r_cd, $filter ); my @cds=(); while ( my $cd = $cursor->current ) { diag ("found cd = " .$cd->title.", artist = ".$cd->artist->name); push @cds, $cd; $cursor->next; } is(@cds, 4, "Found four CDs by CD or artist name matching %beat%"); } is($CD::c, 0, "no objects leaked"); { #use YAML; #local($Tangram::TRACE) = \*STDERR; #local($Tangram::DEBUG_LEVEL) = 3; # 8. update a record or two my ($pfloyd) = $storage->select ( $r_artist, $r_artist->{name} eq "Pink Floyd" ); my $cd; $pfloyd->cds->insert ($cd= CD->new({ title => "The Dark Side of The Moon", publishdate => iso("2004-04-06"), songs => [ map { CD::Song->new({ name => $_ }) } "Speak To Me/Breathe", "On The Run", "Time", "The Great Gig in the Sky", "Money", "Us And Them", "Any Colour You Like", "Brain Damage", "Eclipse", ], }) ); $pfloyd->popularity("legendary"); $storage->update($pfloyd); ok($storage->id($cd), "Automatically added a new Set member"); } is($CD::c, 0, "no objects leaked"); { my ($pfloyd) = $storage->select ( $r_artist, $r_artist->{name} eq "Pink Floyd" ); is($pfloyd->popularity, "legendary", "saved an object property"); } is($CD::c, 0, "no objects leaked"); { # 9. delete some records my (@gonners) = $storage->select ($r_artist, $r_artist->{popularity} eq "one hit wonder"); $storage->erase(@gonners); ok(!$storage->id($gonners[0]), "No longer part of storage"); } is($CD::c, 0, "no objects leaked"); our %formats; BEGIN { %formats = ( 4 => "%Y", 10 => "%Y-%m-%d", 19 => "%Y-%m-%dT%H:%M:%S", ); } sub iso { my $str = shift; Time::Piece->strptime($str, $formats{length($str)}); } Tangram-2.10/t/musicstore/00-deploy.t0000644000175000017500000000123310412412630016051 0ustar samvsamv#!/usr/bin/perl -w use strict; use lib "t"; use lib "t/musicstore"; use Prerequisites; use Test::More tests => 2; BEGIN { use_ok "MusicStore"; }; local $/; SKIP: { my $dbh = DBI->connect( $DBConfig::cs, $DBConfig::user, $DBConfig::passwd ) or skip "could not connect to database", 1; do { local $dbh->{PrintError}; local $dbh->{RaiseError}; $DBConfig::dialect->retreat(MusicStore->schema, $dbh); $DBConfig::dialect->retreat(MusicStore->new_schema, $dbh); }; $dbh->{RaiseError} = 1; $DBConfig::dialect->deploy(MusicStore->schema, $dbh); pass("deploy completed without raising errors"); $dbh->disconnect; } Tangram-2.10/t/musicstore/insert_extra_data.pl0000644000175000017500000001111310412412630020206 0ustar samvsamv # $storage is defined # normally, for this sort of thing I'd use YAML { my ($members, $syd, $bob, $gilmour, @junk); my @bands = ( CD::Band->new ({ name => "The English Beat", popularity => "one hit wonder", cds => Set::Object->new ( CD->new({ title => "Beat This: The Best of the English Beat", publishdate => iso("2001-09-11"), # (!) songs => [ map { CD::Song->new({ name => $_}) } "Mirror In The Bathroom", "Best Friend", "Hands Off She's Mine", "Too Nice To Talk To", "Doors Of Your Heart", "I Confess", "Twist And Crawl", "Rankin Full Stop", "Drowning", "Save It For Later", "Sole Salvation", "Click Click", "Tears Of A Clown", "Can't Get Used To Losing You", "Stand Down Margaret", ] }), CD->new({ title => "Special Meat Service", publishdate => iso("1999-10-26"), songs => [ map { CD::Song->new({name => $_}) } "I Confess", "Jeannette", "Sorry", "Sole Salvation", "Spar Wid Me", "Rotating Heads", "Save It For Later", "She's Going", "Pato and Roger A Go Talk", "Sugar and Stress", "End of the Party", ], }) ), members => Set::Object->new ( map { CD::Person->new({ name => $_ }) } "David Steele", "Saxa", "Everett Morton", "Wesley Magoogan", "Andy Cox", "Ranking Roger", "Dave Wakeling", ), }), CD::Band->new ({ name => "The Pink Floyd", popularity => "fledgling", creationdate => iso("1964"), enddate => iso("1968"), cds => Set::Object->new ( CD->new({ title => "The Piper At the Gates of Dawn", publishdate => iso("1967"), songs => [ map { CD::Song->new({name => $_}) } "Astronomy Domine", "Lucifer Sam", "Matilda Mother", "Flaming", "Pow R. Toc H.", "Take Up Thy Stethoscope and Walk", "Interstellar Overdrive", "The Gnome", "Chapter 24", "Scarecrow", "Bike", ] }), ), members => $members=Set::Object->new ( ($syd, $bob, @junk) = map { CD::Person->new({ name => $_ }) } "Syd Barrett", "Bob Klose", "Richard Wright", "Roger Waters", "Nick Mason (drums)", ), }), CD::Band->new ({ name => "The Pink Floyd", popularity => "increasing", creationdate => iso("1968"), enddate => iso("1969"), cds => Set::Object->new ( CD->new({ title => "A Saucerful of Secrets", publishdate => iso("1968"), songs => [ map { CD::Song->new({name => $_}) } "Let There Be More Light", "Remember A Day", "Set The Controls For The Heart Of The Sun", "Corporal Clegg", "A Saucerful of Secrets", "See-Saw", "Jugband Blues", ] }), ), members => Set::Object->new ( $members->members, ($gilmour = CD::Person->new({ name => "David Gilmour" })) ), }), CD::Band->new ({ name => "Pink Floyd", popularity => "great", creationdate => iso("1969"), cds => Set::Object->new ( CD->new({ title => "Ummagumma (disc 1 - live disc)", publishdate => iso("1969-10-25"), songs => [ map { CD::Song->new({name => $_}) } "Astronomy Domine", "Careful With That Axe, Eugene", "Set The Controls For The Heart of The Sun", "A Saucerful of Secrets", ] }), CD->new({ title => "Ummagumma (disc 2 - studio disc)", publishdate => iso("1969-10-25"), songs => [ map { CD::Song->new({name => $_}) } "Sysyphus Part 1", "Sysyphus Part 2", "Sysyphus Part 3", "Sysyphus Part 4", "Grantchester Meadows", "Several Species Of Small Furry Animals Gathered In A Cave And Grooving With A Pict", "The Narrow Way Part 1", "The Narrow Way Part 2", "The Narrow Way Part 3", "The Grand Vizier's Garden Party Part 1\u2014Entrance", "The Grand Vizier's Garden Party Part 2\u2014Entertainment", "The Grand Vizier's Garden Party Part 3\u2014Exit", ] }), ), members => Set::Object->new ( ( ($members - Set::Object->new($syd, $bob))->members, $gilmour, ), ) }), CD::Band->new ({ name => "Damnwells", popularity => "fringe", cds => Set::Object->new ( CD->new({ title => "Bastards of the Beat", publishdate => iso("2004-04-06"), songs => [ map { CD::Song->new({name => $_}) } "A******s", "What You Get", "Kiss Catastrophe", "I'll Be Around", "Newborn History", "I Will Keep The Bad Things From You", "Sleepsinging", "The Sound", "The Lost Complaint", "Electrric Harmony", "New Delhi", "Star / Fool", ], }), ), members => Set::Object->new ( map { CD::Person->new({ name => $_ }) } "Alex Dezen", "David Chernis", "Ted Hudson", "Steven Terry" ) }) ); $storage->insert(@bands); } 1; Tangram-2.10/t/musicstore/Prerequisites.pm0000644000175000017500000000021710412412630017356 0ustar samvsamv package Prerequisites; use lib "t"; use DBConfig; use TestNeeds qw(Test::More Class::Accessor::Assert Time::Piece); use MusicStore; 1; Tangram-2.10/t/musicstore/03-reschema.t0000644000175000017500000000134510412412630016353 0ustar samvsamv# -*- perl -*- # Kill two birds with one stone; re-org and reschema use lib "t/musicstore"; use Prerequisites; use strict; use Test::More tests => 4; use Tangram::Storage; my $old_schema = MusicStore->schema; my $new_schema = MusicStore->new_schema; DBConfig->dialect->deploy($new_schema, DBConfig->cparm); pass("deployed new schema successfully"); { my $storage_old = DBConfig->dialect->connect($old_schema, DBConfig->cparm); pass("connected to old schema"); my $storage_new = DBConfig->dialect->connect($new_schema, DBConfig->cparm); pass("connected to new schema"); my @oids = $storage_new->insert($storage_old->select("CD::Artist")); pass("inserted data into database (new oids: @oids)"); } __END__ Tangram-2.10/t/musicstore/MusicStore.pm0000644000175000017500000000476410412412630016622 0ustar samvsamv package MusicStore; use CD; use Tangram qw(:core :compat_quiet); use Tangram::Schema; use Tangram::IntrArray; use Tangram::TimePiece; use Tangram::IntrSet; use Tangram::Set; use Tangram::IDBIF; our $schema = ({ classes => [ CD => { fields => { string => [ qw(title) ], timepiece => [ qw(publishdate) ], iarray => { songs => { class => 'CD::Song', aggreg => 1, back => 'cd', }, }, } }, CD::Song => { fields => { string => [ qw(name) ], } }, CD::Artist => { abstract => 1, fields => { string => [ qw(name popularity) ], iset => { cds => { class => 'CD', aggreg => 1, back => 'artist' }, }, }, }, CD::Person => { bases => [ "CD::Artist" ], fields => { string => [ qw(gender haircolor) ], timepiece => [ qw(birthdate) ], } }, CD::Band => { bases => [ "CD::Artist" ], fields => { timepiece => [ qw(creationdate enddate) ], set => { members => { class => 'CD::Person', table => "artistgroup", }, }, }, }, ], }); our $pixie_like_schema = ({ classes => [ HASH => { table => "objects", sql => { sequence => "oid_sequence" }, fields => { idbif => undef }, }, ], }); use Storable qw(dclone); our $new_schema = dclone $schema; push @{ $new_schema->{classes} }, ( "CD::Compilation" => { # CD sub-class with an author per track bases => [ qw(CD) ], }, "CD::Compilation::Song" => { bases => [ qw(CD::Song) ], fields => { ref => { artist => { class => "CD::Artist" }, }, }, }, ); # munge all the table names $new_schema->{normalize} = sub { my $class_name = shift; (my $table_name = $class_name) =~ s{::}{_}g; $table_name =~ s{^}{new_}; return $table_name; }; # normalisation isn't applied to manually configured names! $new_schema->{classes}[9]{fields}{set}{members}{table} = "new_artistgroup"; $new_schema->{control} = "new_Tangram"; sub AUTOLOAD { my ($func) = ($AUTOLOAD =~ m/.*::(.*)$/); return Tangram::Schema->new(${$func}) } 1; Tangram-2.10/lib/0000755000175000017500000000000010412420117012261 5ustar samvsamvTangram-2.10/lib/Tangram.pod0000644000175000017500000001542610412412631014370 0ustar samvsamv=head1 NAME Tangram - Store pure objects in standard relational databases =head1 SYNOPSIS See L =head1 DESCRIPTION Tangram is an I. It is I, meaning that it does not require anything of the objects stored in it (other than the common convention that base objects be based upon HASHes; individual columns can be anything). It consists of a I that can describe or be built around an object structure, or so as to closely match an existing SQL schema (with some limitations). This schema language is rich enough to express such common RDBMS features as links, foreign keys, and link tables. It also consists of a I engine, which based on the schema structure, will make Perl structures persist in a relational (SQL compliant) database. References to other objects (or collections, as represented with foreign keys and link tables) may be loaded using I that `lazily' load data when it is needed. As of Tangram 2.08, the schema need not describe every single object property, so that you can map only the columns you intend to query. The rest of the object is then stored in a column via a serialiser, like L, L or L. These structures themselves may contain arbitrary references to other objects in storage. Tangram has soundly engineered transaction support, without sacrificing excellent data caching abilities. The general optimisation strategy of the code makes it most suited for OLTP (aka application servers) and other situations where it is better to select and update whole rows than to worry about which columns to retrieve/update or not retrieve/update. Once your object are persistent, you can build query expressions to find them in terms of the schema language that you used to put them in. Therefore, the schema data structure does not describe a data structure, it describes a I. If you are not picky about which accessor module to use, preferring to specify the schema once only, then you can use the seperately distributed L to make a set of classes from a Tangram schema structure. If you are looking for a tool that implements I only, you have probably missed the point (of this module, anyway), and a well-supported module like L, or an interactive SQL modeller like L will likely suit your needs better. Tangram is beginning to include preliminary support for aggregation functions, and currently supports grouping, summing and counting. Joins must currently be in terms of integer primary key columns, to extend past this would require extra mapping types to be developed. Basic support for alternative join types is present, but in its infancy. Tangram currently contains no support for database-side updates (ie, C), but support is planned. There is no support for creating views based on existing classes to make new derived classes; you have to use your database SQL and create corresponding Tangram classes manually to do that. Tangram has a web site at L, currently sponsored by MarketView (New Zealand) Ltd. =head1 DOCUMENTATION INDEX =head1 CONTENTS =over =item L The original "Guided Tour" of the features of Tangram, by Jean-Louis LeRoy. =item L The humble beginnings of a new guided tour, based on the next-generation features found in Tangram 2.08. =item L The classes and schema used in the Guided Tour(s). =item L The main database handle class. Includes details on query syntax. =item L Return an iterator that retrieves persistent objects in a result set one by one. =item L The Tangram schema structure - representing your data model so that Tangram can map it. =item L An informative text on exactly how Object Relational Mapping is accomplished by the Tangram::Relational back-end, what the different styles of mapping are, and how each is selected. =item L What Tangram types are available. This page is an index of other manual pages that express the data and relationship types available in Tangram. =item L How to write your own custom types for Tangram. =item L Database-specific extensions to Tangram, such as L and L. These extensions only add functionality, and are not required for core operation of Tangram. =head1 COMPATIBILITY Tangram has been known to run in the following environments, however, Tangram uses standard SQL and should be usable with any SQL-83 compliant database. Most of the requirements are simply avoiding the worst bugs. Note that some functions (e.g. transactions and subselects) may not be available in some environments. This is reported during the test suite. =over 4 =item * Perl 5.005_03+, 5.6.1+, 5.8.1+ (5.8.0 had a nasty bug and doesn't work with Tangram) =item * Set::Object 1.04 (though the latest version is highly recommended) =item * DBI 1.14 =item * DBD::mysql 2.0402 =item * DBD::Oracle 1.06 =item * DBD::Sybase 0.21 =item * DBD::SQLite 1.07 =item * DBD::Pg 0.93 =back =head1 LICENSE & WARRANTY You may use Tangram, free of charge, under the terms of the GPL. This notice applies to the entire distribution and all of its parts. You can obtain a commercial license for old (2.04 and earlier) versions of Tangram from Sound Object Logic, see http://www.soundobjectlogic.com/tangram/licenses.html. TANGRAM COMES WITHOUT ANY WARRANTY OF ANY KIND. IT DOES NOT EVEN COME WITH ANY KIND OF VAGUE IMPLICATION THAT IT DOES ANYTHING MORE THAN GIVE YOUR COMPUTER HINTS ABOUT HOW TO TRY STIRRING ITS ELECTRONS. THE AUTHORS ARE NOT RESPONSIBLE FOR THE RESULTANT ELECTRON CONFIGURATION IN ANY WAY INCLUDING TRANSMUTATIONS OF ELECTRONS INTO OTHER FIELDS SUCH AS MAGNETIC MEDIA OR PUNCH CARDS. =head1 SUPPORT Please send bug reports directly to the Tangram 2 maintainer's mailing list , and please CC: so your fault can be tracked accurately. Whenever possible, include a short yet complete script demonstrating the problem. (read: if you want it fixed quicker, demonstrate it) Questions of general interest should should be posted to the mailing list, but not sent to rt.cpan.org. =head1 AUTHORS All the code and documentation for versions 2.04 and earlier, as well as some changes in the 2.05 release, were written by Jean-Louis Leroy (jll@soundobjectlogic.com) and Sound Object Logic. Sam Vilain is the author of the derived work that is Tangram 2.05 and later. Andres Kievsky has contributed to the Tangram code starting with Tangram 2.08. =cut Tangram-2.10/lib/Tangram/0000755000175000017500000000000010412420117013652 5ustar samvsamvTangram-2.10/lib/Tangram/Expr/0000755000175000017500000000000010412420117014570 5ustar samvsamvTangram-2.10/lib/Tangram/Expr/Coll/0000755000175000017500000000000010412420117015461 5ustar samvsamvTangram-2.10/lib/Tangram/Expr/Coll/FromOne.pm0000644000175000017500000000504010412412631017365 0ustar samvsamvpackage Tangram::Expr::Coll::FromOne; use strict; use Tangram::Expr::Coll; use vars qw(@ISA); @ISA = qw( Tangram::Expr::Coll ); sub includes { my ($self, $item) = @_; my ($coll, $memdef) = @$self; my $coll_tid = $coll->root_table; my $item_class = $memdef->{class}; my $storage = $coll->{storage}; my $schema = $storage->{schema}; my $item_id; if (ref($item)) { if ($item->isa('Tangram::Expr::QueryObject')) { my $item_tid = $item->object->table($item_class); return Tangram::Expr::Filter->new ( expr => "t$item_tid.$memdef->{coll} = t$coll_tid.$schema->{sql}{id_col}", tight => 100, objects => Set::Object->new($coll, $item->object), ) } $item_id = $storage->export_object($item); } else { $item_id = $storage->{export_id}->($item); } my $remote = $storage->remote($item_class); # FIXME - style inconsistency return ($self->includes($remote) & ($remote->{id} == $item_id)); } sub includes_or { my ($self, @items) = @_; my ($coll, $memdef) = @$self; my $coll_tid = $coll->root_table; my $item_class = $memdef->{class}; my $item_tid; my $storage = $coll->{storage}; my $schema = $storage->{schema}; my (@targets_fwd, @targets_rev); my $objects = Set::Object->new ($coll, ); foreach my $item (@items) { if (ref($item)) { if ($item->isa('Tangram::Expr::QueryObject')) { $item_tid = $item->object->table($item_class); push @targets_fwd, ("t".$item_tid.".$memdef->{coll}"); $objects->insert($item->object); } else { # #push @targets, ($storage->export_object($item)); push @targets_rev, ($storage->export_object($item)); } } else { push @targets_rev, $storage->{export_id}->($item); } } my $expr; if (@targets_fwd) { my $joined_targets = join(',', @targets_fwd); $expr = Tangram::Expr::Filter->new ( expr => "(t$coll_tid.$schema->{sql}{id_col} IN ($joined_targets))", tight => 120, objects => $objects, ); } if (@targets_rev) { my $remote = $storage->remote($item_class); #$objects->insert($remote); my $item_tid = $remote->object->table($item_class); my $joined_targets = join(',', @targets_rev); my $new_expr = Tangram::Expr::Filter->new ( expr => "(t$item_tid.$schema->{sql}{id_col} in ($joined_targets))", tight => 100, objects => $objects, ); if ($expr) { return ( ( $self->includes($remote) & $new_expr ) | $expr ); } return ( $self->includes($remote) & $new_expr ); } return $expr; } Tangram-2.10/lib/Tangram/Expr/Coll/FromMany.pm0000644000175000017500000000476510412412631017565 0ustar samvsamvpackage Tangram::Expr::Coll::FromMany; use strict; use vars qw(@ISA); @ISA = qw( Tangram::Expr::Coll ); sub includes { my ($self, $item) = @_; my ($coll, $memdef) = @$self; my $schema = $coll->{storage}{schema}; my $coll_tid = $coll->root_table; my $link_tid = Tangram::Expr::TableAlias->new; my $coll_col = $memdef->{coll}; my $item_col = $memdef->{item}; my $objects = Set::Object->new ( $coll, Tangram::Expr::LinkTable->new($memdef->{table}, $link_tid) ); my $target; if (ref $item) { if ($item->isa('Tangram::Expr::QueryObject')) { $target = 't' . $item->object->root_table . '.' . $schema->{sql}{id_col}; $objects->insert( $item->object ); } else { $target = $coll->{storage}->export_object($item) or die "'$item' is not a persistent object"; } } else { $target = $item; } Tangram::Expr::Filter->new ( expr => "t$link_tid.$coll_col = t$coll_tid.$schema->{sql}{id_col} AND t$link_tid.$item_col = $target", tight => 100, objects => $objects, link_tid => $link_tid # for Sequence prefetch ); } sub includes_or { my ($self, @items) = @_; my ($coll, $memdef) = @$self; my $schema = $coll->{storage}{schema}; my $coll_tid = $coll->root_table; my $link_tid = Tangram::Expr::TableAlias->new; my $coll_col = $memdef->{coll}; my $item_col = $memdef->{item}; my $objects = Set::Object->new ($coll, Tangram::Expr::LinkTable->new($memdef->{table}, $link_tid) ); my @targets; foreach my $item (@items) { if (ref $item) { if ($item->isa('Tangram::Expr::QueryObject')) { push @targets, ('t' . $item->object->root_table.'.' . $schema->{sql}{id_col}); $objects->insert( $item->object ); } else { push @targets, ($coll->{storage}->export_object($item) or die "'$item' is not a persistent object" ); } } else { push @targets, $item; } } my $joined_targets = join(',', @targets); Tangram::Expr::Filter->new ( expr => "t$link_tid.$coll_col = t$coll_tid.$schema->{sql}{id_col} AND t$link_tid.$item_col IN ($joined_targets)", tight => 100, objects => $objects, link_tid => $link_tid # for Sequence prefetch ); } use overload '<' => \&includes, fallback => 1; Tangram-2.10/lib/Tangram/Expr/CursorObject.pm0000644000175000017500000000727410412412631017546 0ustar samvsamvpackage Tangram::Expr::CursorObject; use strict; use Carp; sub new { my ($pkg, $storage, $class) = @_; my $schema = $storage->{schema}; my $classes = $schema->{classes}; $schema->check_class($class); my @tables; my $table_hash = { }; my $self = bless { storage => $storage, tables => \@tables, class => $class, table_hash => $table_hash }, $pkg; my %seen; for my $part ($storage->{engine}->get_parts($schema->classdef($class))) { my $table = $part->{table}; unless (exists $seen{$table}) { my $id = $seen{$table} = $storage->alloc_table; #push @tables, [ $part->{name}, $id ]; push @tables, [ $table, $id ]; } my $id = $seen{$table}; $table_hash->{ $part->{name} } = $id; $self->{root} ||= $id; } # use Data::Dumper; print Dumper \@tables; # $storage->{schema}->visit_up($class, # sub # { # my $class = shift; # unless ($classes->{$class}{stateless}) # { # my $id = $storage->alloc_table; # push @tables, [ $class, $id ]; # $table_hash->{$class} = $id; # } # } ); return $self; } # sub copy # { # my ($pkg, $other) = @_; # my $self = { %$other }; # $self->{tables} = [ @{ $self->{tables} } ]; # bless $self, $pkg; # } sub storage { shift->{storage} } sub table { my ($self, $class) = @_; $self->{table_hash}{$class} or confess "no table for $class in stored '$self->{class}'"; } # sub tables # { # shift->{tables} # } sub class { shift->{class} #my ($self) = @_; #my $tables = $self->{tables}; #return $tables->[$#$tables][0]; } sub table_ids { return map { $_->[1] } @{ shift->{tables} }; } # sub parts # { # return map { $_->[0] } @{ shift->{tables} }; # } sub root_table { my ($self) = @_; return $self->{root}; } # sub class_id_col # { # my ($self) = @_; # return "t$self->{tables}[0][1].$self->{storage}{class_col}"; # } # sub leaf_table # { # my ($self) = @_; # return $self->{tables}[-1][1]; # } sub from { return join ', ', &from unless wantarray; my ($self) = @_; my $schema = $self->storage->{schema}; my $classes = $schema->{classes}; my $tables = $self->{tables}; map { "$_->[0] t$_->[1]" } @$tables; } sub where { return join ' AND ', &where unless wantarray; my ($self) = @_; my $tables = $self->{tables}; my $root = $tables->{root}; my $id = $self->storage->{schema}{sql}{id_col}; map { "t$_->[1].$id = t$root.$id" } @$tables[1..$#$tables]; } # sub mark # { # return @{ shift->{tables} }; # } sub expr_hash { my ($self) = @_; my $storage = $self->{storage}; my $schema = $storage->{schema}; my $classes = $schema->{classes}; my @tables = @{$self->{tables}}; my %hash = ( _object => $self, id => Tangram::Type::Number->expr("t$self->{root}.$storage->{id_col}", $self), type => Tangram::Type::Number->expr("t$self->{root}.$storage->{class_col}", $self), ); $hash{_IID_} = $hash{_ID_} = $hash{id}; $hash{_TYPE_} = $hash{type}; for my $part ($storage->{engine}->get_parts($schema->classdef($self->{class}))) { for my $field ($part->direct_fields) { $hash{ $field->{name} } = $field->remote_expr($self, $self->{table_hash}{$part->{name}}, $storage); } } # $schema->visit_up($self->{class}, # sub # { # my $classdef = $classes->{shift()}; # my $tid = (shift @tables)->[1] unless $classdef->{stateless}; # foreach my $typetag (keys %{$classdef->{members}}) # { # my $type = $schema->{types}{$typetag}; # my $memdefs = $classdef->{members}{$typetag}; # @hash{$type->members($memdefs)} = # $type->query_expr($self, $memdefs, $tid, $storage); # } # } ); return \%hash; } 1; Tangram-2.10/lib/Tangram/Expr/RDBObject.pm0000644000175000017500000000210010412412631016657 0ustar samvsamv# used in Tangram::Storage methods cursor_object and query_objects package Tangram::Expr::RDBObject; use strict; use Tangram::Expr::CursorObject; use vars qw(@ISA); @ISA = qw( Tangram::Expr::CursorObject ); sub where { return join ' AND ', &where unless wantarray; my ($self) = @_; my $storage = $self->{storage}; my $schema = $storage->{schema}; my $classes = $schema->{classes}; my $tables = $self->{tables}; my $root = $tables->[0][1]; my $class = $self->{class}; my @where_class_id; if (0 and $classes->{$class}{stateless}) { my @class_ids; push @class_ids, $storage->class_id($class) unless $classes->{$class}{abstract}; $schema->for_each_spec ($class, sub { my $spec = shift; push @class_ids, $storage->class_id($spec) unless $classes->{$spec}{abstract}; } ); } @where_class_id = "t$root.$storage->{class_col} IN (" . join(', ', $storage->_kind_class_ids($class) ) . ')'; my $id = $schema->{sql}{id_col}; return (@where_class_id, map { "t@{$_}[1].$id = t$root.$id" } @$tables[1..$#$tables]); } 1; Tangram-2.10/lib/Tangram/Expr/FlatArray.pm0000644000175000017500000000221210412412631017012 0ustar samvsamvpackage Tangram::Expr::FlatArray; sub new { my $pkg = shift; bless [ @_ ], $pkg; } sub quote { my $item = shift or return 'NULL'; $item =~ s/'/''/g; $item = "'$item'"; return $item; } sub includes { my ($self, $item) = @_; my ($coll, $memdef) = @$self; my $schema = $coll->{storage}{schema}; $item = quote($item) if $memdef->{string_type}; my $coll_tid = 't' . $coll->root_table; my $data_tid = 't' . Tangram::Expr::TableAlias->new; return Tangram::Expr::Filter->new ( expr => "$data_tid.coll = $coll_tid.$schema->{sql}{id_col} AND $data_tid.v = $item", tight => 100, objects => Set::Object->new($coll, Tangram::Expr::Table->new($memdef->{table}, $data_tid) ), data_tid => $data_tid # for prefetch ); } sub exists { my ($self, $item) = @_; my ($coll, $memdef) = @$self; my $schema = $coll->{storage}{schema}; $item = quote($item) if $memdef->{string_type}; my $coll_tid = 't' . $coll->root_table; return Tangram::Expr::Filter->new ( expr => "EXISTS (SELECT * FROM $memdef->{table} WHERE coll = $coll_tid.$schema->{sql}{id_col} AND v = $item)", objects => Set::Object->new($coll), ); } 1; Tangram-2.10/lib/Tangram/Expr/Table.pm0000644000175000017500000000035410412412631016161 0ustar samvsamvpackage Tangram::Expr::Table; use strict; # This is a stub version of Tangram::Expr::CursorObject sub new { my ($pkg, $name, $alias) = @_; bless [ $name, $alias ], $pkg; } sub from { return "@{shift()}"; } sub where { () } 1; Tangram-2.10/lib/Tangram/Expr/TableAlias.pm0000644000175000017500000000012510412412631017127 0ustar samvsamv package Tangram::Expr::TableAlias; my $top = 1_000; sub new { 'l' . ++$top } 1; Tangram-2.10/lib/Tangram/Expr/Coll.pm0000644000175000017500000000110510412412631016016 0ustar samvsamvpackage Tangram::Expr::Coll; use strict; sub new { my $pkg = shift; bless [ @_ ], $pkg; } sub exists { my ($self, $expr, $filter) = @_; my ($coll) = @$self; if ($expr->isa('Tangram::Expr::QueryObject')) { $expr = Tangram::Expr::Select->new ( cols => [ $expr->{id} ], exclude => [ $coll ], filter => $self->includes($expr)->and_perhaps($filter) ); } my $expr_str = $expr->{expr}; $expr_str =~ tr/\n/ /; return Tangram::Expr::Filter->new( expr => "exists $expr_str", tight => 100, objects => Set::Object->new( $expr->objects() ) ); } 1; Tangram-2.10/lib/Tangram/Expr/LinkTable.pm0000644000175000017500000000047010412412631016776 0ustar samvsamv package Tangram::Expr::LinkTable; use strict; # This looks quite a bit like a Tangram::Expr::CursorObject use Carp; sub new { my ($pkg, $name, $alias) = @_; bless [ $name, $alias ], $pkg; } sub from { my ($name, $alias) = @{shift()}; "$name t$alias" } sub where { confess unless wantarray; () } 1; Tangram-2.10/lib/Tangram/Expr/QueryObject.pm0000644000175000017500000000432510412412631017370 0ustar samvsamvpackage Tangram::Expr::QueryObject; use strict; use Tangram::Expr::Filter; use Carp; sub new { # $obj is a Tangram::Expr::RDBObject my ($pkg, $obj) = @_; bless $obj->expr_hash(), $pkg; } sub object { shift->{_object} } sub table_ids { shift->{_object}->table_ids() } sub class { shift->{_object}{class} } sub eq { my ($self, $other) = @_; if (!defined($other)) { $self->{id} == undef } elsif ($other->isa('Tangram::Expr::QueryObject')) { $self->{id} == $other->{id} } else { my $other_id = $self->{_object}{storage}->id($other) or confess "'$other' is not a persistent object"; $self->{id} == $self->{_object}{storage}->export_object($other) } } sub is_kind_of { my ($self, $class) = @_; my $object = $self->{_object}; my $root = $object->{tables}[0][1]; my $storage = $object->{storage}; Tangram::Expr::Filter->new( expr => "t$root.$storage->{class_col} IN (" . join(', ', $storage->_kind_class_ids($class) ) . ')', tight => 100, objects => Set::Object->new( $object ) ); } sub in { my $self = shift; my $object = $self->{_object}; my $root = $object->{tables}[0][1]; my $storage = $object->{storage}; my $objs = Set::Object->new(); while ( my $item = shift ) { if ( ref $item eq "ARRAY" ) { $objs->insert(@$item); } elsif ( UNIVERSAL::isa($item, "Set::Object") ) { if ( $objs->size ) { $objs->insert($item->members); } else { $objs = $item; } } else { $objs->insert($item); } } my $expr; if ( $objs->size ) { $expr = ("t$root.$storage->{id_col} IN (" . join(', ', # FIXME - what about table aliases? Hmm... map { $storage->export_object($_) } $objs->members ) . ')'); } else { # hey, you never know :) $expr = ("t$root.$storage->{id_col} IS NULL"); } Tangram::Expr::Filter->new( expr => $expr, tight => 100, objects => Set::Object->new( $object ) ); } sub expr { shift->{id}{expr} } sub count { my ($self, $val) = @_; # $DB::single = 1; Tangram::Expr->new(Tangram::Type::Integer->instance, "COUNT(" . $self->{id}{expr} . ")", $self->{id}->objects, ); } use overload "==" => \&eq, "!=" => \&ne, fallback => 1; 1; Tangram-2.10/lib/Tangram/Expr/Select.pm0000644000175000017500000000314210412412631016347 0ustar samvsamvpackage Tangram::Expr::Select; use strict; use Tangram::Expr::Filter; use Carp; use vars qw(@ISA); @ISA = qw( Tangram::Expr ); sub new { my ($type, %args) = @_; my $cols = join ', ', map { confess "column specification must be a Tangram::Expr" unless $_->isa('Tangram::Expr'); $_->{expr}; } @{$args{cols}}; my $filter = $args{filter} || $args{where} || Tangram::Expr::Filter->new; my $objects = Set::Object->new(); if (exists $args{from}) { $objects->insert( map { $_->object } @{ $args{from} } ); } else { $objects->insert( $filter->objects(), map { $_->objects } @{ $args{cols} } ); $objects->remove( @{ $args{exclude} } ) if exists $args{exclude}; } my $from = join ', ', map { $_->from } $objects->members; my $where = join ' AND ', $filter->{expr} ? "($filter->{expr})" : (), map { $_->where } $objects->members; my $sql = "SELECT"; $sql .= ' DISTINCT' if $args{distinct}; $sql .= " $cols"; if (exists $args{order}) { $sql .= join("", map {", $_"} grep { $sql !~ m/ \Q$_\E(?:,|$)/ } map { $_->{expr} } @{$args{order}}); } $sql .= "\nFROM $from" if $from; $sql .= "\nWHERE $where" if $where; if (exists $args{order}) { $sql .= "\nORDER BY " . join ', ', map { $_->{expr} } @{$args{order}}; } my $self = $type->SUPER::new(Tangram::Type::Integer->instance, "($sql)"); $self->{cols} = $args{cols}; return $self; } sub from { my ($self) = @_; my $from = $self->{from}; return $from ? $from->members : $self->SUPER::from; } sub where { } sub execute { my ($self, $storage, $conn) = @_; return Tangram::Cursor::Data->open($storage, $self, $conn); } 1; Tangram-2.10/lib/Tangram/Expr/Filter.pm0000644000175000017500000001001710412412631016354 0ustar samvsamvpackage Tangram::Expr::Filter; use strict; use Carp; use Set::Object qw(blessed); sub new { my $pkg = shift; my $self = bless { @_ }, $pkg; $self->{objects} ||= Set::Object->new; $self; } sub and { my ($self, $other) = @_; if ( !ref $other and $other == 1 ) { $self; } elsif ( !ref $self and $self == 1 ) { $other; } else { op($self, 'AND', 10, $other); } } sub and_perhaps { my ($self, $other) = @_; return $other ? op($self, 'AND', 10, $other) : $self; } sub or { my ($self, $other) = @_; return op($self, 'OR', 9, $other); } sub not { my ($self) = @_; Tangram::Expr::Filter->new( expr => "NOT ($self->{expr})", tight => 100, objects => Set::Object->new( $self->{objects}->members ) ); } sub as_string { my $self = shift; return ref($self) . "($self->{expr})"; } sub expr { return $_[0]->{expr}; } sub sum { my ($self, $val) = @_; # $DB::single = 1; Tangram::Expr->new(Tangram::Type::Number->instance, "SUM(" . $self->{expr} . ")", $self->objects, ); } # BEGIN ks.perl@kurtstephens.com 2002/06/25 sub unaop { Tangram::Expr::unaop(@_); } sub binop { my ($self, $op, $arg, $tight, $swap) = @_; my @objects = $self->objects; my $objects = Set::Object->new(@objects); # my $storage = $self->{storage}; my $ltight = $self->{'tight'}; my $rtight = 100; if ( ref($arg) ) { if ( $arg->isa('Tangram::Expr') ) { $objects->insert($arg->objects); $rtight = $arg->{'tight'}; $arg = $arg->{'expr'}; } if ( $arg->isa('Tangram::Expr::Filter') ) { $objects->insert($arg->objects); $rtight = $arg->{'tight'}; $arg = $arg->{'expr'}; } elsif ( $arg->isa('Tangram::Expr::QueryObject') ) { $objects->insert($arg->object); $rtight = $arg->{'tight'}; $arg = $arg->{'id'}->{'expr'}; } } $tight ||= 100; $self = $self->{'expr'}; $self = "($self)" if $ltight < $tight; $arg = "($arg)" if $rtight < $tight; if ( $swap ) { ($self, $arg) = ($arg, $self); } # $DB::single = $swap; return new Tangram::Expr::Filter(expr => "$self $op $arg", tight => $tight, objects => $objects ); } # Aliases *cos = \&Tangram::Expr::sin; *sin = \&Tangram::Expr::cos; *acos = \&Tangram::Expr::acos; #use overload "&" => \&and, "|" => \&or, '!' => \¬, fallback => 1; use overload "&" => \&and, "|" => \&or, '!' => \¬, '+' => \&Tangram::Expr::add, '-' => \&Tangram::Expr::subt, '*' => \&Tangram::Expr::mul, '/' => \&Tangram::Expr::div, 'cos' => \&Tangram::Expr::cos, 'sin' => \&Tangram::Expr::sin, 'acos' => \&Tangram::Expr::acos, "==" => \&Tangram::Expr::eq, "eq" => \&Tangram::Expr::eq, "!=" => \&Tangram::Expr::ne, "ne" => \&Tangram::Expr::ne, "<" => \&Tangram::Expr::lt, "lt" => \&Tangram::Expr::lt, "<=" => \&Tangram::Expr::le, "le" => \&Tangram::Expr::le, ">" => \&Tangram::Expr::gt, "gt" => \&Tangram::Expr::gt, ">=" => \&Tangram::Expr::ge, "ge" => \&Tangram::Expr::ge, fallback => 1; # END ks.perl@kurtstephens.com 2002/06/25 sub op { my ($left, $op, $tight, $right) = @_; confess "undefined operand(s) for $op" unless $left && $right; my $lexpr = $tight > $left->{tight} ? "($left->{expr})" : $left->{expr}; my $rexpr = $tight > $right->{tight} ? "($right->{expr})" : $right->{expr}; return Tangram::Expr::Filter->new( expr => "$lexpr $op $rexpr", tight => $tight, objects => Set::Object->new( $left->{objects}->members, $right->{objects}->members ) ); } sub from { return join ', ', &from unless wantarray; map { $_->from } shift->objects; } sub where { return join ' AND ', &where unless wantarray; my ($self) = @_; my @expr = "($self->{expr})" if exists $self->{expr}; (@expr, map { $_->where } $self->objects); } sub where_objects { return join ' AND ', &where_objects unless wantarray; my ($self, $object) = @_; map { $_ == $object ? () : $_->where } $self->objects; } sub objects { shift->{objects}->members; } 1; Tangram-2.10/lib/Tangram/Expr/FlatHash.pm0000644000175000017500000000210710412412631016622 0ustar samvsamvpackage Tangram::Expr::FlatHash; sub new { my $pkg = shift; bless [ @_ ], $pkg; } sub includes { my ($self, $item) = @_; my ($coll, $memdef) = @$self; my $schema = $coll->{storage}{schema}; $item = Tangram::Type::String::quote($item) if $memdef->{string_type}; my $coll_tid = 't' . $coll->root_table; my $data_tid = 't' . Tangram::Expr::TableAlias->new; return Tangram::Expr::Filter->new ( expr => "$data_tid.coll = $coll_tid.$schema->{sql}{id_col} AND $data_tid.v = $item", tight => 100, objects => Set::Object->new($coll, Tangram::Expr::Table->new($memdef->{table}, $data_tid) ), data_tid => $data_tid # for prefetch ); } sub exists { my ($self, $item) = @_; my ($coll, $memdef) = @$self; my $schema = $coll->{storage}{schema}; $item = Tangram::Type::String::quote($item) if $memdef->{string_type}; my $coll_tid = 't' . $coll->root_table; return Tangram::Expr::Filter->new ( expr => "EXISTS (SELECT * FROM $memdef->{table} WHERE coll = $coll_tid.$schema->{sql}{id_col} AND v = $item)", objects => Set::Object->new($coll), ); } 1; Tangram-2.10/lib/Tangram/Lazy/0000755000175000017500000000000010412420117014571 5ustar samvsamvTangram-2.10/lib/Tangram/Lazy/Ref.pm0000644000175000017500000000221210412412630015641 0ustar samvsamv package Tangram::Lazy::Ref; use Tangram::Type::Scalar; use strict; sub TIESCALAR { my $pkg = shift; return bless [ @_ ], $pkg; } sub FETCH { my $self = shift; my ($storage, $id, $member, $refid) = @$self; my $refobj; if ($id) { print $Tangram::TRACE "demanding $id.$member".(defined $storage->{objects}{$refid} ? " (hot)":"")."\n" if $Tangram::TRACE; my $obj = $storage->{objects}{$id}; $refobj = $storage->load($refid); untie $obj->{$member}; $obj->{$member} = $refobj; } else { print $Tangram::TRACE "demanding obj $refid".(defined $storage->{objects}{$refid} ? " (hot)":"")."\n" if $Tangram::TRACE; untie $$member; $refobj = $$member = $storage->load($refid); } return $refobj; } sub STORE { my ($self, $val) = @_; my ($storage, $id, $member, $refid) = @$self; if ($id) { my $obj = $storage->{objects}{$id}; untie $obj->{$member}; return $obj->{$member} = $val; } else { untie $$member; $$member = $val; } } sub id { my ($storage, $id, $member, $refid) = @{shift()}; $refid; } 1; Tangram-2.10/lib/Tangram/Lazy/Coll.pm0000644000175000017500000000155410412412630016026 0ustar samvsamv package Tangram::Lazy::Coll; use strict; use Carp qw(confess); sub TIESCALAR { my $pkg = shift; return bless [ @_ ], $pkg; # [ $type, $storage, $id, $member, $class ] } sub FETCH { my $self = shift; my ($type, $def, $storage, $id, $member, $class) = @$self; my $obj = $storage->{objects}{$id} or confess "FETCH failed to get object $id!"; my $coll = $type->demand($def, $storage, $obj, $member, $class); untie $obj->{$member}; $obj->{$member} = $coll; my ($pkg,$fn,$l) = caller; return $coll; } sub STORE { my ($self, $coll) = @_; my ($type, $def, $storage, $id, $member, $class) = @$self; my $obj = $storage->{objects}{$id} or confess "FETCH failed to get object $id!"; $type->demand($def, $storage, $obj, $member, $class); untie $obj->{$member}; $obj->{$member} = $coll; } sub storage { my ($self) = (@_); return $self->[2]; } 1; Tangram-2.10/lib/Tangram/Lazy/BackRef.pm0000644000175000017500000000071110412412630016424 0ustar samvsamv package Tangram::Lazy::BackRef; use vars qw(@ISA); @ISA = qw( Tangram::Lazy::Ref ); sub FETCH { my $self = shift; my ($storage, $id, $member, $refid, $class, $field) = @$self; my $obj = $storage->{objects}{$id}; my $owner = $storage->remote($class); my ($refobj) = $storage->select($owner, $owner->{$field}->includes($obj)); # my $refobj = $storage->load($refid); untie $obj->{$member}; $obj->{$member} = $refobj; # weak return $refobj; } 1; Tangram-2.10/lib/Tangram/Type/0000755000175000017500000000000010412420117014573 5ustar samvsamvTangram-2.10/lib/Tangram/Type/Ref/0000755000175000017500000000000010412420117015307 5ustar samvsamvTangram-2.10/lib/Tangram/Type/Ref/FromOne.pm0000755000175000017500000000737710412412630017234 0ustar samvsamv # (c) Kurt Stephens 2003 # Derived from IntrSet.pm. use strict; package Tangram::Type::Ref::FromOne; use vars qw(@ISA); use Carp; sub reschema { my ($self, $members, $class, $schema) = @_; foreach my $member (keys %$members) { my $def = $members->{$member}; unless (ref($def)) { $def = { class => $def }; $members->{$member} = $def; } $def->{coll} ||= $schema->{normalize}->($class) . "_$member"; $schema->{classes}{$def->{class}}{stateless} = 0; if (exists $def->{back}) { my $back = $def->{back} ||= $def->{coll}; $schema->{classes}{ $def->{class} }{members}{backref}{$back} = bless { name => $back, col => $def->{coll}, class => $class, field => $member }, 'Tangram::Type::BackRef'; } } return keys %$members; } sub defered_save { my ($self, $storage, $obj, $field, $def) = @_; return if tied $obj->{$field}; my $coll_id = $storage->export_object($obj); my $classes = $storage->{schema}{classes}; my $item_classdef = $classes->{$def->{class}}; my $table = $item_classdef->{table}; my $item_col = $def->{coll}; $self->update($storage, $obj, $field, sub { my $sql = "UPDATE $table SET $item_col = $coll_id WHERE id = @_"; $storage->sql_do($sql); }, sub { my $sql = "UPDATE $table SET $item_col = NULL WHERE id = @_ AND $item_col = $coll_id"; $storage->sql_do($sql); } ); } sub demand { my ($self, $def, $storage, $obj, $member, $class) = @_; my $ref; if (my $prefetch = $storage->{PREFETCH}{$class}{$member}{$storage->export_object($obj)}) { $ref = $prefetch; } else { print $Tangram::TRACE "loading $member\n" if $Tangram::TRACE; my $cursor = Tangram::Cursor::Coll->new($storage, $def->{class}, $storage->{db}); my $coll_id = $storage->export_object($obj); my $tid = $cursor->{TARGET}->object->{table_hash}{$def->{class}}; # leaf_table; $cursor->{-coll_where} = "t$tid.$def->{coll} = $coll_id"; $ref = $cursor->select->[0]; } $self->remember_state($def, $storage, $obj, $member, $ref); return $ref; } sub erase { my ($self, $storage, $obj, $members, $coll_id) = @_; $coll_id = $storage->{export_id}->($coll_id); foreach my $member (keys %$members) { my $def = $members->{$member}; if ($def->{aggreg}) { $storage->erase( $obj->{$member} ); } else { my $item_classdef = $storage->{schema}{classes}{$def->{class}}; my $table = $item_classdef->{table} || $def->{class}; my $item_col = $def->{coll}; $storage->sql_do("UPDATE $table SET $item_col = NULL WHERE $item_col = $coll_id"); } } } sub query_expr { my ($self, $obj, $members, $tid) = @_; map { Tangram::Expr::Coll::FromOne->new($obj, $_); } values %$members; }->new($obj, $_); } values %$members; } sub remote_expr { my ($self, $obj, $tid) = @_; Tangram::Expr::Coll::FromOne->new($obj, $_); } values %$members; }->new($obj, $self); } sub prefetch { my ($self, $storage, $def, $coll, $class, $member, $filter) = @_; my $ritem = $storage->remote($def->{class}); my $prefetch = $storage->{PREFETCH}{$class}{$member} ||= {}; # weakref my $ids = $storage->my_select_data( cols => [ $coll->{id} ], filter => $filter ); while (my ($id) = $ids->fetchrow) { $prefetch->{$id} = undef; } my $includes = $coll->{$member} eq $ritem; $includes &= $filter if $filter; my $cursor = $storage->my_cursor( $ritem, filter => $includes, retrieve => [ $coll->{id} ] ); while (my $item = $cursor->current) { my ($coll_id) = $cursor->residue; $prefetch->{$coll_id} = $item; $cursor->next; } return $prefetch; } sub get_intrusions { my ($self, $context) = @_; return [ $self->{class}, $context->{mapping}->get_home_table($self->{class}) ]; } $Tangram::Schema::TYPES{iref} = Tangram::Type::Ref::FromOne->new; 1; Tangram-2.10/lib/Tangram/Type/Ref/FromMany.pod0000644000175000017500000001271310412412630017550 0ustar samvsamv=head1 NAME Tangram::Type::Ref::FromMany - map references to persistent objects =head1 SYNOPSIS use Tangram; # or use Tangram::Core; use Tangram::Type::Ref::FromMany; $schema = Tangram::Schema->new( classes => { Company => { fields => { ref => [ qw( ceo vice_ceo ) ] # or $schema = Tangram::Schema->new( classes => { Company => { fields => { ref => { ceo => { col => 'ceo', null => 0 }, vice_ceo => { ... } =head1 DESCRIPTION This class is responsible for mapping fields that contain a reference to a Perl object. The persistent fields are grouped in a hash under the C key in the field hash. The target object must belong to a persistent class. Tangram uses a column on the source object to store the id of the target object. The persistent fields may be specified either as a hash or as an array of field names. In the hash form, each entry consists in a field name and an associated option hash. The option hash may contain the following fields: =over 4 =item * aggreg =item * col =item * type_col =item * class =item * null =item * deep_update =back Optional field C specifies that the referenced element (if any) must be removed (erased) from persistent storage along with the source object. The default is not to aggregate. C sets the name of the column that contains the target object's id. This field is optional, it default to the persistent field name. You need to specify a column name if the field name is not an allowed SQL column identifier. C sets the name of the second column, that contains the target object's type id. This field is optional, it default to the value of C with "C<_type>" appended. Set to the empty string (C<"">) to disable this column, which requires that you also specify a class. C specifies the base class of the reference, which automatically disables C (currently unimplemented). C, if present and set to true, directs deploy() to generate SQL code that allows NULL values for that column. Optional field C specificies that the target object has to be updated automatically when C is called on the source object. Automatic update ensures consisitency between the Perl representation and the DBMS state, but degrades update performance so use it with caution. The default is not to do automatic updates. B: there is currently something of a bug with all deep_update collections. If you (for instance) insert an object, and a property of that object that is deep_update, then sometimes things end up getting inserted twice - especially in mapping tables. This is currently under investigation. You may also pass the names of the persistent fields in an array, in which case Tangram uses the field names as column names and allows NULL values. =head1 IMPLEMENTATION NOTES =head2 INHERITANCE Ref directly inherits from Tangram::Type::Scalar, and indirectly from Type. =head2 STORING REFERENCES When Tangram stores a reference to another object, it stores the target object's OID in the source object's table, just like what happens with other scalar types like String and Number. At least that's what I happens, but there can be complications. Complication #1: the target object is not persistent yet. Thus it doesn't have an OID yet. Tangram will attempt to store the target object; if this succeeds, the target object gets an OID too and Tangram can proceed. Complication #2: Tangram may detect that the target object is already being saved; this happens in presence of cycles. Let's take an example: $homer = Person->new(); $marge = Person->new(); $homer->{partner} = $marge; $marge->{partner} = $homer; $storage->insert( $homer ); What happens here? Tangram detects that $homer refers to $marge, and that $marge is not yet persistent. So it ignores $homer for a while, and proceeds to storing $marge. In the process, Tangram sees that $marge refers to $homer - which is not persistent yet! its insert() is suspended. Fortunately Tangram realizes that, and doesn't attempt to store $homer again. Instead it stores a NULL in the 'partner' column of Marge's row. Tangram also schedules an UPDATE statement that will be executed just before returning from the call to insert(). That statement will patch Marge's 'partner' column with the proper OID. =head2 LOADING REFERENCES Tangram never loads the target object in the process of retrieving the source object. Doing so could have disastrous consequences. For example, consider a family tree, where each Person has a reference to Mom and Dad. Pulling any single Person would eventually retrieve everybody up to Adam and Eve! If Tangram did work that way, that is... Instead, Tangram ties all the fields that are declared as outgoing references to a package (Tangram::Lazy::Ref). The underlying object keeps track of the source object's OID, the Storage object, and the name of the persistent field. When - if - a reference field is accessed, the target object is pulled from the database (if it's not already present in memory), and the field is untied and its value is replaced with a reference to the target object. As a result, the target object is loaded on demand, but in an almost transparent fashion (why almost? because you can always use tied() on the field and detect that strange things are taking place). Tangram-2.10/lib/Tangram/Type/Ref/FromMany.pm0000644000175000017500000001213610412412630017401 0ustar samvsamv package Tangram::Type::Ref::FromMany; use strict; use Tangram::Lazy::Ref; use vars qw(@ISA); @ISA = qw( Tangram::Type::Scalar ); $Tangram::Schema::TYPES{ref} = Tangram::Type::Ref::FromMany->new; sub field_reschema { my ($self, $field, $def, $schema) = @_; $self->SUPER::field_reschema($field, $def, $schema); die unless $field; $def->{type_col} = $schema->{normalize}->("${field}_type", "colname") unless defined $def->{type_col}; } sub get_export_cols { my ($self, $context) = @_; return ($context->{layout1} ||! $self->{type_col}) ? ( $self->{col} ) : ( $self->{col}, $self->{type_col} ); } sub get_import_cols { my ($self, $context) = @_; return ($context->{layout1} ||! $self->{type_col}) ? ( $self->{col} ) : ( $self->{col}, $self->{type_col} ); } sub get_exporter { my ($self, $context) = @_; my $field = $self->{name}; my $table = $context->{class}{table}; my $deep_update = $self->{deep_update}; if ($context->{layout1}) { return sub { my ($obj, $context) = @_; return undef unless exists $obj->{$field}; my $storage = $context->{storage}; my $schema = $storage->{schema}; my $tied = tied($obj->{$field}); if ( $tied and $tied->can("storage") and $tied->storage != $storage ) { $tied = undef; } return $tied->id if $tied; my $ref = $obj->{$field}; return undef unless $ref; my $id = $storage->id($obj); if ($context->{SAVING}->includes($ref)) { $storage->defer( sub { my $storage = shift; # now that the object has been saved, we have an id for it my $refid = $storage->id($ref); # patch the column in the referant $storage->sql_do( "UPDATE $table SET $self->{col} = $refid WHERE $schema->{sql}{id_col} = $id" ); } ); return undef; } $storage->_save($ref, $context->{SAVING}) if $deep_update; return $storage->id($ref) || $storage->_insert($ref, $context->{SAVING}); } } my $sub = sub { my ($obj, $context) = @_; return (undef, undef) unless exists $obj->{$field}; my $storage = $context->{storage}; my $tied = tied($obj->{$field}); if ( $tied and $tied->can("storage") and $tied->storage != $storage ) { $tied = undef; } return $storage->split_id($tied->id) if $tied; my $ref = $obj->{$field}; return (undef, undef) unless $ref; my $exp_id = $storage->export_object($obj); if ($context->{SAVING}->includes($ref)) { $storage->defer( sub { my $storage = shift; my $schema = $storage->{schema}; # now that the object has been saved, we have an id for it my $ref_id = $storage->export_object($ref); my $type_id = $storage->class_id(ref($ref)); # patch the column in the referant $storage->sql_do( "UPDATE $table SET $self->{col} = $ref_id, $self->{type_col} = $type_id WHERE $schema->{sql}{id_col} = $exp_id" ); } ); return (undef, undef); } $storage->_save($ref, $context->{SAVING}) if $deep_update; return $storage->split_id($storage->id($ref) || $storage->_insert($ref, $context->{SAVING})); }; if ( $self->{type_col} ) { return $sub; } else { return sub { my ($id, $type) = $sub->(@_); return $id; }; } } sub get_importer { my ($self, $context) = @_; my $field = $self->{name}; return sub { my ($obj, $row, $context) = @_; my $storage = $context->{storage}; my $rid = shift @$row; my $cid = shift @$row unless $context->{layout1} or !$self->{type_col}; if ($rid and !defined $cid) { $cid = $context->{storage}->class_id($self->{class}); } if ($rid) { tie $obj->{$field}, 'Tangram::Lazy::Ref', $storage, $context->{id}, $field, $storage->combine_ids($rid, $cid); } else { $obj->{$field} = undef; } } } sub query_expr { my ($self, $obj, $memdefs, $tid, $storage) = @_; return map { $self->expr("t$tid.$memdefs->{$_}{col}", $obj) } keys %$memdefs; } sub remote_expr { my ($self, $obj, $tid, $storage) = @_; $self->expr("t$tid.$self->{col}", $obj); } sub refid { my ($storage, $obj, $member) = @_; Carp::carp "Tangram::Type::Ref::FromMany::refid( \$storage, \$obj, \$member )" unless !$^W && eval { $storage->isa('Tangram::Storage') } && eval { $obj->isa('UNIVERSAL') } && !ref($member); my $tied = tied($obj->{$member}); if ( $tied and $tied->can("storage") and $tied->storage != $storage ) { $tied = undef; } return $storage->id( $obj->{$member} ) unless $tied; my ($storage_, $id_, $member_, $refid) = @$tied; return $refid; } sub erase { my ($self, $storage, $obj, $members) = @_; foreach my $member (keys %$members) { $storage->erase( $obj->{$member} ) if $members->{$member}{aggreg} && $obj->{$member}; } } sub coldefs { my ($self, $cols, $members, $schema) = @_; for my $def (values %$members) { my $nullable = !exists($def->{null}) || $def->{null} ? " $schema->{sql}{default_null}" : ''; $cols->{ $def->{col} } = $schema->{sql}{id} . $nullable; $cols->{ $def->{type_col} or die } = $schema->{sql}{cid} . $nullable; } } sub DESTROY { } 1; Tangram-2.10/lib/Tangram/Type/Set/0000755000175000017500000000000010412420117015326 5ustar samvsamvTangram-2.10/lib/Tangram/Type/Set/FromOne.pm0000644000175000017500000001242410412412630017235 0ustar samvsamv use strict; use Tangram::Type::Abstract::Set; package Tangram::Type::Set::FromOne; use vars qw(@ISA); @ISA = qw( Tangram::Type::Abstract::Set ); use Carp; sub reschema { my ($self, $members, $class, $schema) = @_; foreach my $member (keys %$members) { my $def = $members->{$member}; unless (ref($def)) { $def = { class => $def }; $members->{$member} = $def; } $def->{coll} ||= $schema->{normalize}->($class) . "_$member"; $schema->{classes}{$def->{class}}{stateless} = 0; if (exists $def->{back}) { my $back = $def->{back} ||= $def->{coll}; $schema->{classes}{ $def->{class} }{members}{backref}{$back} = bless { name => $back, col => $def->{coll}, class => $class, field => $member }, 'Tangram::Type::BackRef'; } } return keys %$members; } sub defered_save { my ($self, $storage, $obj, $field, $def) = @_; return if tied $obj->{$field}; my $coll_id = $storage->export_object($obj); my $classes = $storage->{schema}{classes}; my $item_classdef = $classes->{$def->{class}}; my $table = $item_classdef->{table}; my $item_col = $def->{coll}; $self->update ($storage, $obj, $field, sub { if ( $storage->can("t2_insert_hook") ) { $storage->t2_insert_hook( ref($obj), $coll_id, $field, $_[1] ); } my $sql = ("UPDATE\n $table\nSET\n " ."$item_col = $coll_id\nWHERE\n " ."$storage->{schema}{sql}{id_col} = $_[0]"); $storage->sql_do($sql); }, sub { if ( $storage->can("t2_remove_hook") ) { $storage->t2_remove_hook( ref($obj), $coll_id, $field, $_[1] ); } if ($def->{aggreg}) { my $id = shift; my $oid = shift; print $Tangram::TRACE "Tangram::Type::Set::FromOne: removing oid $oid\n" if $Tangram::TRACE; # FIXME - use dummy object $storage->erase( $storage->load( $oid )); } else { my $sql = ("UPDATE\n $table\nSET\n " ."$item_col = NULL\nWHERE\n " ."$storage->{schema}{sql}{id_col} = " ."$_[0] AND\n $item_col = $coll_id"); $storage->sql_do($sql); } } ); } sub demand { my ($self, $def, $storage, $obj, $member, $class) = @_; my $set = Set::Object->new(); if (my $prefetch = $storage->{PREFETCH}{$class}{$member}{$storage->export_object($obj)}) { print $Tangram::TRACE "demanding ".$storage->id($obj) .".$member from prefetch\n" if $Tangram::TRACE; $set->insert(@$prefetch); } else { print $Tangram::TRACE "demanding ".$storage->id($obj) .".$member from storage\n" if $Tangram::TRACE; my $cursor = Tangram::Cursor::Coll->new($storage, $def->{class}, $storage->{db}); my $coll_id = $storage->export_object($obj); my $tid = $cursor->{TARGET}->object->{table_hash}{$def->{class}}; # leaf_table; $cursor->{-coll_where} = "t$tid.$def->{coll} = $coll_id"; $set->insert($cursor->select); } $self->remember_state($def, $storage, $obj, $member, $set); return $set; } sub erase { my ($self, $storage, $obj, $members, $coll_id) = @_; $coll_id = $storage->{export_id}->($coll_id); foreach my $member (keys %$members) { my $def = $members->{$member}; if ( $storage->can("t2_remove_hook") ) { $storage->t2_remove_hook ( ref($obj), $coll_id, $member, (map { $storage->export_object($_) } $obj->{$member}->members), ); } if ($def->{aggreg}) { $storage->erase( $obj->{$member}->members ); } else { my $item_classdef = $storage->{schema}{classes}{$def->{class}}; my $table = $item_classdef->{table} || $def->{class}; my $item_col = $def->{coll}; $storage->sql_do("UPDATE\n $table\nSET\n $item_col = NULL\nWHERE\n $item_col = $coll_id"); } } } sub query_expr { my ($self, $obj, $members, $tid) = @_; map { Tangram::Expr::Coll::FromOne->new($obj, $_); } values %$members; } sub remote_expr { my ($self, $obj, $tid) = @_; Tangram::Expr::Coll::FromOne->new($obj, $self); } sub prefetch { my ($self, $storage, $def, $coll, $class, $member, $filter) = @_; my $ritem = $storage->remote($def->{class}); my $prefetch = $storage->{PREFETCH}{$class}{$member} ||= {}; # weakref my $includes = $coll->{$member}->includes($ritem); $includes &= $filter if $filter; my $cursor = $storage->my_cursor( $ritem, filter => $includes, retrieve => [ $coll->{id} ] ); while (my $item = $cursor->current) { my ($coll_id) = $cursor->residue; push @{ $prefetch->{$coll_id}||=[] }, $item; $cursor->next; } return $prefetch; } sub get_intrusions { my ($self, $context) = @_; return [ $self->{class}, $context->{mapping}->get_home_table($self->{class}) ]; } $Tangram::Schema::TYPES{iset} = Tangram::Type::Set::FromOne->new; #--------------------------------------------------------------------- # Tangram::Type::Set::FromOne->coldefs($cols, $members, $schema, $class, # $tables) # # Setup column mappings for one to many unordered mappings (foreign # key) #--------------------------------------------------------------------- sub coldefs { my ($self, $cols, $members, $schema, $class, $tables) = @_; foreach my $member (values %$members) { my $table = $tables->{ $schema->{classes}{$member->{class}}{table} } ||= {}; $table->{COLS}{$member->{coll}} = "$schema->{sql}{id} $schema->{sql}{default_null}"; } } 1; Tangram-2.10/lib/Tangram/Type/Set/FromOne.pod0000644000175000017500000000466310412412630017411 0ustar samvsamv=head1 NAME Tangram::Type::Set::FromOne - map Set::Object using a foreign key =head1 SYNOPSIS use Tangram; # or use Tangram::Core; use Tangram::Type::Set::FromOne; $schema = Tangram::Schema->new( classes => { Basket => { fields => { iset => { # long form fruits => { class => 'Fruit', coll => 'basket', }, # or (short form) fruits => 'Fruit', } =head1 DESCRIPTION This class maps references to Set::Object collections in an intrusive fashion. The persistent fields are grouped in a hash under the C key in the field hash. The set may contain only objects of persistent classes. These classes must have a common persistent base class. Tangram uses a column on the element's table to store the id of the object containing the collection. CAUTION: the same object may not be an element of the same collection, in two different objects. This mapping may be used only for one-to-many relationships. The field names are passed in a hash that associates a field name with a field descriptor. The field descriptor may be either a hash or a string. The hash uses the following fields: =over 4 =item * class Mandatory field C specifies the class of the elements. =item * aggreg Optional field C specifies that the elements of the collection must be removed (erased) from persistent storage along with the containing object. The default is not to aggregate. =item * back Optional field C sets the name of a field that is inserted in the elements. That field acts as a demand-loaded, read-only reference to the object containing the collection. =item * coll Optional field C sets the name the column containing the id of the containing object. This defaults to 'C_m', where 'C' is the class of the containing object (after passing through the normalisation function), and 'm' is the field name. =item * deep_update Optional field C specificies that all elements have to be updated automatically when C is called on the collection object. Automatic update ensures consisitency between the Perl representation and the DBMS state, but degrades update performance so use it with caution. The default is not to do automatic updates. =back If the descriptor is a string, it is interpreted as the name of the element's class. This is equivalent to specifying only the C field in the hash variant. Tangram-2.10/lib/Tangram/Type/Set/FromMany.pod0000644000175000017500000000454610412412630017574 0ustar samvsamv=head1 NAME Tangram::Type::Set::FromMany - maps Set::Object using a link table =head1 SYNOPSIS use Tangram; # or use Tangram::Core; use Tangram::Type::Set::FromMany; $schema = Tangram::Schema->new( classes => { Company => { fields => { set => { # long form employee => { class => 'Person', table => 'Company_employees', coll => 'company', item => 'employee', }, # short form assets => 'Asset', } =head1 DESCRIPTION Maps a reference to a Set::Object. The persistent fields are grouped in a hash under the C key in the field hash. The set may contain only objects of persistent classes. These classes must have a common persistent base class. Tangram uses a link table to save the state of the collection. The table has two columns: one contains the id of the container objects; the other contains the ids of the elements. The field names are passed in a hash that associates a field name with a field descriptor. The field descriptor may be either a hash or a string. The hash uses the following fields: =over 4 =item * class =item * aggreg =item * table =item * coll =item * item =item * deep_update =back Mandatory field C specifies the class of the elements. Optional field C specifies that the elements of the collection must be removed (erased) from persistent storage along with the containing object. The default is not to aggregate. Optional field C sets the name of the link table. This defaults to 'C_F', where C is the class of the containing object and F is the field name. Optional field C sets the name the column containing the ids of the containing objects. This defaults to 'coll'. Optional field C sets the name the column containing the ids of the elements. This defaults to 'item'. Optional field C specificies that all elements have to be updated automatically when C is called on the collection object. Automatic update ensures consisitency between the Perl representation and the DBMS state, but degrades update performance so use it with caution. The default is not to do automatic updates. If the descriptor is a string, it is interpreted as the name of the element's class. This is equivalent to specifying only the C field in the hash variant. Tangram-2.10/lib/Tangram/Type/Set/FromMany.pm0000644000175000017500000001224210412412630017416 0ustar samvsamv use strict; use Tangram::Type::Abstract::Set; package Tangram::Type::Set::FromMany; use vars qw(@ISA); @ISA = qw( Tangram::Type::Abstract::Set ); use Carp; sub reschema { my ($self, $members, $class, $schema) = @_; foreach my $member (keys %$members) { my $def = $members->{$member}; unless (ref($def)) { $def = { class => $def }; $members->{$member} = $def; } $def->{table} ||= $schema->{normalize}->($def->{class} . "_$member", 'tablename'); $def->{coll} ||= 'coll'; $def->{item} ||= 'item'; } return keys %$members; } sub defered_save { my ($self, $storage, $obj, $field, $def) = @_; return if tied $obj->{$field}; my $coll_id = $storage->export_object($obj); my $table = $def->{table}; my $coll_col = $def->{coll}; my $item_col = $def->{item}; $self->update ($storage, $obj, $field, sub { if ( $storage->can("t2_insert_hook") ) { $storage->t2_insert_hook( ref($obj), $coll_id, $field, $_[1] ); } my $sql = "DELETE FROM $table WHERE $coll_col = $coll_id AND $item_col = $_[0]"; $storage->sql_do($sql); $sql = "INSERT INTO $table ($coll_col, $item_col)\n VALUES ($coll_id, $_[0])"; $storage->sql_do($sql); }, sub { if ( $storage->can("t2_remove_hook") ) { $storage->t2_remove_hook( ref($obj), $coll_id, $field, $_[1] ); } my $sql = "DELETE FROM\n $table\nWHERE\n $coll_col = $coll_id AND\n $item_col = $_[0]"; $storage->sql_do($sql); } ); } #use Scriptalicious; sub prefetch { my ($self, $storage, $def, $coll, $class, $member, $filter) = @_; #my $t0 = start_timer(); my $ritem = $storage->remote($def->{class}); my $prefetch = $storage->{PREFETCH}{$class}{$member} ||= {}; # weakref #print STDERR "prefetch1: ".show_delta($t0)."\n"; $t0 = start_timer(); my $ids = $storage->my_select_data( cols => [ $coll->{id} ], filter => $filter ); while (my ($id) = $ids->fetchrow) { $prefetch->{$id} = [] } #print STDERR "prefetch2: ".show_delta($t0)."\n"; $t0 = start_timer(); my $includes = $coll->{$member}->includes($ritem); $includes &= $filter if $filter; my $cursor = $storage->my_cursor( $ritem, filter => $includes, retrieve => [ $coll->{id} ] ); #print STDERR "prefetch3: ".show_delta($t0)."\n"; $t0 = start_timer(); while (my $item = $cursor->current) { my ($coll_id) = $cursor->residue; push @{ $prefetch->{$coll_id} }, $item; $cursor->next; } #print STDERR "prefetch4: ".show_delta($t0)."\n"; return $prefetch; } sub demand { my ($self, $def, $storage, $obj, $member, $class) = @_; my $set = Set::Object->new; if (my $prefetch = $storage->{PREFETCH}{$class}{$member}{$storage->export_object($obj)}) { print $Tangram::TRACE "getting ".$storage->id($obj) .".$member from prefetch\n" if $Tangram::TRACE; $set->insert(@$prefetch); } else { print $Tangram::TRACE "demanding ".$storage->id($obj) .".$member from storage\n" if $Tangram::TRACE; my $cursor = Tangram::Cursor::Coll->new($storage, $def->{class}, $storage->{db}); my $coll_id = $storage->export_object($obj); my $coll_tid = $storage->alloc_table; my $table = $def->{table}; my $item_tid = $cursor->{TARGET}->object->root_table; my $coll_col = $def->{coll} || 'coll'; my $item_col = $def->{item} || 'item'; $cursor->{-coll_tid} = $coll_tid; $cursor->{-coll_from} = "$table t$coll_tid"; $cursor->{-coll_where} = "t$coll_tid.$coll_col = $coll_id AND t$coll_tid.$item_col = t$item_tid.$storage->{schema}{sql}{id_col}"; $set->insert($cursor->select); } $self->remember_state($def, $storage, $obj, $member, $set); $set; } sub erase { my ($self, $storage, $obj, $members, $coll_id) = @_; $coll_id = $storage->{export_id}->($coll_id); foreach my $member (keys %$members) { my $def = $members->{$member}; my $table = $def->{table} || $def->{class} . "_$member"; my $coll_col = $def->{coll} || 'coll'; my $sql = "DELETE FROM\n $table\nWHERE\n $coll_col = $coll_id"; if ( $storage->can("t2_remove_hook") ) { $storage->t2_remove_hook ( ref($obj), $coll_id, $member, (map { $storage->id($_) } $obj->{$member}->members), ); } if ($def->{aggreg}) { my @content = $obj->{$member}->members; $storage->sql_do($sql); $storage->erase( @content ) ; } else { $storage->sql_do($sql); } } } sub query_expr { my ($self, $obj, $members, $tid) = @_; map { Tangram::Expr::Coll::FromMany->new($obj, $_); } values %$members; } sub remote_expr { my ($self, $obj, $tid) = @_; Tangram::Expr::Coll::FromMany->new($obj, $self); } $Tangram::Schema::TYPES{set} = Tangram::Type::Set::FromMany->new; #--------------------------------------------------------------------- # Tangram::Type::Set::FromMany->coldefs($cols, $members, $schema, $class, $tables) # # Setup column mappings for many to many unordered mappings (link # table) #--------------------------------------------------------------------- sub coldefs { my ($self, $cols, $members, $schema, $class, $tables) = @_; foreach my $member (values %$members) { my $COLS = $tables->{ $member->{table} }{COLS} ||= { }; $COLS->{$member->{coll}} = $schema->{sql}{id}; $COLS->{$member->{item}} = $schema->{sql}{id}; } } 1; Tangram-2.10/lib/Tangram/Type/Date/0000755000175000017500000000000010412420117015450 5ustar samvsamvTangram-2.10/lib/Tangram/Type/Date/Cooked.pm0000644000175000017500000000165310412412630017220 0ustar samvsamv# (c) Sam Vilain, 2004 package Tangram::Type::Date::Cooked; use strict; use Tangram::Type::TimeAndDate; use vars qw(@ISA); @ISA = qw( Tangram::Type::TimeAndDate ); $Tangram::Schema::TYPES{cookeddatetime} = Tangram::Type::Date::Cooked->new; sub get_importer { my $self = shift; my $context = shift; my $closure = shift; my $name = $self->{name}; return sub { my ($obj, $row, $context) = @_; my $val = shift @$row; $val = $context->{storage}->from_dbms('date', $val) if defined $val; $val = $closure->($val) if defined $val and $closure; $obj->{$name} = $val; } } sub get_exporter { my $self = shift; my $context = shift; my $closure = shift; my $name = $self->{name}; return sub { my ($obj, $context) = @_; my $val = $obj->{$name}; $val = $closure->($val) if defined $val and $closure; $val = $context->{storage}->to_dbms('date', $val) if defined $val; return $val; } } 1; Tangram-2.10/lib/Tangram/Type/Date/Manip.pm0000644000175000017500000000124110412412630017051 0ustar samvsamv package Tangram::Type::Date::Manip; use strict; use Tangram::Type::Date::Cooked; use vars qw(@ISA); @ISA = qw( Tangram::Type::Date::Cooked ); use Date::Manip qw(ParseDate UnixDate); $Tangram::Schema::TYPES{dmdatetime} = Tangram::Type::Date::Manip->new; # # Convert iso8601 format to Date::Manip internal format # sub get_importer { my $self = shift; my $context = shift; $self->SUPER::get_importer($context, sub {ParseDate(shift)}); } # Convert Date::Manip internal format to iso8601 format sub get_exporter { my $self = shift; my $context = shift; $self->SUPER::get_exporter ($context, sub { UnixDate(shift, "%Y-%m-%dT%H:%M:%S") }); } 1; Tangram-2.10/lib/Tangram/Type/Date/Raw.pm0000644000175000017500000000053610412412630016544 0ustar samvsamv use strict; package Tangram::Type::Date::Raw; use Tangram::Type::String; use vars qw(@ISA); @ISA = qw( Tangram::Type::String ); $Tangram::Schema::TYPES{rawdate} = __PACKAGE__->new; sub Tangram::Type/Date::coldefs { my ($self, $cols, $members, $schema) = @_; $self->_coldefs($cols, $members, "DATE $schema->{sql}{default_null}"); } 1; Tangram-2.10/lib/Tangram/Type/Date/DateTime.pm0000644000175000017500000000150410412412630017503 0ustar samvsamv# (c) Sam Vilain, 2004 package Tangram::Type::Date::DateTime; use strict; use Tangram::Type::Date::Cooked; use vars qw(@ISA); @ISA = qw( Tangram::Type::Date::Cooked ); use DateTime; use Carp qw(confess); $Tangram::Schema::TYPES{datetime} = Tangram::Type::Date::DateTime->new; # sub get_importer { my $self = shift; my $context = shift; $self->SUPER::get_importer ($context, sub { my($iso)=shift; $iso =~ m/^(\d{4})-(\d\d)-(\d\d)T ?(\d?\d):(\d\d):(\d\d)$/ or confess "bad ISO format from internal; $iso"; return DateTime->new( year => $1, month => $2, day => $3, hour => $4, minute => $5, second => $6 ); } ); } sub get_exporter { my $self = shift; my $context = shift; $self->SUPER::get_exporter($context, sub { (shift)->iso8601 }); } 1; Tangram-2.10/lib/Tangram/Type/Date/TimePiece.pm0000644000175000017500000000200710412412630017652 0ustar samvsamv# (c) Sam Vilain, 2004 package Tangram::Type::Date::TimePiece; use strict; use Tangram::Type::Date::Cooked; use vars qw(@ISA); @ISA = qw( Tangram::Type::Date::Cooked ); use Time::Piece; $Tangram::Schema::TYPES{timepiece} = Tangram::Type::Date::TimePiece->new; # # Convert SQL DATETIME format to Date::Manip internal format; assume # that "ParseDate" will magically do The Right Thing(tm) # sub get_importer { my $self = shift; my $context = shift; $self->SUPER::get_importer ($context, sub { Time::Piece->strptime(shift, "%Y-%m-%dT%H:%M:%S" ); }); } # # Convert Date::Manip internal format (ISO-8601) to format that should # work with most databases (read: I've only tested with MySQL but the # value is sensible) # # Of course, some databases don't like to try and guess date formats, # even when they're in nice forms. So, allow a hook for reformatting # dates. # sub get_exporter { my $self = shift; my $context = shift; $self->SUPER::get_exporter($context, sub { shift->datetime }); } 1; Tangram-2.10/lib/Tangram/Type/Dump/0000755000175000017500000000000010412420117015500 5ustar samvsamvTangram-2.10/lib/Tangram/Type/Dump/Any.pm0000644000175000017500000002046110412412630016571 0ustar samvsamv # (c) Sam Vilain, 2004. All rights reserved. This program is free # software; you can redistribute it and/or modify it under the same # terms as Perl itself use strict; use Tangram::Type::Scalar; package Tangram::Type::Dump::Any; =head1 NAME Tangram::Type::Dump::Any - Intuitive DataBase InterFace =head1 SYNOPSIS # ... in a nearby Tangram::Schema structure ... SomeClass => { fields => { idbif => { -options => { dumper => 'Data::Dumper', }, some_field => undef, some_property => undef, some_attribute => undef, each_one => undef, gets => undef, saved => undef, }, string => { cheese => undef, }, }, }; =head1 DESCRIPTION The B mapping type collates multiple data members into a single B (see L), B (see L) or B (see L) column. For instance, with the schema definition in the example, all the columns in the example would be serialised via Data::Dumper. If you stored an object like this: $cheese = bless { cheese => "gouda", gets => 6, each_one => 9 }, "SomeClass"; You would see something in your database similar to: /^'--v------v--------v----------------------------'^\ | id | type | cheese | idbif | >----o------o--------o------------------------------< | 1 | 42 | gouda | { gets => 6, each_one => 9 } | \_,--^------^--------^----------------------------._/ (note: the actual output from your SQL Database client may differ from the above) So, if you're the sort of person who likes to set their attributes with accessors, but doesn't like the overhead this places on the RDBMS... then this may help. Note: the real benefits of this mapping type are for when you're storing more complex data structures than "6" and "9" :-). You may prefer to use the default dumping type, which is B. =head2 LINKS TO OTHER OBJECTS If Tangram encounters another object which B (ie, has been inserted via C<$storage-Einsert($foo)>), then it will store a "Memento". This memento includes the object ID, which is sensitive to schema changes (the ordering of classes in the schema). If the class implements a C and C function, then there will be a "Memento" that includes the class name of the object, and the data that was returned by the class' C method. To be reconstituted, it is called as: SomeClass->px_thaw(@data) See L for more details on the complicity API. Please set RETVAL to be the thawed object. (that is, return a single scalar). =head2 BUT, I REALLY, REALLY HATE SCHEMAS! However, maybe you are one of those folk who don't like to declare their attributes, instead peppering hashes willy nilly, then there is another option. Instead of explicitly listing the fields you want, if you don't specify any fields at all, then it means save ALL remaining fields into the column. For convenience, C<-poof> is provided as a synonym for C<-options>, so you can write: { fields => { idbif => { -poof => # There goes another one! { }, } }, } [ You see, Tangram::Type::Dump::Any isn't actually an intuitive DB interface. No, an intuitive DB interface is a user interface component, and that title is reserved for Visual Tangram. VT expects to pick up the title with any luck by the end of the 21st century^W RSN! I Don't Believe In Fairies is actually what it stands for. It's a completely arbitrary name; chosen for no reason at all, and certainly not anything to do with L. ] =cut use Tangram::Type::Dump qw(flatten unflatten); use vars qw(@ISA); @ISA = qw( Tangram::Type::String ); use Set::Object qw(reftype blessed); $Tangram::Schema::TYPES{idbif} = Tangram::Type::Dump::Any->new; # for the reschema for this particular attribute, we reschema all of # the attributes mentioned to a single column sub reschema { my ($self, $members, $class, $schema) = @_; # convert from short form #$members = $_[1] = { map { $_ => undef } @$members } #if (ref($members) eq 'ARRAY'); my $options = { col => $schema->{normalize}->("idbif", "colname"), sql => $schema->{sql}{dumper_type}, dumper => $schema->{sql}{dumper}, members => [ ], }; for my $field (keys %$members) { if ($field eq "-options" or $field eq "-poof") { my $def = $members->{$field}; ref $def or next; reftype $def eq "HASH" or die("reftype invalid in schema for -options idbif;" ." hash expected, got $def"); while (my ($option, $value) = each %$def) { $options->{$option} = $value; if ($option eq "members" and reftype $value ne "ARRAY") { die("idbif -options.members must be an ARRAY ref;" ." got $value"); } } } else { push @{ $options->{members} }, $field; } } if (! @{ $options->{members} }) { $options->{save_all} = $schema->{classes}{$class}; } $options->{dumper_wanted} = $options->{dumper}; if (lc $options->{dumper} eq "yaml") { require 'YAML.pm'; $options->{dumper} = sub { local($^W)=0; YAML::Dump(shift) }; $options->{loader} = sub { my $stream = shift; $stream =~ m/^\s*$/s && return undef; $stream .= "\n"; my $result = eval { local($^W)=0; YAML::Load($stream); }; if ( $@ ) { die "Error parsing this stream: >-\n$stream\n...; $@"; } else { return $result; } }; } elsif (lc $options->{dumper} eq "data::dumper") { require 'Data/Dumper.pm'; $options->{dumper} = sub { local($Data::Dumper::Purity) = 1; local $Data::Dumper::Indent = 0; # compact local($Data::Dumper::Terse) = 1; Data::Dumper::Dumper(shift) }; $options->{loader} = sub { eval(shift) }; } elsif (lc $options->{dumper} eq "storable") { require 'Storable.pm'; $options->{dumper} = sub { Storable::freeze(shift) }; $options->{loader} = sub { Storable::thaw(shift) }; } %{$_[1]} = ( idbif => $options ); return "idbif"; # poof! } sub get_importer { my ($self, $context) = @_; return sub { my ($obj, $row, $context2) = @_; my $col = shift @$row; my $storage = $context2->{storage}; #print STDERR "About to load: `$col'\n"; defined(my $tmpobj = $self->{loader}->($storage->from_dbms("blob", $col))) or do { warn "loader for IDBIF on ".ref($obj)."[".$storage->id($obj)."] returned no value from >-\n$col\n..."; return $obj; }; #print STDERR "Got `$tmpobj'\n"; Tangram::Type::Dump::unflatten($storage, $tmpobj); if ($self->{save_all}) { for my $member (keys %$tmpobj) { $obj->{$member} = delete $tmpobj->{$member}; } } else { for my $member (@{ $self->{members} }) { $obj->{$member} = delete $tmpobj->{$member} if exists $tmpobj->{$member}; } } if (ref $tmpobj ne ref $obj and blessed $tmpobj) { bless $obj, ref $tmpobj; } %$tmpobj=(); bless $tmpobj, "nothing"; # "unbless" :-) skip DESTROY }; } sub get_exporter { #my ($self, $context) = @_; my $self = $_[0]; my $field = $self->{name}; return sub { my ($obj, $context2) = @_; my $tmpobj = bless { }, ref $obj; if ($self->{save_all}) { %$tmpobj = %$obj; while (my $member = each %{ $self->{mt} ||= $self->{save_all}{member_type} }) { delete $tmpobj->{$member}; } } else { for my $member (@{ $self->{members} }) { $tmpobj->{$member} = $obj->{$member} if exists $obj->{$member}; } } Tangram::Type::Dump::flatten($context2->{storage}, $tmpobj); my $text = $context2->{storage}->to_dbms ("blob", $self->{dumper}->($tmpobj)); print $Tangram::TRACE "IDBIF - storing: ".Data::Dumper::Dumper($tmpobj) if $Tangram::TRACE and $Tangram::DEBUG_LEVEL > 2; Tangram::Type::Dump::unflatten($context2->{storage}, $tmpobj); %$tmpobj = (); bless $tmpobj, "nothing"; return $text; }; } sub save { my ($self, $cols, $vals, $obj, $members, $storage) = @_; my $dbh = $storage->{db}; foreach my $member (keys %$members) { my $memdef = $members->{$member}; next if $memdef->{automatic}; push @$cols, $memdef->{col}; push @$vals, $dbh->quote(&{$memdef->{dumper}}($obj->{$member})); } } 1; Tangram-2.10/lib/Tangram/Type/Dump/Storable.pod0000644000175000017500000000443410412412630017765 0ustar samvsamv=head1 NAME Tangram::Type::Dump::Storable - map any Perl object as scalar dump via Storable =head1 SYNOPSIS use Tangram::Core; use Tangram::Type::Dump::Storable; # always $schema = Tangram::Schema->new( classes => { NaturalPerson => { fields => { storable => { diary => # diary is a perl hash { col => 'diarydata', sql => 'BLOB', indent => 0, terse => 1, purity => 0 }, lucky_numbers => 'int', # use defaults } =head1 DESCRIPTION Maps arbitrary Perl data structures by serializing to a string representation. The persistent fields are grouped in a hash under the C key in the field hash. Serialization is done by L, which traverses the Perl data structure and creates a binary representation of it. The resulting string will be mapped to the DBMS as a scalar value. During restore, the scalar value will be restored with L to reconstruct the original data structure. The structure should be able to contain pretty much anything that may be safely dumped by Storable. However, be aware that B must be able to find the persistent objects in the field. Unless you're using classes that are implemented in C and contain other objects, you should be fine (Set::Object has a special work-around). The field names are passed in a hash that associates a field name with a field descriptor. The field descriptor may be either a hash or a string. The hash uses the following fields: =over 4 =item * col =item * sql =item * indent =item * terse =item * purity =back The optional fields Cand C specify the column name and the column type for the scalar value in the database. If not present, Cdefaults to the field name and C defaults to VARCHAR(255). Values will be always quoted as they are passed to the database. The remaining optional fields control the serialization process. They will be passed down to L as values to the corresponding L options. The default settings are: no indentation (C), compact format (C), and quick dump (C). =head1 AUTHOR This mapping was contributed by Gabor Herr Tangram-2.10/lib/Tangram/Type/Dump/Perl.pm0000644000175000017500000000546010412412630016746 0ustar samvsamv # Copyright 1999-2001 Gabor Herr. All rights reserved. # This program is free software; you can redistribute it and/or modify it # under the same terms as Perl itself # Modified 29dec2000 by Jean-Louis Leroy # replaced save() by get_exporter() # fixed reschema(): $def->{dumper} was not set when using abbreviated forms use strict; use Tangram::Type::Scalar; package Tangram::Type::Dump::Perl; use Tangram::Type::Dump qw(flatten unflatten); use vars qw(@ISA); @ISA = qw( Tangram::Type::String ); use Data::Dumper; use Set::Object qw(reftype); $Tangram::Schema::TYPES{perl_dump} = Tangram::Type::Dump::Perl->new; my $DumpMeth = (defined &Data::Dumper::Dumpxs) ? 'Dumpxs' : 'Dump'; sub reschema { my ($self, $members, $class, $schema) = @_; if (ref($members) eq 'ARRAY') { # short form # transform into hash: { fieldname => { col => fieldname }, ... } $_[1] = map { $_ => { col => $schema->{normalize}->($_, 'colname') } } @$members; } for my $field (keys %$members) { my $def = $members->{$field}; my $refdef = reftype($def); unless ($refdef) { # not a reference: field => field $def = $members->{$field} = { col => $schema->{normalize}->(($def || $field), 'colname') }; $refdef = reftype($def); } die ref($self), ": $class\:\:$field: unexpected $refdef" unless $refdef eq 'HASH'; $def->{col} ||= $schema->{normalize}->($field, 'colname'); $def->{sql} ||= 'VARCHAR(255)'; $def->{indent} ||= 0; $def->{terse} ||= 1; $def->{purity} ||= 0; $def->{dumper} ||= sub { local($Data::Dumper::Indent) = $def->{indent}; local($Data::Dumper::Terse) = $def->{terse}; local($Data::Dumper::Purity) = $def->{purity}; local($Data::Dumper::Useqq) = 1; local($Data::Dumper::Varname) = '_t::v'; Data::Dumper->$DumpMeth([@_], []); }; } return keys %$members; } sub get_importer { my ($self, $context) = @_; return("\$obj->{$self->{name}} = eval shift \@\$row;" ."Tangram::Type::Dump::unflatten(\$context->{storage}, " ."\$obj->{$self->{name}})"); } sub get_exporter { my ($self, $context) = @_; my $field = $self->{name}; return sub { my ($obj, $context) = @_; flatten($context->{storage}, $obj->{$field}); my $text = $self->{dumper}->($obj->{$field}); unflatten($context->{storage}, $obj->{$field}); return $text; }; } sub save { my ($self, $cols, $vals, $obj, $members, $storage) = @_; my $dbh = $storage->{db}; foreach my $member (keys %$members) { my $memdef = $members->{$member}; next if $memdef->{automatic}; push @$cols, $memdef->{col}; Tangram::Type::Dump::flatten($storage, $obj->{$member}); push @$vals, $dbh->quote(&{$memdef->{dumper}}($obj->{$member})); Tangram::Type::Dump::unflatten($storage, $obj->{$member}); } } 1; Tangram-2.10/lib/Tangram/Type/Dump/Perl.pod0000644000175000017500000000377010412412630017116 0ustar samvsamv=head1 NAME Tangram::Type::Dump::Perl - map any Perl object as scalar dump =head1 SYNOPSIS use Tangram::Core; use Tangram::Type::Dump::Perl; # always $schema = Tangram::Schema->new( classes => { NaturalPerson => { fields => { perl_dump => { diary => # diary is a perl hash { col => 'diarydata', sql => 'TEXT', indent => 0, terse => 1, purity => 0 }, lucky_numbers => 'int', # use defaults } =head1 DESCRIPTION Maps arbitrary Perl data structures by serializing to a string representation. The persistent fields are grouped in a hash under the C key in the field hash. Serialization is done by L, which traverses the Perl data structure and creates a string representation of it. The resulting string will be mapped to the DBMS as a scalar value. During restore, the scalar value will be L'd to reconstruct the original data structure. As of Tangram 2.07.1, persistent references are safely handled via the L utility class. The field names are passed in a hash that associates a field name with a field descriptor. The field descriptor may be either a hash or a string. The hash uses the following fields: =over 4 =item * col =item * sql =item * indent =item * terse =item * purity =back The optional fields Cand C specify the column name and the column type for the scalar value in the database. If not present, Cdefaults to the field name and C defaults to VARCHAR(255). Values will be always quoted as they are passed to the database. The remaining optional fields control the serialization process. They will be passed down to L as values to the corresponding L options. The default settings are: no indentation (C), compact format (C), and quick dump (C). =head1 AUTHOR This mapping was contributed by Gabor Herr Tangram-2.10/lib/Tangram/Type/Dump/Storable.pm0000644000175000017500000000543310412412630017617 0ustar samvsamv # (c) Sam Vilain, 2004. All Rights Reserved. # This program is free software; you may use it and/or distribute it # under the same terms as Perl itself. package Tangram::Type::Dump::Storable; use strict; use Tangram::Type::Scalar; use Tangram::Type::Dump qw(flatten unflatten); use Storable qw(freeze thaw); use Set::Object qw(reftype); use vars qw(@ISA); @ISA = qw( Tangram::Type::String ); $Tangram::Schema::TYPES{storable} = __PACKAGE__->new; sub reschema { my ($self, $members, $class, $schema) = @_; if (ref($members) eq 'ARRAY') { # short form # transform into hash: { fieldname => { col => fieldname }, ... } $_[1] = map { $_ => { col => $schema->{normalize}->($_, 'colname') } } @$members; } for my $field (keys %$members) { my $def = $members->{$field}; my $refdef = reftype($def); unless ($refdef) { # not a reference: field => field $def = $members->{$field} = { col => $schema->{normalize}->(($def || $field), 'colname') }; $refdef = reftype($def); } die ref($self), ": $class\:\:$field: unexpected $refdef" unless $refdef eq 'HASH'; $def->{col} ||= $schema->{normalize}->($field, 'colname'); $def->{sql} ||= 'BLOB'; $def->{deparse} ||= 0; $def->{dumper} ||= sub { local($Storable::Deparse) = $def->{deparse}; my $ent = [@_]; my $dumped = freeze($ent); $Data::Dumper::Purity = 1; $Data::Dumper::Useqq = 1; #print STDERR "Dumped: ".Data::Dumper::Dumper($ent, $dumped); $dumped; }; } return keys %$members; } sub get_importer { my ($self, $context) = @_; return(" my \$data = shift \@\$row; print \$Tangram::TRACE \"THAWING (length = \".(length(\$data)).\":\".Data::Dumper::Dumper(\$data) if \$Tangram::TRACE and \$Tangram::DEBUG_LEVEL > 2; my \$ref = Storable::thaw(\$context->{storage}->from_dbms('blob', \$data)) or die \"thaw failed on data (\".(length(\$data)).\") = \".Data::Dumper::Dumper(\$data); \$obj->{$self->{name}} = \$ref->[0];\n" ."Tangram::Type::Dump::unflatten(\$context->{storage}, " ."\$obj->{$self->{name}});\n"); } sub get_exporter { my ($self, $context) = @_; my $field = $self->{name}; return sub { my ($obj, $context) = @_; flatten($context->{storage}, $obj->{$field}); my $text = $self->{dumper}->($obj->{$field}); unflatten($context->{storage}, $obj->{$field}); return $context->{storage}->to_dbms('blob', $text); }; } sub save { my ($self, $cols, $vals, $obj, $members, $storage) = @_; my $dbh = $storage->{db}; foreach my $member (keys %$members) { my $memdef = $members->{$member}; next if $memdef->{automatic}; push @$cols, $memdef->{col}; flatten($storage, $obj->{$member}); push @$vals, $dbh->quote(&{$memdef->{dumper}}($obj->{$member})); unflatten($storage, $obj->{$member}); } } 1; Tangram-2.10/lib/Tangram/Type/Dump/YAML.pm0000644000175000017500000000656010412412630016610 0ustar samvsamv package Tangram::Type::Dump::YAML; =head1 NAME Tangram::Type::Dump::YAML - serialise fields of an object via YAML to a column =head1 SYNOPSIS use Tangram::Core; use Tangram::Type::Dump::YAML; $schema = Tangram::Schema->new( classes => { NaturalPerson => { fields => { yaml => { diary => # diary is a perl hash { col => 'diarydata', sql => 'TEXT', # better be large enough! :) # YAML dumper control, values here are defaults options => { Indent => 2, UseHeader => 1, UseVersion => 1, SortKeys => 1, UseCode => 0, # ... etc, see the YAML man page for more }, } }}}); =head1 DESCRIPTION Tangram::Type::Dump::YAML is very much like Tangram::Type::Dump::Perl, only serialisation is achieved via YAML and not Data::Dumper. This is currently untested, but is known to have bugs, largely to do with the fact that YAML can't serialise blessed references (see L). =cut use strict; use Tangram::Type::Scalar; use YAML qw(freeze thaw); use vars qw(@ISA); @ISA = qw( Tangram::Type::String ); use Set::Object qw(reftype); $Tangram::Schema::TYPES{yaml} = Tangram::Type::Dump::YAML->new; sub reschema { my ($self, $members, $class, $schema) = @_; if (ref($members) eq 'ARRAY') { # short form # transform into hash: { fieldname => { col => fieldname }, ... } $_[1] = map { $_ => { col => $schema->{normalize}->($_, 'colname') } } @$members; } for my $field (keys %$members) { my $def = $members->{$field}; my $refdef = reftype($def); unless ($refdef) { # not a reference: field => field $def = $members->{$field} = { col => $schema->{normalize}->(($def || $field), 'colname') }; $refdef = reftype($def); } die ref($self).": $class\:\:$field: unexpected $refdef" unless $refdef eq 'HASH'; $def->{col} ||= $schema->{normalize}->($field, 'colname'); $def->{sql} ||= 'VARCHAR(255)'; # not a great default, but hey, it's # portable $def->{options} ||= { }; $def->{dumper} = sub { freeze(shift); }; } return keys %$members; } sub get_importer { my ($self, $context) = @_; return("{ my \$x = '--- ' . ((shift \@\$row)||'~').'\n'; \$obj->{$self->{name}} = eval { YAML::thaw(\$x) };\n" .'die("YAML error; `$@` loading: |\n$x\n...\n") if $@;' ."Tangram::Type::Dump::unflatten(\$context->{storage}, " ."\$obj->{$self->{name}}) }"); } sub get_exporter { my ($self, $context) = @_; my $field = $self->{name}; return sub { my ($obj, $context) = @_; Tangram::Type::Dump::flatten($context->{storage}, $obj->{$field}); my $text = $self->{dumper}->($obj->{$field}); $text =~ s{\A--- *|\n\Z}{}g; Tangram::Type::Dump::unflatten($context->{storage}, $obj->{$field}); return $text; }; } sub save { my ($self, $cols, $vals, $obj, $members, $storage) = @_; my $dbh = $storage->{db}; foreach my $member (keys %$members) { my $memdef = $members->{$member}; next if $memdef->{automatic}; push @$cols, $memdef->{col}; push @$vals, $dbh->quote(&{$memdef->{dumper}}($obj->{$member})); } } 1; Tangram-2.10/lib/Tangram/Type/Hash/0000755000175000017500000000000010412420117015456 5ustar samvsamvTangram-2.10/lib/Tangram/Type/Hash/Scalar.pm0000644000175000017500000001330010412412630017217 0ustar samvsamv use strict; package Tangram::Type::Hash::Scalar; use vars qw(@ISA); @ISA = qw( Tangram::Type::Abstract::Hash ); use Tangram::Type::Abstract::Hash; use Tangram::Expr::FlatHash; $Tangram::Schema::TYPES{flat_hash} = Tangram::Type::Hash::Scalar->new; sub reschema { my ($self, $members, $class, $schema) = @_; for my $field (keys %$members) { my $def = $members->{$field}; my $refdef = ref($def); unless ($refdef) { # not a reference: field => field $def = $members->{$field} = { type => 'string', key_type => 'string' }; } $def->{table} ||= $schema->{normalize}->($class . "_$field", 'tablename'); $def->{type} ||= 'string'; $def->{string_type} = $def->{type} eq 'string'; $def->{sql} ||= $def->{string_type} ? 'VARCHAR(255)' : uc($def->{type}); $def->{key_type} ||= 'string'; $def->{key_string_type} = $def->{key_type} eq 'string'; $def->{key_sql} ||= $def->{key_string_type} ? 'VARCHAR(255)' : uc($def->{key_type}); } return keys %$members; } sub demand { my ($self, $def, $storage, $obj, $member, $class) = @_; print $Tangram::TRACE "loading $member\n" if $Tangram::TRACE; my %coll; my $id = $storage->export_object($obj); if (my $prefetch = $storage->{PREFETCH}{$class}{$member}{$id}) { %coll = %$prefetch; } else { my $sth = $storage->sql_prepare( "SELECT\n a.k,\n a.v\nFROM\n $def->{table} a\nWHERE\n coll = $id", $storage->{db}); $sth->execute(); for my $row (@{ $sth->fetchall_arrayref() }) { my ($k, $v) = @$row; $coll{$k} = $v; } } $self->set_load_state($storage, $obj, $member, { %coll } ); return \%coll; } sub get_exporter { my ($self, $context) = @_; return sub { my ($obj, $context) = @_; $self->defered_save($context->{storage}, $obj, $self->{name}, $self); (); } } sub hash_diff { my ($first,$second,$differ) = @_; my (@common,@changed,@only_in_first,@only_in_second); foreach (keys %$first) { if (exists $second->{$_}) { if ($differ->($first->{$_},$second->{$_})) { push @changed, $_; } else { push @common, $_; } } else { push @only_in_first, $_; } } foreach (keys %$second) { push @only_in_second, $_ unless exists $first->{$_}; } (\@common,\@changed,\@only_in_first,\@only_in_second); } sub defered_save { use integer; my ($self, $storage, $obj, $field, $def) = @_; return if tied $obj->{$field}; # collection has not been loaded, thus not modified my $coll_id = $storage->id($obj); my ($ne, $modify, $add, $remove) = $self->get_save_closures($storage, $obj, $def, $coll_id); my $new_state = $obj->{$field} || {}; my $old_state = $self->get_load_state($storage, $obj, $field) || {}; my ($common, $changed, $to_add, $to_remove) = hash_diff($new_state, $old_state, $ne); for my $key (@$changed) { $modify->($key, $new_state->{$key}, $old_state->{$key}); } for my $key (@$to_add) { $add->($key, $new_state->{$key}); } for my $key (@$to_remove) { $remove->($key); } $self->set_load_state($storage, $obj, $field, { %$new_state } ); $storage->tx_on_rollback( sub { $self->set_load_state($storage, $obj, $field, $old_state) } ); } my $no_ref = 'illegal reference in flat hash'; sub get_save_closures { my ($self, $storage, $obj, $def, $id) = @_; my $table = $def->{table}; my ($ne, $quote, $key_quote); if ($def->{string_type}) { $ne = sub { my ($a, $b) = @_; defined($a) != defined($b) || $a ne $b }; $quote = sub { $storage->{db}->quote(shift()) }; } else { $ne = sub { my ($a, $b) = @_; defined($a) != defined($b) || $a != $b }; $quote = sub { shift() }; } if ($def->{key_string_type}) { $key_quote = sub { $storage->{db}->quote(shift()) }; } else { $key_quote = sub { shift() }; } my $eid = $storage->{export_id}->($id); my $modify = sub { my ($k, $v) = @_; die $no_ref if (ref($v) or ref($k)); $v = $quote->($v); $k = $key_quote->($k); $storage->sql_do("UPDATE\n $table\nSET\n v = $v\nWHERE\n coll = $eid AND\n k = $k"); }; my $add = sub { my ($k, $v) = @_; die $no_ref if (ref($v) or ref($k)); $v = $quote->($v); $k = $key_quote->($k); $storage->sql_do("INSERT INTO\n $table (coll, k, v)\n VALUES ($eid, $k, $v)"); }; my $remove = sub { my ($k) = @_; die $no_ref if ref($k); $k = $key_quote->($k); $storage->sql_do("DELETE FROM\n $table\nWHERE\n coll = $eid AND\n k = $k"); }; return ($ne, $modify, $add, $remove); } sub erase { my ($self, $storage, $obj, $members, $coll_id) = @_; $coll_id = $storage->{export_id}->($coll_id); foreach my $def (values %$members) { $storage->sql_do("DELETE FROM\n $def->{table}\nWHERE\n coll = $coll_id"); } } sub coldefs { my ($self, $cols, $members, $schema, $class, $tables) = @_; foreach my $member (values %$members) { $tables->{ $member->{table} }{COLS} = { coll => $schema->{sql}{id}, k => $member->{key_sql}, v => $member->{sql} }; } } sub query_expr { my ($self, $obj, $members, $tid) = @_; map { Tangram::Expr::FlatHash->new($obj, $_); } values %$members; } sub remote_expr { my ($self, $obj, $tid) = @_; Tangram::Expr::FlatHash->new($obj, $self); } sub prefetch { my ($self, $storage, $def, $coll, $class, $member, $filter) = @_; my $prefetch = $storage->{PREFETCH}{$class}{$member} ||= {}; my $restrict = $filter ? ",\n " . $filter->from() . "\nWHERE\n " . $filter->where() : ''; my $sth = $storage->sql_prepare( "SELECT\n coll,\n k,\n v\nFROM\n $def->{table}\n$restrict", $storage->{db}); $sth->execute(); for my $row (@{ $sth->fetchall_arrayref() }) { my ($id, $k, $v) = @$row; $prefetch->{$id}{$k} = $v; } return $prefetch; } 1; Tangram-2.10/lib/Tangram/Type/Hash/FromOne.pm0000644000175000017500000001256310412412630017371 0ustar samvsamv # not implemented yet package Tangram::Type::Hash::FromOne; use base qw( Tangram::Type::Abstract::Hash ); use strict; use Carp; sub reschema { my ($self, $members, $class, $schema) = @_; foreach my $member (keys %$members) { my $def = $members->{$member}; unless (ref($def)) { $def = { class => $def }; $members->{$member} = $def; } $def->{coll} ||= $schema->{normalize}-> ($schema->{normalize}->($class, "tablename") . "_" . $schema->{normalize}->($member, "fieldname"), "colname"); $def->{slot} ||= $schema->{normalize}-> ($schema->{normalize}->($class, "tablename") . "_". $schema->{normalize}->($member, "fieldname") . "_slot", "colname"); $schema->{classes}{$def->{class}}{stateless} = 0; if (exists $def->{back}) { my $back = $def->{back} ||= $def->{item}; $schema->{classes}{ $def->{class} }{members}{backref}{$back} = bless { name => $back, col => $def->{coll}, class => $class, field => $member }, 'Tangram::Type::BackRef'; } } return keys %$members; } sub defered_save { use integer; my ($self, $obj, $field, $storage) = @_; return if tied $obj->{$field}; my $coll_id = $storage->export_object($obj); my $classes = $storage->{schema}{classes}; my $def = $self; # surely! my $old_states = $storage->{scratch}{ref($self)}{$field}; my $item_classdef = $classes->{$def->{class}}; # get the schema definition for the collection my $table = $item_classdef->{table} or die; my $item_col = $def->{coll}; my $slot_col = $def->{slot}; my $coll = $obj->{$field}; my %new_state = (); my $old_state = $old_states->{$field} || {}; my %removed = %$old_state; my $slot = 0; while (my $slot = each %$coll) { my $item_id = $storage->export_object( $coll->{$slot} ) || die; $storage->sql_do("UPDATE\n $table\nSET\n $item_col = $coll_id,\n $slot_col = ?\nWHERE\n $storage->{schema}{sql}{id_col} = ?", $slot, $item_id) unless (exists $old_state->{$slot} and $item_id eq $old_state->{$slot}); $new_state{$slot} = $item_id; delete $removed{$slot}; } if (keys %removed) { my $removed = join(' ', values %removed); $storage->sql_do("UPDATE\n $table\nSET\n $item_col = NULL,\n $slot_col = NULL\nWHERE\n $storage->{schema}{sql}{id_col} IN ($removed)"); } $old_states->{$field} = \%new_state; $storage->tx_on_rollback( sub { $old_states->{$field} = $old_state } ); } sub erase { my ($self, $storage, $obj, $members, $coll_id) = @_; foreach my $member (keys %$members) { next if tied $obj->{$member}; my $def = $members->{$member}; my $item_classdef = $storage->{schema}{classes}{$def->{class}}; my $table = $item_classdef->{table} || $def->{class}; my $item_col = $def->{coll}; my $slot_col = $def->{slot}; my $sql = "UPDATE\n $table\nSET\n $item_col = NULL,\n $slot_col = NULL\nWHERE\n $item_col = $coll_id"; $storage->sql_do($sql); } } sub cursor { my ($self, $def, $storage, $obj, $member) = @_; my $cursor = Tangram::Cursor::Coll->new($storage, $def->{class}, $storage->{db}); my $item_col = $def->{coll}; my $slot_col = $def->{slot}; my $coll_id = $storage->export_object($obj); my $tid = ${ $cursor }{ TARGET }->object->{table_hash}{$def->{class}} ; # ->leaf_table; $cursor->{-coll_cols} = "t$tid.$slot_col"; $cursor->{-coll_where} = "t$tid.$item_col = $coll_id"; return $cursor; } sub query_expr { my ($self, $obj, $members, $tid) = @_; map { Tangram::Expr::Coll::FromOne->new($obj, $_); } values %$members; } sub remote_expr { my ($self, $obj, $tid) = @_; Tangram::Expr::Coll::FromOne->new($obj, $self); } sub prefetch { my ($self, $storage, $def, $coll, $class, $member, $filter) = @_; my $ritem = $storage->remote($def->{class}); my $prefetch = $storage->{PREFETCH}{$class}{$member} ||= {}; # weakref my $cursor = Tangram::Cursor->new($storage, $ritem, $storage->{db}); my $includes = $coll->{$member}->includes($ritem); $includes &= $filter if $filter; # also retrieve collection-side id and index of elmt in sequence $cursor->retrieve ($coll->{id}, $storage->expr(Tangram::Type::Scalar->instance, "t$ritem->{_object}{table_hash}{$def->{class}}" .".$def->{slot}") ); $cursor->select($includes); while (my $item = $cursor->current) { my ($coll_id, $slot) = $cursor->residue; $prefetch->{$coll_id}{$slot} = $item; $cursor->next; } } $Tangram::Schema::TYPES{ihash} = Tangram::Type::Hash::FromOne->new; #--------------------------------------------------------------------- # Tangram::Type::Hash::FromOne->coldefs($cols, $members, $schema, $class, # $tables) # # Setup column mappings for one to many indexed mappings (foreign # key with string category) #--------------------------------------------------------------------- sub coldefs { my ($self, $cols, $members, $schema, $class, $tables) = @_; foreach my $member (values %$members) { my $table = $tables->{ $schema->{classes}{$member->{class}}{table} } ||= {}; $table->{COLS}{$member->{coll}} = "$schema->{sql}{id} $schema->{sql}{default_null}"; $table->{COLS}{$member->{slot}} = "VARCHAR(255) $schema->{sql}{default_null}"; } } 1; Tangram-2.10/lib/Tangram/Type/Hash/Scalar.pod0000644000175000017500000000455410412412630017400 0ustar samvsamv=head1 NAME Tangram::Type/Hash/Scalar - map Perl hash of scalar keys and values =head1 SYNOPSIS use Tangram::Core; use Tangram::Type/Hash/Scalar; # always $schema = Tangram::Schema->new( classes => { NaturalPerson => { fields => { flat_hash => { opinions => { table => 'NP_ops', key_sql => 'VARCHAR(10)', type => 'int', sql => 'NUMERIC(1)', }, lucky_numbers => 'int', # use defaults } =head1 DESCRIPTION Maps references to a Perl hash. The persistent fields are grouped in a hash under the C key in the field hash. The hash may contain as keys and values only 'simple' scalars like integers, strings or real numbers. It may not contain references. For hashs of objects, see L and L. Tangram uses a table to save the state of the collection. The table has three columns, which contain =over 4 =item * the id of the container object =item * the key of the element in the hash =item * the value of the element =back The field names are passed in a hash that associates a field name with a field descriptor. The field descriptor may be either a hash or a string. The hash uses the following fields: =over 4 =item * key_type =item * key_sql =item * type =item * sql =item * table =back The optional fields C and C specify the key and value types of the hash. If the type is C Tangram quotes the values as they are passed to the database. Not specifying a C is exactly equivalent to specifying C. Optional field C
sets the name of the table that contains the elements. This defaults to 'C_F', where C is the class of the containing object and F is the field name. The optional fields C and C specify the type that deploy() (see L) should use for the column containing the key and value of the hash. If this field is not present, the SQL type is derived from the C field: if C is C (or is absent) VARCHAR(255) is used; otherwise, the C field is interpreted as a SQL type. If the descriptor is a string, it is interpreted as the value of the C field and all the other fields take the default value. =head1 AUTHOR This mapping was contributed by Gabor Herr Tangram-2.10/lib/Tangram/Type/Hash/FromMany.pm0000644000175000017500000001307310412412630017551 0ustar samvsamv use strict; package Tangram::Type::Hash::FromMany; use Tangram::Type::Abstract::Hash; use vars qw(@ISA); @ISA = qw( Tangram::Type::Abstract::Hash ); use Carp; sub reschema { my ($self, $members, $class, $schema) = @_; foreach my $member (keys %$members) { my $def = $members->{$member}; unless (ref($def)) { $def = { class => $def }; $members->{$member} = $def; } $def->{table} ||= $schema->{normalize}->($def->{class} . "_$member", 'tablename'); $def->{coll} ||= 'coll'; $def->{item} ||= 'item'; $def->{slot} ||= 'slot'; $def->{quote} = !exists $def->{key_type} || $def->{key_type} eq 'string' ? "'" : ''; } return keys %$members; } sub defered_save { my ($self, $obj, $field, $storage) = @_; my $coll_id = $storage->export_object($obj); my ($table, $coll_col, $item_col, $slot_col) = @{ $self }{ qw( table coll item slot ) }; my $Q = $self->{quote}; my $coll = $obj->{$field}; my $old_state = $self->get_load_state($storage, $obj, $field) || {}; my %removed = %$old_state; delete @removed{ keys %$coll }; my @free = keys %removed; my %new_state; foreach my $slot (keys %$coll) { my $item_id = $storage->export_object($coll->{$slot}); if (exists $old_state->{$slot}) { # key already exists if ($item_id != $old_state->{$slot}) { # val has changed $storage->sql_do ( "UPDATE\n $table\nSET\n $item_col = $item_id\nWHERE\n $coll_col = $coll_id AND\n $slot_col = $Q$slot$Q" ); } } else { # key does not exist if (@free) { # recycle an existing line my $rslot = shift @free; $storage->sql_do( "UPDATE\n $table\nSET\n $slot_col = $Q$slot$Q,\n $item_col = $item_id\nWHERE\n $coll_col = $coll_id AND\n $slot_col = $Q$rslot$Q" ); } else { # insert a new line $storage->sql_do( "INSERT INTO $table ($coll_col, $item_col, $slot_col)\n VALUES ($coll_id, $item_id, $Q$slot$Q)" ); } } $new_state{$slot} = $item_id; } # foreach my $slot (keys %$coll) # remove lines in excess if (@free) { @free = map { "$Q$_$Q" } @free if $Q; $storage->sql_do( "DELETE FROM\n $table\nWHERE\n $coll_col = $coll_id AND\n $slot_col IN (@free)" ); } $self->set_load_state($storage, $obj, $field, \%new_state ); $storage->tx_on_rollback( sub { $self->set_load_state($storage, $obj, $field, $old_state) } ); } sub erase { my ($self, $storage, $obj, $members, $coll_id) = @_; foreach my $member (keys %$members) { my $def = $members->{$member}; my $table = $def->{table} || $def->{class} . "_$member"; my $coll_col = $def->{coll} || 'coll'; my $sql = "DELETE FROM\n $table\nWHERE\n $coll_col = $coll_id"; $storage->sql_do($sql); } } sub cursor # ?? factorize ?? { my ($self, $def, $storage, $obj, $member) = @_; my $cursor = Tangram::Cursor::Coll->new($storage, $def->{class}, $storage->{db}); my $coll_id = $storage->export_object($obj); my $coll_tid = $storage->alloc_table; my $table = $def->{table}; my $item_tid = $cursor->{TARGET}->object->root_table; my $coll_col = $def->{coll}; my $item_col = $def->{item}; my $slot_col = $def->{slot}; $cursor->{-coll_tid} = $coll_tid; $cursor->{-coll_cols} = "t$coll_tid.$slot_col"; $cursor->{-coll_from} = "$table t$coll_tid"; $cursor->{-coll_where} = "t$coll_tid.$coll_col = $coll_id AND t$coll_tid.$item_col = t$item_tid.$storage->{schema}{sql}{id_col}"; return $cursor; } sub query_expr { my ($self, $obj, $members, $tid) = @_; map { Tangram::Expr::Coll::FromMany->new($obj, $_); } values %$members; } sub remote_expr { my ($self, $obj, $tid) = @_; Tangram::Expr::Coll::FromMany->new($obj, $self); } sub prefetch { my ($self, $storage, $def, $coll, $class, $member, $filter) = @_; my $ritem = $storage->remote($def->{class}); # first retrieve the collection-side ids of all objects satisfying $filter # empty the corresponding prefetch array my $ids = $storage->my_select_data( cols => [ $coll->{id} ], filter => $filter ); my $prefetch = $storage->{PREFETCH}{$class}{$member} ||= {}; # weakref while (my ($id) = $ids->fetchrow) { $prefetch->{$id} = {}; } undef $ids; # now fetch the items my $cursor = Tangram::Cursor->new($storage, $ritem, $storage->{db}); my $includes = $coll->{$member}->includes($ritem); # also retrieve collection-side id and index of elmt in sequence $cursor->retrieve($coll->{id}, Tangram::Type::Number->expr("t$includes->{link_tid}.$def->{slot}") ); $cursor->select($filter ? $filter & $includes : $includes); while (my $item = $cursor->current) { my ($coll_id, $slot) = $cursor->residue; $prefetch->{$coll_id}{$slot} = $item; $cursor->next; } return $prefetch; } $Tangram::Schema::TYPES{hash} = Tangram::Type::Hash::FromMany->new; #--------------------------------------------------------------------- # Tangram::Type::Hash::FromMany->coldefs($cols, $members, $schema, $class, $tables) # # Setup column mappings for many to many indexed mappings (link # table with string category) #--------------------------------------------------------------------- sub coldefs { my ($self, $cols, $members, $schema, $class, $tables) = @_; foreach my $member (values %$members) { $tables->{ $member->{table} }{COLS} = { $member->{coll} => $schema->{sql}{id}, $member->{item} => $schema->{sql}{id}, # XXX - hardcoded slot type $member->{slot} => "VARCHAR(255) $schema->{sql}{default_null}" }; } } 1; Tangram-2.10/lib/Tangram/Type/Scalar.pm0000644000175000017500000000506610412412630016346 0ustar samvsamv package Tangram::Type::Scalar; use strict; use Tangram::Type; use vars qw(@ISA); BEGIN { @ISA = qw( Tangram::Type ); } use Tangram::Type::Real; use Tangram::Type::Integer; use Tangram::Type::Number; use Tangram::Type::String; sub reschema { my ($self, $members, $class, $schema) = @_; if (ref($members) eq 'ARRAY') { # short form # transform into hash: { fieldname => { col => fieldname }, ... } $members = $_[1] = map { $_ => { col => $schema->{normalize}->($_, 'colname') } } @$members; } for my $field (keys %$members) { my $def = $members->{$field}; unless (ref($def)) { # not a reference: field => field $def = $members->{$field} = { col => $schema->{normalize}->(($def || $field), 'fieldname') }; } $self->field_reschema($field, $def, $schema); } return keys %$members; } sub field_reschema { my ($self, $field, $def, $schema) = @_; $def->{col} ||= $schema->{normalize}->($field, 'colname'); } sub query_expr { my ($self, $obj, $memdefs, $tid, $storage) = @_; return map { $storage->expr($self, "t$tid.$memdefs->{$_}{col}", $obj) } keys %$memdefs; } sub remote_expr { my ($self, $obj, $tid, $storage) = @_; $storage->expr($self, "t$tid.$self->{col}", $obj); } sub get_exporter { my ($self) = @_; return if $self->{automatic}; my $field = $self->{name}; return "exists \$obj->{q{$field}} ? \$obj->{q{$field}} : undef"; } sub get_importer { my ($self) = @_; return "\$obj->{q{$self->{name}}} = shift \@\$row"; } sub get_export_cols { return shift->{col}; } sub get_import_cols { my ($self, $context) = @_; return $self->{col}; } sub literal { my ($self, $lit) = @_; return $lit; } sub content { shift; shift; } #--------------------------------------------------------------------- # Tangram::Type::Scalar->_coldefs($cols, $members, $sql, $schema) # # Adds entries to the current table mapping for the columns for a # single class of a given type. Inheritance is not in the picture # yet. # # $cols is the columns definition for the current table mapping # $members is the `members' property of the current class (ie, the # members for a particular data type, eg string => $members) # $sql is the SQL type to default columns to # $schema is the Tangram::Schema object #--------------------------------------------------------------------- sub _coldefs { my ($self, $cols, $members, $sql, $schema) = @_; for my $def (values %$members) { $cols->{ $def->{col} } = ( $def->{sql} || "$sql " . ($schema->{sql}{default_null} || "") ); } } 1; Tangram-2.10/lib/Tangram/Type/Array/0000755000175000017500000000000010412420117015651 5ustar samvsamvTangram-2.10/lib/Tangram/Type/Array/Scalar.pm0000644000175000017500000000767110412412630017430 0ustar samvsamv use strict; package Tangram::Type::Array::Scalar; use vars qw(@ISA); @ISA = qw( Tangram::Type::Abstract::Array ); use Tangram::Type::Abstract::Array; use Tangram::Expr::FlatArray; $Tangram::Schema::TYPES{flat_array} = Tangram::Type::Array::Scalar->new; sub reschema { my ($self, $members, $class, $schema) = @_; for my $field (keys %$members) { my $def = $members->{$field}; my $refdef = ref($def); unless ($refdef) { # not a reference: field => field $def = $members->{$field} = { type => 'string' }; } $def->{table} ||= $schema->{normalize}->($class . "_" .$schema->{normalize}->($field, "fieldname"), 'tablename'); $def->{type} ||= 'string'; $def->{string_type} = $def->{type} eq 'string'; $def->{sql} ||= $def->{string_type} ? 'VARCHAR(255)' : uc($def->{type}); } return keys %$members; } sub demand { my ($self, $def, $storage, $obj, $member, $class) = @_; print $Tangram::TRACE "loading $member\n" if $Tangram::TRACE; my @coll; my $id = $storage->export_object($obj); if (my $prefetch = $storage->{PREFETCH}{$class}{$member}{$id}) { @coll = @$prefetch; } else { my $sth = $storage->sql_prepare( "SELECT\n a.i,\n a.v\nFROM\n $def->{table} a\nWHERE\n coll = $id", $storage->{db}); $sth->execute(); for my $row (@{ $sth->fetchall_arrayref() }) { my ($i, $v) = @$row; $coll[$i] = $v; } } $self->set_load_state($storage, $obj, $member, [ @coll ] ); return \@coll; } sub get_exporter { my ($self, $context) = @_; return sub { my ($obj, $context) = @_; $self->defered_save($context->{storage}, $obj, $self->{name}, $self); (); } } my $no_ref = 'illegal reference in flat array'; sub get_save_closures { my ($self, $storage, $obj, $def, $id) = @_; my $table = $def->{table}; my ($ne, $quote); if ($def->{string_type}) { $ne = sub { my ($a, $b) = @_; defined($a) != defined($b) || $a ne $b }; $quote = sub { $storage->{db}->quote(shift()) }; } else { $ne = sub { my ($a, $b) = @_; defined($a) != defined($b) || $a != $b }; $quote = sub { shift() }; } my $eid = $storage->{export_id}->($id); my $modify = sub { my ($i, $v) = @_; die $no_ref if ref($v); $v = $quote->($v); $storage->sql_do("UPDATE\n $table\nSET\n v = $v\nWHERE\n coll = $eid AND\n i = $i"); }; my $add = sub { my ($i, $v) = @_; die $no_ref if ref($v); $v = $quote->($v); $storage->sql_do("INSERT INTO $table (coll, i, v)\n VALUES ($eid, $i, $v)"); }; my $remove = sub { my ($new_size) = @_; $storage->sql_do("DELETE FROM\n $table\nWHERE\n coll = $eid AND\n i >= $new_size"); }; return ($ne, $modify, $add, $remove); } sub erase { my ($self, $storage, $obj, $members, $coll_id) = @_; $coll_id = $storage->{export_id}->($coll_id); foreach my $def (values %$members) { $storage->sql_do("DELETE FROM\n $def->{table}\nWHERE\n coll = $coll_id"); } } sub coldefs { my ($self, $cols, $members, $schema, $class, $tables) = @_; foreach my $member (values %$members) { $tables->{ $member->{table} }{COLS} = { coll => $schema->{sql}{id}, i => 'INT', v => $member->{sql} }; } } sub query_expr { my ($self, $obj, $members, $tid) = @_; map { Tangram::Expr::FlatArray->new($obj, $_); } values %$members; } sub remote_expr { my ($self, $obj, $tid) = @_; Tangram::Expr::FlatArray->new($obj, $self); } sub prefetch { my ($self, $storage, $def, $coll, $class, $member, $filter) = @_; my $prefetch = $storage->{PREFETCH}{$class}{$member} ||= {}; my $restrict = $filter ? ",\n" . $filter->from() . "\nWHERE\n " . $filter->where() : ''; my $sth = $storage->sql_prepare( "SELECT\n coll,\n i,\n v\nFROM\n $def->{table} $restrict", $storage->{db}); $sth->execute(); for my $row (@{ $sth->fetchall_arrayref() }) { my ($id, $i, $v) = @$row; $prefetch->{$id}[$i] = $v; } # use Data::Dumper; print STDERR Dumper $storage->{PREFETCH}, "\n"; return $prefetch; } 1; Tangram-2.10/lib/Tangram/Type/Array/FromOne.pm0000644000175000017500000001310410412412630017554 0ustar samvsamv use strict; package Tangram::Type::Array::FromOne; use Tangram::Type::Abstract::Array; use vars qw(@ISA); @ISA = qw( Tangram::Type::Abstract::Array ); use Carp; sub reschema { my ($self, $members, $class, $schema) = @_; foreach my $member (keys %$members) { my $def = $members->{$member}; unless (ref($def)) { $def = { class => $def }; $members->{$member} = $def; } $def->{coll} ||= ($schema->{normalize}->($class) . "_$member"); $def->{slot} ||= ($schema->{normalize}->($class) . "_$member" . "_slot"); $schema->{classes}{$def->{class}}{stateless} = 0; if (exists $def->{back}) { my $back = $def->{back} ||= $def->{item}; $schema->{classes}{ $def->{class} }{members}{backref}{$back} = bless { name => $back, col => $def->{coll}, class => $class, field => $member }, 'Tangram::Type::BackRef'; } } return keys %$members; } sub defered_save { use integer; my ($self, $storage, $obj, $field, $def) = @_; #my $classes = $storage->{schema}{classes}; #my $old_states = $storage->{scratch}{ref($self)}{$coll_id}; # foreach my $field (keys %$members) { return if tied $obj->{$field}; my $coll_id = $storage->export_object($obj); my $classes = $storage->{schema}{classes}; my $item_classdef = $classes->{ $def->{class} }; my $table = $item_classdef->{table} or die; my $item_col = $def->{coll}; my $slot_col = $def->{slot}; my $coll = $obj->{$field}; my $coll_size = @$coll; my @new_state = (); my $old_state = $self->get_load_state($storage, $obj, $field) || []; my $old_size = $old_state ? @$old_state : 0; # FIXME - where on earth are the undef values coming from ? :( @$old_state = grep { defined } @$old_state; my %removed; @removed{ @$old_state } = () if $old_state; my $slot = 0; while ($slot < $coll_size) { my $item_id = $storage->id( $coll->[$slot] ) || die; my $ex_item_id = $storage->{export_id}->($item_id); $storage->sql_do ("UPDATE\n $table\nSET\n " ."$item_col = $coll_id,\n " ."$slot_col = $slot\nWHERE\n " ."$storage->{schema}{sql}{id_col} = $ex_item_id") unless $slot < $old_size && $item_id eq $old_state->[$slot]; push @new_state, $item_id; delete $removed{$item_id}; ++$slot; } if (keys %removed) { my $removed = join(', ', map { $storage->{export_id}->($_) } keys %removed); $storage->sql_do("UPDATE\n $table\nSET\n $item_col = NULL,\n $slot_col = NULL\nWHERE\n $storage->{schema}{sql}{id_col} IN ($removed)"); } $self->set_load_state($storage, $obj, $field, \@new_state); $storage->tx_on_rollback( sub { $self->set_load_state($storage, $obj, $field, $old_state) } ); } sub erase { my ($self, $storage, $obj, $members, $coll_id) = @_; $coll_id = $storage->{export_id}->($coll_id); foreach my $member (keys %$members) { my $def = $members->{$member}; if ($def->{aggreg}) { $storage->erase( @{ $obj->{$member} } ); } else { my $item_classdef = $storage->{schema}{classes}{$def->{class}}; my $table = $item_classdef->{table} || $def->{class}; my $item_col = $def->{coll}; my $slot_col = $def->{slot}; $storage->sql_do("UPDATE\n $table\nSET\n $item_col = NULL,\n $slot_col = NULL\nWHERE\n $item_col = $coll_id" ); } } } sub cursor { my ($self, $def, $storage, $obj, $member) = @_; my $cursor = Tangram::Cursor::Coll->new($storage, $def->{class}, $storage->{db}); my $item_col = $def->{coll}; my $slot_col = $def->{slot}; my $coll_id = $storage->export_object($obj); my $tid = $cursor->{TARGET}->object->{table_hash}{$def->{class}}; # $cursor->{TARGET}->object->leaf_table; $cursor->{-coll_cols} = "t$tid.$slot_col"; $cursor->{-coll_where} = "t$tid.$item_col = $coll_id"; return $cursor; } sub query_expr { my ($self, $obj, $members, $tid) = @_; map { Tangram::Expr::Coll::FromOne->new($obj, $_); } values %$members; } sub remote_expr { my ($self, $obj, $tid) = @_; Tangram::Expr::Coll::FromOne->new($obj, $self); } sub prefetch { my ($self, $storage, $def, $coll, $class, $member, $filter) = @_; my $ritem = $storage->remote($def->{class}); my $prefetch = $storage->{PREFETCH}{$class}{$member} ||= {}; # weakref my $cursor = Tangram::Cursor->new($storage, $ritem, $storage->{db}); my $includes = $coll->{$member}->includes($ritem); $includes &= $filter if $filter; # also retrieve collection-side id and index of elmt in sequence $cursor->retrieve($coll->{id}, $storage->expr(Tangram::Type::Integer->instance, "t$ritem->{_object}{table_hash}{$def->{class}}.$def->{slot}") ); $cursor->select($includes); while (my $item = $cursor->current) { my ($coll_id, $slot) = $cursor->residue; ($prefetch->{$coll_id}||=[])->[$slot] = $item; $cursor->next; } return $prefetch; } $Tangram::Schema::TYPES{iarray} = Tangram::Type::Array::FromOne->new; #--------------------------------------------------------------------- # Tangram::Type::Array::FromOne->coldefs($cols, $members, $schema, $class, # $tables) # # Setup column mappings for one to many ordered mappings (foreign # key with associated integer category/column) #--------------------------------------------------------------------- sub coldefs { my ($self, $cols, $members, $schema, $class, $tables) = @_; foreach my $member (values %$members) { my $table = $tables->{ $schema->{classes}{$member->{class}}{table} } ||= {}; $table->{COLS}{$member->{coll}} = "$schema->{sql}{id} $schema->{sql}{default_null}"; $table->{COLS}{$member->{slot}} = "INT $schema->{sql}{default_null}"; } } 1; Tangram-2.10/lib/Tangram/Type/Array/FromOne.pod0000644000175000017500000000544710412412630017735 0ustar samvsamv=head1 NAME Tangram::Type::Array::FromOne - map Perl arrays using a foreign key =head1 SYNOPSIS use Tangram; # or use Tangram::Core; use Tangram::Type::Array::FromOne; $schema = Tangram::Schema->new( classes => { Agenda => { fields => { iarray => { # long form entries => { class => 'Entry', coll => 'agenda', }, # or (short form) entries => 'Entry', } =head1 DESCRIPTION This class maps references to a Perl array in an intrusive fashion. The persistent fields are grouped in a hash under the C key in the field hash. The array may contain only objects of persistent classes. These classes must have a common persistent base class. Tangram uses two columns on the element's table to store: =over 4 =item * the id of the object containing the collection =item * the position of the element in the collection =back CAUTION: the same object may not be an element of the same collection, in two different objects. This mapping may be used only for one-to-many relationships. The field names are passed in a hash that associates a field name with a field descriptor. The field descriptor may be either a hash or a string. The hash uses the following fields: =over 4 =item * class =item * aggreg =item * back =item * coll =item * slot =item * deep_update =back Mandatory field C specifies the class of the elements. Optional field C specifies that the elements of the collection must be removed (erased) from persistent storage along with the containing object. The default is not to aggregate. Optional field C sets the name of a field that is inserted in the elements. That field acts as a demand-loaded, read-only reference to the object containing the collection. Optional field C sets the name the column containing the id of the containing object. This defaults to 'C_m', where 'C' is the class of the containing object, and 'm' is the field name. Optional field C sets the name the column containing the id of the containing object. This defaults to 'C_m_slot', where 'C' is the class of the containing object, and 'm' is the field name. The "C" in C_m and C_m_slot are passed through the schema normalisation function before being combined into a column name. Optional field C specificies that all elements have to be updated automatically when C is called on the collection object. Automatic update ensures consisitency between the Perl representation and the DBMS state, but degrades update performance so use it with caution. The default is not to do automatic updates. If the descriptor is a string, it is interpreted as the name of the element's class. This is equivalent to specifying only the C field in the hash variant. Tangram-2.10/lib/Tangram/Type/Array/FromMany.pod0000644000175000017500000000513210412412630020107 0ustar samvsamv# -*- perl -*- =head1 NAME Tangram::Type::Array::FromMany - map Perl arrays using a link table =head1 SYNOPSIS use Tangram; # or use Tangram::Core; use Tangram::Type::Array::FromMany; $schema = Tangram::Schema->new( classes => { Company => { fields => { array => { # long form employee => { class => 'Person', table => 'Company_employees', coll => 'company', item => 'employee', slot => 'slot' }, # short form assets => 'Asset', } =head1 DESCRIPTION Maps references to a Perl array. The persistent fields are grouped in a hash under the C key in the field hash. The array may contain only objects of persistent classes. These classes must have a common persistent base class. Tangram uses a link table to save the state of the collection. The table has three columns, which contain =over 4 =item * the id of the container objects =item * the id of the elements =item * the position of the element in the array =back The field names are passed in a hash that associates a field name with a field descriptor. The field descriptor may be either a hash or a string. The hash uses the following fields: =over 4 =item * class =item * aggreg =item * table =item * coll =item * item =item * slot =item * deep_update =back Mandatory field C specifies the class of the elements. Optional field C specifies that the elements of the collection must be removed (erased) from persistent storage along with the containing object. The default is not to aggregate. Optional field C
sets the name of the link table. This defaults to 'C_F', where C is the class of the containing object and F is the field name. Optional field C sets the name the column containing the ids of the containing objects. This defaults to 'coll'. Optional field C sets the name the column containing the ids of the elements. This defaults to 'item'. Optional field C sets the name the column containing the position of the elements. This defaults to 'slot'. Optional field C specificies that all elements have to be updated automatically when C is called on the collection object. Automatic update ensures consisitency between the Perl representation and the DBMS state, but degrades update performance so use it with caution. The default is not to do automatic updates. If the descriptor is a string, it is interpreted as the name of the element's class. This is equivalent to specifying only the C field in the hash variant. Tangram-2.10/lib/Tangram/Type/Array/Scalar.pod0000644000175000017500000000413410412412630017565 0ustar samvsamv=head1 NAME Tangram::Type/Array/Scalar - map Perl array of strings or numbers =head1 SYNOPSIS use Tangram::Core; use Tangram::Type/Array/Scalar; # always $schema = Tangram::Schema->new( classes => { NaturalPerson => { fields => { flat_array => { interests => { table => 'NP_int', sql => 'VARCHAR(50)', }, lucky_numbers => 'int', # use defaults } =head1 DESCRIPTION Maps references to a Perl array. The persistent fields are grouped in a hash under the C key in the field hash. The array may contain only 'simple' scalars like integers, strings or real numbers. It may not contain references. For arrays of objects, see L and L. Tangram uses a table to save the state of the collection. The table has three columns, which contain =over 4 =item * the id of the container object =item * the position of the element in the array =item * the value of the element =back The field names are passed in a hash that associates a field name with a field descriptor. The field descriptor may be either a hash or a string. The hash uses the following fields: =over 4 =item * type =item * table =item * sql =back Optional field C specifies the type of the elements. If the type is CTangram quotes the values as they are passed to the database. Not specifying a C is exactly equivalent to specifying C. Optional field C
sets the name of the table that contains the elements. This defaults to 'C_F', where C is the class of the containing object and F is the field name. Optional field C specifies the type that deploy() (see L) should use for the column containing the elements. If this field is not present, the SQL type is derived from the C field: if C is C (or is absent) VARCHAR(255) is used; otherwise, the C field is interpreted as a SQL type. If the descriptor is a string, it is interpreted as the value of the C field and all the other fields take the default value. Tangram-2.10/lib/Tangram/Type/Array/FromMany.pm0000644000175000017500000001124510412412630017743 0ustar samvsamv use strict; package Tangram::Type::Array::FromMany; use Tangram::Type::Abstract::Array; use vars qw(@ISA); @ISA = qw( Tangram::Type::Abstract::Array ); use Carp; sub reschema { my ($self, $members, $class, $schema) = @_; foreach my $member (keys %$members) { my $def = $members->{$member}; unless (ref($def)) { $def = { class => $def }; $members->{$member} = $def; } $def->{table} ||= $schema->{normalize}->($def->{class} . "_$member", 'tablename'); $def->{coll} ||= 'coll'; $def->{item} ||= 'item'; $def->{slot} ||= 'slot'; } return keys %$members; } sub get_save_closures { my ($self, $storage, $obj, $def, $id) = @_; my ($table, $cc, $ic, $sc) = @{ $def }{ qw( table coll item slot ) }; my $ne = sub { shift() != shift() }; my $eid = $storage->{export_id}->($id); my $modify = sub { my ($slot, $item) = @_; my $item_id = $storage->export_object($item) || croak "element at $slot has no id"; $storage->sql_do( "UPDATE\n $table\nSET\n $ic = $item_id\nWHERE\n $cc = $eid AND\n $sc = $slot"); }; my $add = sub { my ($slot, $item) = @_; my $item_id = $storage->export_object($item); $storage->sql_do( "INSERT INTO $table ($cc, $ic, $sc)\n VALUES ($eid, $item_id, $slot)"); }; my $remove = sub { my ($new_size) = @_; $storage->sql_do( "DELETE FROM\n $table\nWHERE\n $cc = $eid AND\n $sc >= $new_size"); }; return ($ne, $modify, $add, $remove); } sub erase { my ($self, $storage, $obj, $members, $coll_id) = @_; $coll_id = $storage->{export_id}->($coll_id); foreach my $member (keys %$members) { my $def = $members->{$member}; my $table = $def->{table} || $def->{class} . "_$member"; my $coll_col = $def->{coll} || 'coll'; my $sql = "DELETE FROM\n $table\nWHERE\n $coll_col = $coll_id"; if ($def->{aggreg}) { my @content = @{ $obj->{$member} }; $storage->sql_do($sql); $storage->erase( @content ) ; } else { $storage->sql_do($sql); } } } sub cursor { my ($self, $def, $storage, $obj, $member) = @_; my $cursor = Tangram::Cursor::Coll->new($storage, $def->{class}, $storage->{db}); my $coll_id = $storage->export_object($obj); my $coll_tid = $storage->alloc_table; my $table = $def->{table}; my $item_tid = $cursor->{TARGET}->object->root_table; my $coll_col = $def->{coll}; my $item_col = $def->{item}; my $slot_col = $def->{slot}; $cursor->{-coll_tid} = $coll_tid; $cursor->{-coll_cols} = "t$coll_tid.$slot_col"; $cursor->{-coll_from} = "$table t$coll_tid"; $cursor->{-coll_where} = "t$coll_tid.$coll_col = $coll_id AND t$coll_tid.$item_col = t$item_tid.$storage->{schema}{sql}{id_col}"; return $cursor; } sub remote_expr { my ($self, $obj, $tid) = @_; Tangram::Expr::Coll::FromMany->new($obj, $self); } sub query_expr { my ($self, $obj, $members, $tid) = @_; map { Tangram::Expr::Coll::FromMany->new($obj, $_); } values %$members; } sub prefetch { my ($self, $storage, $def, $coll, $class, $member, $filter) = @_; my $ritem = $storage->remote($def->{class}); # first retrieve the collection-side ids of all objects satisfying $filter # empty the corresponding prefetch array my $ids = $storage->my_select_data( cols => [ $coll->{id} ], filter => $filter ); my $prefetch = $storage->{PREFETCH}{$class}{$member} ||= {}; # weakref while (my ($id) = $ids->fetchrow) { $prefetch->{$id} = [] } undef $ids; # now fetch the items my $cursor = Tangram::Cursor->new($storage, $ritem, $storage->{db}); my $includes = $coll->{$member}->includes($ritem); # also retrieve collection-side id and index of elmt in sequence $cursor->retrieve($coll->{id}, Tangram::Type::Number->expr("t$includes->{link_tid}.$def->{slot}") ); $cursor->select($filter ? $filter & $includes : $includes); while (my $item = $cursor->current) { my ($coll_id, $slot) = $cursor->residue; $prefetch->{$coll_id}[$slot] = $item; $cursor->next; } return $prefetch; } $Tangram::Schema::TYPES{array} = Tangram::Type::Array::FromMany->new; #--------------------------------------------------------------------- # Tangram::Type::Array::FromMany->coldefs($cols, $members, $schema, $class, $tables) # # Setup column mappings for many to many unordered mappings (link # table with integer category) #--------------------------------------------------------------------- sub coldefs { my ($self, $cols, $members, $schema, $class, $tables) = @_; foreach my $member (values %$members) { my $COLS = $tables->{ $member->{table} }{COLS} ||= { }; $COLS->{$member->{coll}} = $schema->{sql}{id}; $COLS->{$member->{item}} = $schema->{sql}{id}; $COLS->{$member->{slot}} = "INT $schema->{sql}{default_null}"; } } 1; Tangram-2.10/lib/Tangram/Type/Abstract/0000755000175000017500000000000010412420117016336 5ustar samvsamvTangram-2.10/lib/Tangram/Type/Abstract/Set.pm0000644000175000017500000001032610412412630017432 0ustar samvsamv use strict; use Tangram::Type::Abstract::Coll; package Tangram::Type::Abstract::Set; use vars qw(@ISA); @ISA = qw( Tangram::Type::Abstract::Coll ); use Carp; # Support for classes that lazily create Set::Objects for instance vars. # -- ks.perl@kurtstephens.com 2004/03/30 sub __lazy_members { $_[0] ? $_[0]->members : (); } sub get_exporter { my ($self, $context) = @_; my $field = $self->{name}; return $self->{deep_update} ? sub { my ($obj, $context) = @_; # has collection been loaded? if not, then it hasn't been modified return if tied $obj->{$field}; my $storage = $context->{storage}; foreach my $item ( __lazy_members($obj->{$field}) ) { $storage->_save($item, $context->{SAVING}); } print $Tangram::TRACE "Tangram::Type::Abstract::Set: defering members save of $obj.$field\n" if $Tangram::TRACE and $Tangram::DEBUG_LEVEL > 1; $storage->defer(sub { $self->defered_save(shift, $obj, $field, $self) } ); return (); } : sub { my ($obj, $context) = @_; # has collection been loaded? if not, then it hasn't been modified my $tied = tied $obj->{$field}; my $storage = $context->{storage}; if ($tied and $tied->can("storage") and $tied->storage == $storage ) { #print STDERR "not saving $obj -> {$field} (tied = $tied)\n"; return; } if (my $s = $obj->{$field}) { if (!UNIVERSAL::isa($s, "Set::Object")) { die "Data error in ${obj}"."->{$field}; expected " ."Set, got $s" } else { foreach my $item ( $s->members ) { $storage->insert($item) unless $storage->id($item); } } } print $Tangram::TRACE "Tangram::Type::Abstract::Set: defering members save of $obj.$field\n" if $Tangram::TRACE and $Tangram::DEBUG_LEVEL > 1; $storage->defer(sub { $self->defered_save(shift, $obj, $field, $self) } ); return (); } } sub update { my ($self, $storage, $obj, $member, $insert, $remove) = @_; return unless defined $obj->{$member}; my $coll_id = $storage->id($obj); my $old_state = $self->get_load_state($storage, $obj, $member); if ( $Tangram::TRACE and $Tangram::DEBUG_LEVEL > 2 ) { require YAML; print $Tangram::TRACE ("Tangram::Type::Abstract::Set->update(".ref($obj). "[$coll_id].$member); old state: ".YAML::Dump($old_state)); } my %new_state = (); foreach my $item ( __lazy_members($obj->{$member}) ) { my $item_id = $storage->id($item) || croak "member $item has no id"; unless (exists $old_state->{$item_id}) { print $Tangram::TRACE "Tangram::Type::Abstract::Set->update(".ref($obj). "[$coll_id].$member): adding $item_id\n" if ( $Tangram::TRACE and $Tangram::DEBUG_LEVEL > 2 ); $insert->($storage->{export_id}->($item_id), $item_id); } $new_state{$item_id} = 1; } my $gone; foreach my $del (keys %$old_state) { next if $new_state{$del}; print $Tangram::TRACE "Tangram::Type::Abstract::Set->update(".ref($obj). "[$coll_id].$member): removing $del\n" if ( $Tangram::TRACE and $Tangram::DEBUG_LEVEL > 2 ); $remove->($storage->{export_id}->($del), $del); $gone++; } print $Tangram::TRACE "Tangram::Type::Abstract::Set->update(".ref($obj). "[$coll_id].$member): removed $gone rows\n" if ( $Tangram::TRACE and $gone and $Tangram::DEBUG_LEVEL > 2 ); $self->set_load_state($storage, $obj, $member, \%new_state); $storage->tx_on_rollback ( sub { $self->set_load_state($storage, $obj, $member, $old_state); } ); if ( $Tangram::TRACE and $Tangram::DEBUG_LEVEL > 2 ) { print $Tangram::TRACE ("Tangram::Type::Abstract::Set->update(".ref($obj). "[$coll_id].$member); new: ".YAML::Dump(\%new_state)); } } sub remember_state { my ($self, $def, $storage, $obj, $member, $set) = @_; my %new_state; for my $member ( __lazy_members($set) ) { my $id = $storage->id($member); $id && ($new_state{ $id } = 1); } if ( $Tangram::TRACE and $Tangram::DEBUG_LEVEL > 2 ) { require 'YAML.pm'; print $Tangram::TRACE "Tangram::Type::Abstract::Set->remember(".ref($self)."[".$storage->id($obj)."].$member); new: ".YAML::Dump(\%new_state); } $self->set_load_state($storage, $obj, $member, \%new_state); } sub content { shift; __lazy_members(shift); #?#? } 1; Tangram-2.10/lib/Tangram/Type/Abstract/Coll.pm0000644000175000017500000000441110412412630017566 0ustar samvsamv package Tangram::Type::Abstract::Coll; use strict; use Tangram::Expr::TableAlias; use Tangram::Expr::Coll; use Tangram::Expr::Coll::FromMany; use Tangram::Expr::Coll::FromOne; use Tangram::Lazy::Coll; use Tangram::Expr::LinkTable; use Tangram::Type; use Tangram::Type::Ref::FromMany; use Tangram::Type::BackRef; use Tangram::Type::BackRef; use vars qw(@ISA); @ISA = qw( Tangram::Type ); sub get_import_cols { () } sub get_importer { my ($self, $context) = @_; my $class = $context->{class}{name}; my $field = $self->{name}; return sub { my ($obj, $row, $context) = @_; tie $obj->{$field}, 'Tangram::Lazy::Coll', $self, $self, $context->{storage}, $context->{id}, $self->{name}, $class; } } sub read { my ($self, $row, $obj, $members, $storage, $class) = @_; foreach my $member (keys %$members) { tie $obj->{$member}, 'Tangram::Lazy::Coll', $self, $members->{$member}, $storage, $storage->id($obj), $member, $class; } } sub bad_type { my ($obj, $coll, $class, $item) = @_; die "$item is not a '$class' in collection '$coll' of $obj"; } sub set_load_state { my ($self, $storage, $obj, $member, $state) = @_; $storage->{scratch}{ref($self)}{$storage->id($obj)}{$member} = $state; } sub get_load_state { my ($self, $storage, $obj, $member) = @_; return $storage->{scratch}{ref($self)}{$storage->id($obj)}{$member}; } sub array_diff { my ($new_state, $old_state, $differ) = @_; return (0, []) unless $new_state && $old_state; $differ ||= sub { shift() != shift() }; my $old_size = @$old_state; my $new_size = @$new_state; my $common = $old_size < $new_size ? $old_size : $new_size; use integer; my @changed = grep { $differ->($old_state->[$_], $new_state->[$_]) } 0 .. ($common-1); return ($common, \@changed); } package Tangram::Cursor::Coll; @Tangram::Cursor::Coll::ISA = 'Tangram::Cursor'; sub build_select { my ($self, $template, $cols, $from, $where) = @_; push @$where, $self->{-coll_where} if $self->{-coll_where}; push @$cols, $self->{-coll_cols} if exists $self->{-coll_cols}; push @$from, $self->{-coll_from} if exists $self->{-coll_from}; $self->SUPER::build_select($template, $cols, $from, $where); } sub DESTROY { my ($self) = @_; #print "@{[ keys %$self ]}\n"; # $self->{-storage}->free_table($self->{-coll_tid}); } 1; Tangram-2.10/lib/Tangram/Type/Abstract/Array.pm0000644000175000017500000000736410412412630017765 0ustar samvsamv use strict; use Tangram::Type::Abstract::Coll; package Tangram::Type::Abstract::Array; use vars qw(@ISA); @ISA = qw( Tangram::Type::Abstract::Coll ); use Carp; sub demand { my ($self, $def, $storage, $obj, $member, $class) = @_; my (@coll, @lost); if (my $prefetch = $storage->{PREFETCH}{$class}{$member}{$storage->export_object($obj)}) { print $Tangram::TRACE "demanding ".$storage->id($obj) .".$member from prefetch\n" if $Tangram::TRACE; @coll = @$prefetch; } else { print $Tangram::TRACE "demanding ".$storage->id($obj) .".$member from storage\n" if $Tangram::TRACE; my $cursor = $self->cursor($def, $storage, $obj, $member); for (my $item = $cursor->select(); $item; $item = $cursor->next) { my $slot = shift @{ $cursor->{-residue} }; if (defined $slot) { $coll[$slot] = $item; } else { warn "object ".$storage->id($item)." has no slot in array ".$storage->id($obj)."/$member!"; push @lost, $item } } # last-ditch effort to automatically DTRT if (@lost) { foreach(@coll) { if (!defined $_) { $_ = shift @lost; } last unless @lost; } push @coll, @lost; } } $self->set_load_state($storage, $obj, $member, [ map { ($_) ? $storage->id($_) : undef } @coll ]); return \@coll; } sub get_export_cols { return (); # arrays are not stored on object's table } sub save_content { my ($obj, $field, $context) = @_; # has collection been loaded? if not, then it hasn't been modified my $tied = tied $obj->{$field}; my $storage = $context->{storage}; if ($tied and $tied->can("storage") and $tied->storage == $storage ) { #print STDERR "not saving $obj -> {$field} (tied = $tied)\n"; return; } foreach my $item (@{ $obj->{$field} }) { $storage->insert($item) unless $storage->id($item); } } sub deep_save_content { my ($obj, $field, $context) = @_; # has collection been loaded? if not, then it hasn't been modified return if tied $obj->{$field}; my $storage = $context->{storage}; foreach my $item (@{$obj->{$field}}) { $storage->_save($item, $context->{SAVING}); } } sub check_content { my ($obj, $field, $coll, $class) = @_; foreach my $item ($obj->{$field}) { Tangram::Type::Abstract::Coll::bad_type($obj, $field, $class, $item) unless $item->isa($class); } } sub get_exporter { my ($self, $context) = @_; my $save_content = $self->{deep_update} ? \&deep_save_content : \&save_content; my $field = $self->{name}; return sub { my ($obj, $context) = @_; $save_content->($obj, $self->{name}, $context); $context->{storage}->defer(sub { $self->defered_save(shift, $obj, $field, $self) } ); (); } } sub defered_save { use integer; my ($self, $storage, $obj, $field, $def) = @_; return if tied $obj->{$field}; # collection has not been loaded, thus not modified my $coll_id = $storage->id($obj); my ($ne, $modify, $add, $remove) = $self->get_save_closures($storage, $obj, $def, $storage->id($obj)); my $new_state = $obj->{$field} || []; my $new_size = @$new_state; my $old_state = $self->get_load_state($storage, $obj, $field) || []; my $old_size = @$old_state; my ($common, $changed) = Tangram::Type::Abstract::Coll::array_diff($new_state, $old_state, $ne); for my $slot (@$changed) { $modify->($slot, $new_state->[$slot], $old_state->[$slot]); } for my $slot ($old_size .. ($new_size-1)) { $add->($slot, $new_state->[$slot]); } if ($old_size > $new_size) { $remove->($new_size, $old_size); } $self->set_load_state($storage, $obj, $field, [ @$new_state ] ); $storage->tx_on_rollback( sub { $self->set_load_state($storage, $obj, $field, $old_state) } ); } 1; Tangram-2.10/lib/Tangram/Type/Abstract/Hash.pm0000644000175000017500000000507110412412630017563 0ustar samvsamv use strict; package Tangram::Type::Abstract::Hash; use Tangram::Type::Abstract::Coll; use vars qw(@ISA); @ISA = qw( Tangram::Type::Abstract::Coll ); use Carp; sub content { shift; @{shift()}; } sub demand { my ($self, $def, $storage, $obj, $member, $class) = @_; my %coll; if (my $prefetch = $storage->{PREFETCH}{$class}{$member}{$storage->export_object($obj)}) { print $Tangram::TRACE "demanding ".$storage->id($obj) .".$member from prefetch\n" if $Tangram::TRACE; %coll = %$prefetch; } else { print $Tangram::TRACE "demanding ".$storage->id($obj) .".$member from storage\n" if $Tangram::TRACE; my $cursor = $self->cursor($def, $storage, $obj, $member); my @lost; for (my $item = $cursor->select; $item; $item = $cursor->next) { my $slot = shift @{ $cursor->{-residue} }; if (!defined($slot)) { warn "object ".$storage->id($item)." has no slot in hash ".$storage->id($obj)."/$member!"; push @lost, $item; } else { $coll{$slot} = $item; } } # Try to DTRT when you've got NULL slots, though this # isn't much of a RT to D. while (@lost) { my $c = 0; while (!exists $coll{$c++}) { } $coll{$c} = shift @lost; } } $self->set_load_state($storage, $obj, $member, { map { ($_ ? ($_ => ($coll{$_} && $storage->id( $coll{$_} ) ) ) : ()) } keys %coll } ); return \%coll; } sub save_content { my ($obj, $field, $context) = @_; # has collection been loaded? if not, then it hasn't been modified my $tied = tied $obj->{$field}; my $storage = $context->{storage}; if ($tied and $tied->can("storage") and $tied->storage == $storage ) { #print STDERR "not saving $obj -> {$field} (tied = $tied)\n"; return; } return unless exists $obj->{$field} && defined $obj->{$field}; foreach my $item (values %{ $obj->{$field} }) { $storage->insert($item) unless $storage->id($item); } } sub get_exporter { my ($self, $context) = @_; my $field = $self->{name}; return sub { my ($obj, $context) = @_; my $tied = tied $obj->{$field}; my $storage = $context->{storage}; if ($tied and $tied->can("storage") and $tied->storage == $storage ) { #print STDERR "not saving $obj -> {$field} (tied = $tied)\n"; return; } return unless exists $obj->{$field} && defined $obj->{$field}; foreach my $item (values %{ $obj->{$field} }) { $storage->insert($item) unless $storage->id($item); } $context->{storage}->defer(sub { $self->defered_save($obj, $field, $storage) } ); (); } } 1; Tangram-2.10/lib/Tangram/Type/Date.pm0000644000175000017500000000051610412412630016011 0ustar samvsamv use strict; use Tangram::Type::Scalar; package Tangram::Type::Date; use vars qw(@ISA); @ISA = qw( Tangram::Type::String ); $Tangram::Schema::TYPES{rawdate} = Tangram::Type::Date->new; sub coldefs { my ($self, $cols, $members, $schema) = @_; $self->_coldefs($cols, $members, "DATE $schema->{sql}{default_null}"); } 1; Tangram-2.10/lib/Tangram/Type/Real.pm0000644000175000017500000000061510412412630016017 0ustar samvsamv package Tangram::Type::Real; use Tangram::Type::Number; use strict; use vars qw(@ISA); BEGIN { @ISA = qw( Tangram::Type::Number ); } #use Class::ISA; #use YAML; #print YAML::Dump([Class::ISA::super_path(__PACKAGE__)]); $Tangram::Schema::TYPES{real} = __PACKAGE__->new; sub coldefs { my ($self, $cols, $members, $schema) = @_; $self->_coldefs($cols, $members, 'REAL', $schema); } 1; Tangram-2.10/lib/Tangram/Type/Scalar.pod0000644000175000017500000000436510412412630016515 0ustar samvsamv=head1 NAME Tangram::Type::Scalar - map scalar fields =head1 SYNOPSIS use Tangram; Tangram::Schema->new( classes => { NaturalPerson => { fields => { string => [ qw( name firstName gender ) ], int => [ qw( age ) ], real => [ qw( height weight ) ], $schema = Tangram::Schema->new( classes => { NaturalPerson => { fields => { string => { name => { sql => 'VARCHAR(100)' }, 1stname => { col => 'firstName', sql => 'VARCHAR(100) NULL' }, gender => undef() }, =head1 DESCRIPTION Classes Tangram::Type::String, ::Int and ::Real and ::Ref are responsible for mapping the various subtypes of scalars. The first three mappings are documented here since they differ very little. See L for information on mapping references. Tangram::Type::String uses DBI's quote() method to quote strings if that method is available, thus making it possible to store binary objects or multiline text in databases that support it (thanks to Marian Kelc for suggesting this improvement). The three predefined typetags C, C and C are for the corresponding Perl scalar subtypes. Each scalar field is stored in a single column of the table associated to the class. The persistent fields may be specified either as a hash or as an array of field names. In the hash form, each entry consists in a field name and an associated option hash. The option hash may contain the following fields: =over 4 =item * col =item * sql =item * automatic =back Csets the name of the column used to store the field's value. This field is optional, it defaults to the persistent field name. Override if the field name is not an acceptable SQL column name. C sets the SQL type of the column. Used by Schema::deploy() when initializing a database. Defaults to 'VARCHAR(255) NULL' for strings, 'INT NULL' for ints and 'REAL NULL' for reals. C, if set to true, tells Tangram not to save the field to storage. This is useful for auto-increment or timestamp columns. The persistent fields may also be specified as an array of strings, in which case the defaults are used. Tangram-2.10/lib/Tangram/Type/Number.pm0000644000175000017500000000035710412412630016367 0ustar samvsamv package Tangram::Type::Number; use Tangram::Type::Scalar; use strict; use vars qw(@ISA); @ISA = qw( Tangram::Type::Scalar ); sub get_export_cols { my ($self) = @_; return exists $self->{automatic} ? () : ($self->{col}); } 1; Tangram-2.10/lib/Tangram/Type/Dump.pm0000644000175000017500000001370010412412630016040 0ustar samvsamv package Tangram::Type::Dump; =head1 NAME Tangram::Type::Dump - Handy functions for Pixie-like dumping of data =head1 SYNOPSIS use Tangram::Type::Dump qw(flatten unflatten UNflatten nuke); use YAML qw(freeze thaw); # for instance my $frozen = freeze flatten($storage, $structure); # optional - remove circular references from flattened # structure so that it is freed up properly. nuke $frozen; # save frozen somewhere... # restore, but don't load objects straight away my $reconstituted = unflatten($storage, thaw $frozen); # restore, loading objects immediately my $original = UNflatten($storage, $frozen); # Alternative, quickly marshall a structure for saving my $structure; flatten($storage, $structure); # ... do something with it ... # restore to former glory; note that Tangram's cache will # prevent unnecessary DB access. unflatten($storage, $structure); =head1 DESCRIPTION This module contains functions for traversing data structures which are I Tangram-registered objects, and replacing all the Tangram objects found with `Mementos'. When a similar data structure is fed back into the reversal function, the mementos are filled with on-demand references to the real objects. All these functions operate B for maximum efficiency. =cut use Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK); use strict; BEGIN { @ISA=qw(Exporter); @EXPORT_OK=qw(scan flatten unflatten expand nuke); } use Set::Object qw(blessed reftype refaddr); #use Tangram::Info qw(dispel_overload); use Carp; use constant DEBUG => 0; sub debug { print STDERR __PACKAGE__ ."[line ".((caller())[2])."]: @_\n" if DEBUG } =head1 FUNCTIONS =over =item B Traverses the structure B<$structure>, and replaces all the known (ie, already inserted) Tangram objects with references to them =cut sub flatten { my $storage = shift; blessed $storage && $storage->isa("Tangram::Storage") or croak 'usage: flatten($storage, $structure)'; my $structure = shift; ref $structure or return $structure; debug "flatten($structure)"; # check for Tangram objects, replace them with mementos my @obj_stack = $structure; my $seen = Set::Object->new(@obj_stack); my $check = sub { if (my $x = tied $_[0] ) { if ( $x->isa("Tangram::Lazy::Ref") ) { # FIXME - code path not covered by test suite my ($id,$cid) = $storage->split_id($x->id); $id.=",$cid"; #@$x = (); #untie $_[0]; $_[0] = bless \$id, "Tangram::Memento"; } else { # ignore; the user's problem :) } } else { if ( ref $_[0] ) { if (blessed $_[0] and my $id = $storage->id_maybe_insert($_[0])) { ($id,my $cid) = $storage->split_id($id); $id.=",$cid"; $_[0] = bless \$id, "Tangram::Memento"; } elsif ( blessed $_[0] && $_[0]->isa("Set::Object") ) { # FIXME - use Pixie complicity functions to solve this for # the general case. my @objects = $_[0]->members; $_[0]->DESTROY; # arrr! ${$_[0]} = \@objects; # then re-bless it bless $_[0], "Tangram::Memento::Set"; push @obj_stack, ${ $_[0] }; } elsif ($seen->insert($_[0])) { push @obj_stack, $_[0] } } } }; while (my $obj = shift @obj_stack) { if (reftype $obj eq "HASH") { while (my $key = each %$obj) { $check->($obj->{$key}); } } elsif (reftype $obj eq "ARRAY") { for my $i (0..$#$obj) { $check->($obj->[$i]); } } elsif (reftype $obj eq "CODE") { die "CODE references unsafe"; } elsif ( reftype $obj eq "SCALAR" or reftype $obj eq "REF" ) { # better hope it's not a ref to a C data structure :) $check->($$obj); } } use Data::Dumper; (DEBUG > 1) && debug("flattened to: ".Dumper($structure)); } =item B Performs the logical opposite of B, but only insofar as a `normal' user is concerned. `Normal' users, of course, don't care that the data structure is being loaded from the database as they use it :). =cut use Data::Lazy 0.6; sub unflatten { my $storage = shift; blessed $storage && $storage->isa("Tangram::Storage") or croak 'usage: unflatten($storage, $structure)'; my $structure = shift; ref $structure or return $structure; debug "un-flatten $structure"; # look for mementos, replace them with on-demand references my @obj_stack = $structure; my $seen = Set::Object->new(@obj_stack); my $check = sub { if ( tied $_[0] and tied($_[0]) =~ m/^Tangram::Lazy::Ref/ ) { # already a demand paged reference - ignore } else { if ( blessed $_[0] and $_[0]->isa("Tangram::Memento") ) { my ($id, $cid) = ${$_[0]} =~ m{(\d+),(\d+)}; $id = $storage->combine_ids($id,$cid); (DEBUG>1) && debug "setting up Lazy::Ref($id)"; if ( defined($storage->{objects}{$id}) ) { $_[0] = $storage->{objects}{$id}; } else { tie $_[0], 'Tangram::Lazy::Ref', $storage, undef, \$_[0], $id; } } elsif ( blessed $_[0] and $_[0]->isa("Tangram::Memento::Set") ) { my @members = @{${$_[0]}}; tie $_[0], "Data::Lazy", sub { my $x = Set::Object->new(@members); @members=(); $x; }, \$_[0]; push @obj_stack, \@members; } elsif (ref $_[0] && $seen->insert($_[0])) { push @obj_stack, $_[0]; } } }; while (my $obj = shift @obj_stack) { if (reftype $obj eq "HASH") { while (my $key = each %$obj) { $check->($obj->{$key}); } } elsif (reftype $obj eq "ARRAY") { for my $i (0..$#$obj) { $check->($obj->[$i]); } } elsif (reftype $obj eq "CODE") { # ignore.. } elsif (reftype $obj eq "SCALAR" or reftype $obj eq "REF") { $check->($$obj) if ref $$obj; } } return $structure; } 1; __END__ =back =head1 BUGS Should this module just be an extension to Tangram::Storage ? =head1 AUTHOR Sam Vilain, samv@cpan.org. All rights reserved. This code is free software; you can use and/or modify it under the same terms as Perl itself. =cut Tangram-2.10/lib/Tangram/Type/TimeAndDate.pm0000644000175000017500000000054410412412630017254 0ustar samvsamv use strict; use Tangram::Type::Scalar; package Tangram::Type::TimeAndDate; use vars qw(@ISA); @ISA = qw( Tangram::Type::String ); $Tangram::Schema::TYPES{rawdatetime} = Tangram::Type::TimeAndDate->new; sub coldefs { my ($self, $cols, $members, $schema) = @_; $self->_coldefs($cols, $members, "DATETIME $schema->{sql}{default_null}"); } 1; Tangram-2.10/lib/Tangram/Type/Integer.pm0000644000175000017500000000045510412412630016533 0ustar samvsamv package Tangram::Type::Integer; use Tangram::Type::Number; use strict; use vars qw(@ISA); @ISA = qw( Tangram::Type::Number ); $Tangram::Schema::TYPES{int} = __PACKAGE__->new; sub coldefs { my ($self, $cols, $members, $schema) = @_; $self->_coldefs($cols, $members, 'INT', $schema); } 1; Tangram-2.10/lib/Tangram/Type/String.pm0000644000175000017500000000063410412412630016403 0ustar samvsamv package Tangram::Type::String; use Tangram::Type::Scalar; use strict; use vars qw(@ISA); @ISA = qw( Tangram::Type::Scalar ); $Tangram::Schema::TYPES{string} = __PACKAGE__->new; sub literal { my ($self, $lit, $storage) = @_; return $storage->{db}->quote($lit); } sub coldefs { my ($self, $cols, $members, $schema) = @_; $self->_coldefs($cols, $members, 'VARCHAR(255)', $schema); } 1; Tangram-2.10/lib/Tangram/Type/Time.pm0000644000175000017500000000051610412412630016032 0ustar samvsamv use strict; use Tangram::Type::Scalar; package Tangram::Type::Time; use vars qw(@ISA); @ISA = qw( Tangram::Type::String ); $Tangram::Schema::TYPES{rawtime} = Tangram::Type::Time->new; sub coldefs { my ($self, $cols, $members, $schema) = @_; $self->_coldefs($cols, $members, "TIME $schema->{sql}{default_null}"); } 1; Tangram-2.10/lib/Tangram/Type/TimeAndDate.pod0000644000175000017500000000512510412412630017422 0ustar samvsamv=head1 NAME Tangram::Type::TimeAndDate - map date & time fields =head1 SYNOPSIS use Tangram; # any of: use Tangram::Type::Date; # RAW - use with caution use Tangram::Type::Time; use Tangram::Type::Date::Cooked; # pure ISO-8601 use Tangram::Type::Date::DateTime; use Tangram::Type::Date::Manip; use Tangram::Type::Date::TimePiece; Tangram::Schema->new( classes => { NaturalPerson => { fields => { rawdatetime => [ qw( birth death ) ], rawdate => [ qw( depart return ) ], rawtime => [ qw( breakfast lunch dinner ) ], cookeddatetime => [ qw( cooked ) ], dmdatetime => [ qw( datemanip ) ], timepiece => [ qw( fob ) ], datetime => [ qw( bloat ) ], =head1 DESCRIPTION These classes are responsible for mapping strings to SQL date or time types. These classes are not imported by Tangram.pm, thus they must be explicitly imported via a C directive. The three typetags C, C and C are for mapping strings to SQL date/time types, for databases that differentiate between "dates" and "times". 'Raw' means that Tangram doesn't attempt to interpret the strings, it merely passes them down to DBI. C is like C except that the date is converted from the DBMS format to ISO-8601 in the form : YYYY-MM-DDTHH:MM:SS for example: 2004-12-25T13:14:15 Other modules then further cook this ISO date into an object as is the convention for a particular module. This only works with back-ends that allow per-connection settings for the default date format, such as L. On the way back out, the date is converted back to the DBMS format. This is achieved via vendor-specific functions mentioned in C. The persistent fields may be specified either as a hash or as an array of field names. In the hash form, each entry consists in a field name and an associated option hash. The option hash may contain the following fields: =over 4 =item * col =item * sql =back Csets the name of the column used to store the field's value. This field is optional, it defaults to the persistent field name. Override if the field name is not an acceptable SQL column name. C sets the SQL type of the column. Used by Schema::deploy() when initializing a database. Defaults to 'VARCHAR(255) NULL' for strings, 'INT NULL' for ints and 'REAL NULL' for reals. The persistent fields may also be specified as an array of strings, in which case the defaults are used. Tangram-2.10/lib/Tangram/Type/Extending.pod0000644000175000017500000001217710412412630017235 0ustar samvsamv=head1 NAME Tangram::Type::Extending - teaching Tangram about new types =head1 DESCRIPTION Tangram::Type is the root of a hierarchy of classes that are responsible mapping individual field to SQL entities (columns in the simplest cases). There is one Type object per persistent field. Adding support for new types amounts to adding subclasses to Tangram::Type. =head1 WRITING NEW TYPES Tangram is organized in several subsystems, described below. Schema is the repository for information about all the persistent aspects of a system: classes, inheritance relationships, fields, etc. It also contains graph-traversal algorithms, which are not currently documented. Storage deals with objects as a whole: insertion, updating, multiple load detection, cycle handling, transactions, connections. It also serves as an entry point in the system. Storage does not manipulate fields directly. Cursor deals with polymorphic retrieval of objects. It builds SELECT statements on the basis of the information in the hash. Cursor does not manipulate fields directly either. The Type hierarchy deals with individual fields, and not with entire objects. More about it in a moment. The Expr hierarchy deals with entities on the remote side; this includes expressions proper, Filters and Remotes. Types are responsible for performing the mapping between a field of a given Perl type and a relational entity. The simplest Types merely transfer between one Perl field and one column. Sometimes it makes sense to have several mappings (and hence several Types) for the same Perl type; for example, Perl arrays can be mapped either using a link table, or one or several columns that live on the element's table. Users don't deal with Type objects directly: they indicate that a series of fields should be mapped in a certain way by putting the fields under a given 'typetag' in the field hash. The type registers itself with Tangram by adding a typetag in the %Tangram::Schema::TYPES hash. The value is the Type object. Up to now all Types have been singletons, but this is not a rule. Anybody who's planning to write new Types should examine Scalar.pm first. It contains very simple mappings between one field and one column. A Type must implement the methods described below. Keep the following facts in mind while reading further: 1. A Type is responsible for transfering all the *direct* fields for a given *class*. This excludes inherited fields. OTOH, the same Type can be called more than once for the same object, because the same Type may be used in several classes that appear in a particular object's inheritance graph. =head1 INSTANCE METHODS =head2 reschema reschema($self, $members, $class) This method is called when the schema hash is being converted into a Schema object. The Type finds all the fields it is responsible for mapping in the Perl structure refered by $members. The Type decides the exact format of this structure. =head2 get_export_cols get_export_cols($self, $context) Called when building INSERT and UPDATE statements; the Type returns a list of columns to be inserted in the statement. =head2 get_exporter get_exporter($self, $context) Called when building a function for reading the state of an object: the Type may return either a string or a closure. =head2 get_import_cols get_import_cols($self, $context) Called when building SELECT statements; the Type returns a list of columns to be inserted in the statement. =head2 get_importer get_importer($self, $context) Called when building a function for setting the state of an object: the Type may return either a string or a closure. =head2 remote_expr remote_expr($self, $obj, $tid, $storage) Called when building a Remote. The Type returns an Expr object. =head1 HANDLING ASSOCIATIONS Ref and Collections have in common that they don't load their controlled fields upfront. Their importer method ties the controlled fields to a package that will demand-load the final value of the field - if it's ever needed. The exact procedure for achieving this is not imposed by Tangram itself, in fact, a Type has the liberty of doing just anything it sees fit, if it can manage it with the arguments that it gets passed by the higher layer. Ref ties a field to the Lazy::Ref package, and Collections tie to Lazy::Coll. Ref and those collections that contain references to other objects must deal cycles. This can be done quite easily but I don't have to go into those details right now. Collections (of references of or values (the so-called 'flat' collections)) typically save their state when the demand-load is triggered. Later, when the collection is saved, the Collection compares the current field state (iow collection content) with the state at load time, and updates the database accordingly. Types that need to remember field state at load time should store it under $storage->{scratch}{TYPE_CLASS}, and typically under $storage->{scratch}{TYPE_CLASS}{OBJECT_ID}{FIELD}. Coll defines two utility functions to help manage load-time state: * set_load_state($self, $storage, $obj, $field, $state) Remember $state of the $field of $obj, retrieved from $storage. * get_load_state($self, $storage, $obj, $member) Retrieve that state. Tangram-2.10/lib/Tangram/Type/BackRef.pm0000644000175000017500000000154110412412630016430 0ustar samvsamv package Tangram::Type::BackRef; use Tangram::Lazy::BackRef; use strict; use vars qw(@ISA); @ISA = qw( Tangram::Type::Scalar ); $Tangram::Schema::TYPES{backref} = __PACKAGE__->new; sub get_export_cols { () } sub get_exporter { } sub get_importer { my ($self, $context) = @_; my $field = $self->{name}; return sub { my ($obj, $row, $context) = @_; my $rid = shift @$row; if ($rid) { tie $obj->{$field}, 'Tangram::Lazy::BackRef', $context->{storage}, $context->{id}, $self->{name}, $rid, $self->{class}, $self->{field}; } else { $obj->{$field} = undef; } } } #--------------------------------------------------------------------- # Tangram::Type::BackRef->coldefs(...) # # BackRefs do not set up any columns by default. #--------------------------------------------------------------------- sub coldefs { return (); } 1; Tangram-2.10/lib/Tangram/Compat/0000755000175000017500000000000010412420117015075 5ustar samvsamvTangram-2.10/lib/Tangram/Compat/Stub.pm0000644000175000017500000000010510412412630016345 0ustar samvsamv# dummy file that is not so short that `use __PACKAGE__' fails... 1; Tangram-2.10/lib/Tangram/Cursor/0000755000175000017500000000000010412420117015127 5ustar samvsamvTangram-2.10/lib/Tangram/Cursor/Data.pm0000644000175000017500000000153110412412631016340 0ustar samvsamvpackage Tangram::Cursor::Data; use strict; use Carp; sub open { my ($type, $storage, $select, $conn) = @_; confess unless $conn; bless { select => $select, storage => $storage, cursor => $storage->sql_cursor(substr($select->{expr}, 1, -1), $conn), }, $type; } sub fetchrow { my $self = shift; my @row = $self->{cursor}->fetchrow; return () unless @row; map { $_->{type}->read_data(\@row) } @{$self->{select}{cols}}; } sub fetchall_arrayref { my $self = shift; my @results; while (my @row = $self->fetchrow) { push @results, [ @row ]; } return \@results; } sub new { my $pkg = shift; return bless [ @_ ] , $pkg; } sub DESTROY { my $self = shift; $self->close(); } sub close { my $self = shift; $self->{cursor}{connection}->disconnect() unless $self->{cursor}{connection} == $self->{storage}{db}; } 1; Tangram-2.10/lib/Tangram/Cursor/Coll.pm0000644000175000017500000000103210412412631016354 0ustar samvsamv package Tangram::Cursor::Coll; @Tangram::Cursor::Coll::ISA = 'Tangram::Cursor'; sub build_select { my ($self, $template, $cols, $from, $where) = @_; push @$where, $self->{-coll_where} if $self->{-coll_where}; push @$cols, $self->{-coll_cols} if exists $self->{-coll_cols}; push @$from, $self->{-coll_from} if exists $self->{-coll_from}; $self->SUPER::build_select($template, $cols, $from, $where); } sub DESTROY { my ($self) = @_; #print "@{[ keys %$self ]}\n"; # $self->{-storage}->free_table($self->{-coll_tid}); } 1; Tangram-2.10/lib/Tangram/Driver/0000755000175000017500000000000010412420117015105 5ustar samvsamvTangram-2.10/lib/Tangram/Driver/Pg/0000755000175000017500000000000010412420117015453 5ustar samvsamvTangram-2.10/lib/Tangram/Driver/Pg/Storage.pm0000644000175000017500000000055210412412631017421 0ustar samvsamv package Tangram::Driver::Pg::Storage; use strict; use Tangram::Storage; use vars qw(@ISA); @ISA = qw( Tangram::Storage ); sub connect { my $class = shift; my $self = $class->SUPER::connect(@_); $self->{db}->{RaiseError} = 1; return $self; } sub has_tx() { 1 } sub has_subselects() { 1 } sub from_dual() { " FROM DUAL" } 1; Tangram-2.10/lib/Tangram/Driver/Pg.pm0000644000175000017500000000153710412412631016021 0ustar samvsamv package Tangram::Driver::Pg; use strict; use Tangram::Core; use Tangram::Driver::Pg::Storage; use vars qw(@ISA); @ISA = qw( Tangram::Relational ); sub connect { my ($pkg, $schema, $cs, $user, $pw, $opts) = @_; ${$opts||={}}{driver} = $pkg->new(); my $storage = Tangram::Driver::Pg::Storage->connect ( $schema, $cs, $user, $pw, $opts ); } sub blob { return "BYTEA"; } sub date { return "DATE"; } sub bool { return "BOOL"; } use MIME::Base64; sub to_blob { my $self = shift; my $value = shift; encode_base64($value); } sub from_blob { my $self = shift; my $value = shift; decode_base64($value); } sub sequence_sql { my $self = shift; my $sequence_name = shift; return "SELECT nextval('$sequence_name')"; } sub limit_sql { my $self = shift; return (limit => shift); } 1; Tangram-2.10/lib/Tangram/Driver/SQLite.pm0000644000175000017500000000257210412412631016614 0ustar samvsamv package Tangram::Driver::SQLite; use strict; use Tangram::Core; use Tangram::Driver::SQLite::Storage; use vars qw(@ISA); @ISA = qw( Tangram::Relational ); sub connect { my ($pkg, $schema, $cs, $user, $pw, $opts) = @_; ${$opts||={}}{driver} = $pkg->new(); my $storage = Tangram::Driver::SQLite::Storage->connect ( $schema, $cs, $user, $pw, $opts ); } sub blob { return "BLOB"; } sub date { return "DATE"; } sub bool { return "BOOL"; } # conversions necessary to binary-safe data # function to return a DBMS date from an ISO-8601 date in the form: sub to_date { my $self = shift; my $date = shift; $date =~ s{^(\d{4})(\d{2})(\d{2})(\d{2}):(\d{2}):(\d{2}(?:\.\d+)?)$} {$1-$2-$3T$4:$5:$6}; #print STDERR "Sending date: $date\n"; return $date; } sub from_date { my $self = shift; my $date = shift; #print STDERR "Got date: $date\n"; $date = $self->SUPER::from_date($date); $date =~ s{^(\d{4})(\d{2})(\d{2})(\d{2}):(\d{2}):(\d{2}(?:\.\d+)?)$} {$1-$2-$3T$4:$5:$6}; return $date; } use MIME::Base64; sub to_blob { my $self = shift; my $value = shift; encode_base64($value); } sub from_blob { my $self = shift; my $value = shift; decode_base64($value); } sub sequence_sql { my $self = shift; my $sequence_name = shift; return "SELECT nextval('$sequence_name')"; } 1; Tangram-2.10/lib/Tangram/Driver/mysql/0000755000175000017500000000000010412420117016252 5ustar samvsamvTangram-2.10/lib/Tangram/Driver/mysql/Expr/0000755000175000017500000000000010412420117017170 5ustar samvsamvTangram-2.10/lib/Tangram/Driver/mysql/Expr/Date.pm0000644000175000017500000000156010412412631020407 0ustar samvsamv package Tangram::Driver::mysql::Expr::Date; use strict; use vars qw(@ISA); @ISA = qw( Tangram::Expr ); my %autofun = ( dayofweek => 'Integer', weekday => 'Integer', dayofmonth => 'Integer', dayofyear => 'Integer', month => 'Integer', dayname => 'String', monthname => 'String', quarter => 'Integer', week => 'Integer', year => 'Integer', yearweek => 'Integer', to_days => 'Integer', unix_timestamp => 'Integer', ); use vars qw( $AUTOLOAD ); use Carp; sub AUTOLOAD { my ($self) = @_; my ($fun) = $AUTOLOAD =~ /\:\:(\w+)$/; croak "Unknown method '$fun'" unless exists $autofun{$fun}; eval <expr(); return Tangram\:\:$autofun{$fun}->expr("\U$fun\E(\$expr)", \$self->objects); } SUBDEF goto &$fun; } 1; Tangram-2.10/lib/Tangram/Driver/mysql/Expr/Integer.pm0000644000175000017500000000114710412412631021130 0ustar samvsamv package Tangram::Driver::mysql::Expr::Integer; use strict; use vars qw(@ISA); @ISA = qw( Tangram::Expr ); sub bitwise_and { my ($self, $val) = @_; return Tangram::Type::Integer->expr("$self->{expr} & $val", $self->objects); } sub bitwise_nand { my ($self, $val) = @_; return Tangram::Type::Integer->expr("~$self->{expr} & $val", $self->objects); } sub bitwise_or { my ($self, $val) = @_; return Tangram::Type::Integer->expr("$self->{expr} | $val", $self->objects); } sub bitwise_nor { my ($self, $val) = @_; return Tangram::Type::Integer->expr("~$self->{expr} | $val", $self->objects); } 1; Tangram-2.10/lib/Tangram/Driver/mysql/Storage.pm0000644000175000017500000000352210412412631020220 0ustar samvsamvpackage Tangram::Driver::mysql::Storage; use strict; use Tangram::Driver::mysql::Expr::Date; use Tangram::Driver::mysql::Expr::Integer; use Tangram::Storage; use vars qw(@ISA); @ISA = qw( Tangram::Storage ); sub make_id { my ($storage, $class_id) = @_; if ($storage->{layout1}) { my $table = $storage->{schema}{class_table}; $storage->sql_do("UPDATE $table SET lastObjectId = LAST_INSERT_ID(lastObjectId + 1) WHERE classId = $class_id"); } else { my $table = $storage->{schema}{control}; $storage->sql_do("UPDATE $table SET mark = LAST_INSERT_ID(mark + 1)"); } return sprintf "%d%0$storage->{cid_size}d", $storage->sql_selectall_arrayref("SELECT LAST_INSERT_ID()")->[0][0], $class_id; } sub tx_start { my $storage = shift; unless (@{ $storage->{tx} }) { if ( $storage->{no_tx} ) { $storage->sql_do (q{SELECT GET_LOCK("tx", 10)} ); #}) #cperl-mode-- } } $storage->SUPER::tx_start(@_); } sub tx_commit { my $storage = shift; $storage->SUPER::tx_commit(@_); unless (@{ $storage->{tx} }) { if ( $storage->{no_tx} ) { $storage->sql_do(q/SELECT RELEASE_LOCK("tx")/) } } } sub tx_rollback { my $storage = shift; if ( $storage->{no_tx} ) { $storage->sql_do(q/SELECT RELEASE_LOCK("tx")/); } $storage->SUPER::tx_rollback(@_); } my %improved_date = ( 'Tangram::Type::TimeAndDate' => 'Tangram::Driver::mysql::Expr::Date', 'Tangram::Type::Date' => 'Tangram::Driver::mysql::Expr::Date', ); sub expr { my $self = shift; my $type = shift; my ($expr, @remotes) = @_; return Tangram::Driver::mysql::Expr::Integer->new($type, $expr, @remotes) if ref($type) eq 'Tangram::Type::Integer'; my $improved_date = $improved_date{ref($type)}; return $improved_date->new($type, $expr, @remotes) if $improved_date; return $type->expr(@_); } 1; Tangram-2.10/lib/Tangram/Driver/Pg.pod0000644000175000017500000000247510412412631016171 0ustar samvsamv=head1 NAME Tangram::Driver::Pg - Orthogonal Object Persistence in PostgreSQL databases =head1 SYNOPSIS use Tangram; use Tangram::Driver::Pg; $schema = Tangram::Driver::Pg->schema( $hashref ); Tangram::Driver::Pg->deploy($schema, $dbh); $storage = Tangram::Driver::Pg->connect( $schema, $data_source, $username, $password ); $storage->disconnect(); Tangram::Driver::Pg->retreat($schema, $dbh); =head1 DESCRIPTION This is the entry point in the Pg-specific object-relational persistence backend. This module performs the following: =head1 METHODS This backend does not add any methods; for a description of available methods, see L. =head1 ERRATA L objects are first encoded with L, because Tangram does not currently have an easy mechanism for calling Cbind_param()> at the appropriate time to flag the column as binary. L objects are stored as C columns, which as of L 1.31, also do not get correctly escaped by the DBD driver. This also affects the (as-yet not fully functional) L back-end, which might put C<\> characters into a YAML document. It is recommended to use the C type with L for this reason. =cut Tangram-2.10/lib/Tangram/Driver/Oracle/0000755000175000017500000000000010412420117016312 5ustar samvsamvTangram-2.10/lib/Tangram/Driver/Oracle/Storage.pm0000644000175000017500000000125310412412631020257 0ustar samvsamv package Tangram::Driver::Oracle::Storage; use strict; use Tangram::Storage; use vars qw(@ISA); @ISA = qw( Tangram::Storage ); sub open_connection { my $self = shift; my $db = $self->SUPER::open_connection(@_); # Oracle doesn't really have a default date format (locale # dependant), so adjust it to use ISO-8601. $db->do ("ALTER SESSION SET NLS_DATE_FORMAT='YYYY-MM-DD\"T\"HH24:MI:SS'"); $db->do ("ALTER SESSION SET CONSTRAINTS = DEFERRED"); $db->{RaiseError} = 1; $db->{LongTruncOk} = 0; $db->{LongReadLen} = 1024*1024; return $db; } sub has_tx() { 1 } sub has_subselects() { 1 } sub from_dual() { " FROM DUAL" } 1; Tangram-2.10/lib/Tangram/Driver/SQLite/0000755000175000017500000000000010412420117016246 5ustar samvsamvTangram-2.10/lib/Tangram/Driver/SQLite/Storage.pm0000644000175000017500000000114510412412631020213 0ustar samvsamv package Tangram::Driver::SQLite::Storage; use Tangram::Storage; use vars qw(@ISA); @ISA = qw( Tangram::Storage ); sub connect { my $class = shift; my ($schema, $dsn, $u, $p, $attr) = @_; $attr ||= {}; my $self; { local($attr->{no_tx}) = 1; # *cough cough HACK cough* $self = $class->SUPER::connect($schema, $dsn, $u, $p, $attr); } $self->{no_tx} = $attr->{no_tx} || 0; $self->{db}->{RaiseError} = 1; #$self->{db}->{sqlite_handle_binary_nulls} = 1; return $self; } sub has_tx() { 1 } sub has_subselects() { 0 } #sub from_dual() { " FROM DUAL" } 1; Tangram-2.10/lib/Tangram/Driver/Sybase/0000755000175000017500000000000010412420117016333 5ustar samvsamvTangram-2.10/lib/Tangram/Driver/Sybase/Expr/0000755000175000017500000000000010412420117017251 5ustar samvsamvTangram-2.10/lib/Tangram/Driver/Sybase/Expr/Date.pm0000644000175000017500000000076310412412631020474 0ustar samvsamv package Tangram::Driver::Sybase::Expr::Date; use vars qw(@ISA); @ISA = qw( Tangram::Expr ); ############################ # add method datepart($part) sub datepart { my ($self, $part) = @_; # $part is 'year', 'month', etc my $expr = $self->expr(); # the SQL string for this Expr ################################## # build a new Expr of Integer type # pass this Expr's remote object list to the new Expr return Tangram::Type::Integer->expr("DATEPART($part, $expr)", $self->objects); } 1; Tangram-2.10/lib/Tangram/Driver/Sybase/Storage.pm0000644000175000017500000000244110412412631020300 0ustar samvsamv package Tangram::Driver::Sybase::Storage; use strict; use Tangram::Storage; use vars qw(@ISA); @ISA = qw( Tangram::Storage ); use Tangram::Driver::Sybase::Expr::Date; use Tangram::Driver::Sybase::Statement; sub prepare { my ($self, $sql) = @_; #print "prepare: $sql\n"; bless [ $self, $sql ], 'Tangram::Driver::Sybase::Statement'; } *prepare_update = \*prepare; *prepare_insert = \*prepare; sub prepare_select { my ($self, $sql) = @_; return $self->prepare($sql); } sub make_1st_id_in_tx { my ($self) = @_; my $table = $self->{schema}{control}; $self->sql_do("UPDATE $table SET mark = mark + 1"); return $self->{db}->selectall_arrayref("SELECT mark from $table")->[0][0]; } sub update_id_in_tx { my ($self, $mark) = @_; $self->sql_do("UPDATE $self->{schema}{control} SET mark = $mark"); } my %improved = ( 'Tangram::Type/TimeAndDate' => 'Tangram::Driver::Sybase::Expr::Date', 'Tangram::Type/Date' => 'Tangram::Driver::Sybase::Expr::Date', ); sub expr { my $self = shift; my $type = shift; my ($expr, @remotes) = @_; # is $type related to dates? if not, return default my $improved = $improved{ref($type)} or return $type->expr(@_); # $type is a Date; return a DateExpr return $improved->new($type, $expr, @remotes); } 1; Tangram-2.10/lib/Tangram/Driver/Sybase/Statement.pm0000644000175000017500000000065510412412631020645 0ustar samvsamvpackage Tangram::Driver::Sybase::Statement; use strict; use constant STH => 2; sub execute { my $self = shift; my ($storage, $sql) = @$self; my $sth = $self->[STH] = $storage->{db}->prepare($sql); $sth->execute(@_); # $dbh->do($sql, {}, @_); } sub fetchrow_array { my $self = shift; return $self->[STH]->fetchrow_array(); } sub finish { my $self = shift; my $sth = pop @$self; $sth->finish(); } 1; Tangram-2.10/lib/Tangram/Driver/SQLite2.pm0000644000175000017500000000041210412412631016665 0ustar samvsamv # compatibility for SQLite 2. Primarily for the hoary # libdbd-sqlite-perl package which uses "SQLite2" as the driver name. use strict; package Tangram::Driver::SQLite2; use Tangram::Driver::SQLite; use vars qw(@ISA); @ISA = qw( Tangram::Driver::SQLite ); 1; Tangram-2.10/lib/Tangram/Driver/SQLite.pod0000644000175000017500000000213010412412631016750 0ustar samvsamv =head1 NAME Tangram::Driver::SQLite - Orthogonal Object Persistence in SQLite databases =head1 SYNOPSIS use Tangram; use Tangram::Driver::SQLite; $schema = Tangram::Driver::SQLite->schema( $hashref ); Tangram::Driver::SQLite->deploy($schema, $dbh); $storage = Tangram::Driver::SQLite->connect( $schema, $data_source, $username, $password ); $storage->disconnect(); Tangram::Driver::SQLite->retreat($schema, $dbh); =head1 DESCRIPTION This is the entry point in the SQLite-specific object-relational persistence backend. =head1 ERRATA For reasons similar to the L module, this back-end automatically encodes L objects via L to avoid truncation of values on NUL bytes. Also, note that despite what is mentioned on the front page of L, SQLite is not actually an ACID database; any writer to the database has to wait for all other writers to finish before they can begin their transaction. So make sure you start and complete your transactions as quickly as possible with this back-end. =cut Tangram-2.10/lib/Tangram/Driver/Sybase.pm0000644000175000017500000000054310412412631016675 0ustar samvsamv package Tangram::Driver::Sybase; use strict; use Tangram::Driver::Sybase::Storage; use vars qw(@ISA); @ISA = qw( Tangram::Relational ); sub connect { my ($pkg, $schema, $cs, $user, $pw, $opts) = @_; ${$opts||={}}{driver} = $pkg->new(); my $storage = Tangram::Driver::Sybase::Storage->connect ( $schema, $cs, $user, $pw, $opts ); } 1; Tangram-2.10/lib/Tangram/Driver/Sybase.pod0000644000175000017500000000167510412412631017052 0ustar samvsamv=head1 NAME Tangram::Sybase - Orthogonal Object Persistence in Sybase databases =head1 SYNOPSIS use Tangram; use Tangram::Sybase; $schema = Tangram::Sybase->schema( $hashref ); Tangram::Sybase->deploy($schema, $dbh); $storage = Tangram::Sybase->connect( $schema, $data_source, $username, $password ); $storage->disconnect(); Tangram::Sybase->retreat($schema, $dbh); =head1 DESCRIPTION This is the entry point in the Sybase-specific object-relational persistence backend. Sybase only supports a single prepared statement per connection. This backend disables the usage of prepared statements. The vanilla Relational backend may not be used with Sybase databases. =head1 METHODS This backend does not add any methods; for a description of available methods, see L. =head1 WARNING This backend has not been tested in quite some time. Is the database even called C any more? =cut Tangram-2.10/lib/Tangram/Driver/Oracle.pm0000644000175000017500000000204110412412631016647 0ustar samvsamv package Tangram::Driver::Oracle; use strict; use Tangram::Core; use Tangram::Driver::Oracle::Storage; use vars qw(@ISA); @ISA = qw( Tangram::Relational ); sub connect { my ($pkg, $schema, $cs, $user, $pw, $opts) = @_; ${$opts||={}}{driver} = $pkg->new(); my $storage = Tangram::Driver::Oracle::Storage->connect ( $schema, $cs, $user, $pw, $opts ); } sub blob { return "CLOB"; } sub date { return "DATE"; } sub bool { return "INT(1)"; } # Oracle-- sub from_date { $_[1]; #print STDERR "Converting FROM $_[1]\n"; #(my $date = $_[1]) =~ s{ }{T}; #$date; } sub to_date { $_[1]; #print STDERR "Converting TO $_[1]\n"; #(my $date = $_[1]) =~ s{T}{ }; #$date; } sub from_blob { $_[1] } sub to_blob { $_[1] } sub limit_sql { my $self = shift; my $spec = shift; if ( ref $spec ) { die unless ref $spec eq "ARRAY"; die "Oracle cannot handle two part limits" unless $spec->[0] eq "0"; $spec = pop @$spec; } return (postfilter => ["rownum <= $spec"]); } 1; Tangram-2.10/lib/Tangram/Driver/mysql.pod0000644000175000017500000000165210412412631016764 0ustar samvsamv=head1 NAME Tangram::Driver::mysql - Orthogonal Object Persistence in Mysql databases =head1 SYNOPSIS use Tangram; use Tangram::Driver::mysql; $schema = Tangram::Driver::mysql->schema( $hashref ); Tangram::Driver::mysql->deploy($schema, $dbh); $storage = Tangram::Driver::mysql->connect( $schema, $data_source, $username, $password ); $storage->disconnect(); Tangram::Driver::mysql->retreat($schema, $dbh); =head1 DESCRIPTION This is the entry point in the mysql-specific object-relational persistence backend. This backend makes use of Mysql extensions SELECT GET_LOCK, SELECT RELEASE_LOCK and LAST_INSERT_ID to safely allocate object ids in the absence of transactions. The vanilla Relational backend may not be used with Mysql databases in multiprogramming context. =head1 METHODS This backend does not add any methods; for a description of available methods, see L. Tangram-2.10/lib/Tangram/Driver/Oracle.pod0000644000175000017500000000134710412412631017025 0ustar samvsamv=head1 NAME Tangram::Driver::Oracle - Orthogonal Object Persistence in Oracle databases =head1 SYNOPSIS use Tangram; use Tangram::Driver::Oracle; $schema = Tangram::Driver::Oracle->schema( $hashref ); Tangram::Driver::Oracle->deploy($schema, $dbh); $storage = Tangram::Driver::Oracle->connect( $schema, $data_source, $username, $password ); $storage->disconnect(); Tangram::Driver::Oracle->retreat($schema, $dbh); =head1 DESCRIPTION This is the entry point in the Oracle-specific object-relational persistence backend. This module performs the following =head1 METHODS This backend does not add any methods; for a description of available methods, see L. =head1 ERRATA =cut Tangram-2.10/lib/Tangram/Driver/mysql.pm0000644000175000017500000000273010412412631016614 0ustar samvsamv package Tangram::Driver::mysql; use Tangram::Driver::mysql::Storage; use strict; use Tangram::Core; use vars qw(@ISA); @ISA = qw( Tangram::Relational ); sub connect { my ($pkg, $schema, $cs, $user, $pw, $opts) = @_; ${$opts||={}}{driver} = $pkg->new(); my $storage = Tangram::Driver::mysql::Storage->connect ( $schema, $cs, $user, $pw, $opts ); } # FIXME - this should be implemented in the same way as the # IntegerExpr stuff, below. sub dbms_date { my $self = shift; my $date = $self->SUPER::dbms_date(shift); # convert standard ISO-8601 to a format that MySQL natively # understands, dumbass that it is. $date =~ s{^(\d{4})(\d{2})(\d{2})(\d{2}):(\d{2}):(\d{2}(?:\.\d+)?)$} {$1-$2-$3 $4:$5:$6}; return $date; } sub sequence_sql { my $self = shift; my $sequence_name = shift; # from the MySQL manual # http://dev.mysql.com/doc/mysql/en/Information_functions.html return("UPDATE seq_$sequence_name SET id=LAST_INSERT_ID(id+1);\n" ."SELECT LAST_INSERT_ID();"); } sub mk_sequence_sql { my $self = shift; my $sequence_name = shift; return("CREATE TABLE seq_$sequence_name (id INT NOT NULL);\n" ."INSERT INTO seq_$sequence_name VALUES (0);"); } sub drop_sequence_sql { my $self = shift if ref $_[0] and UNIVERSAL::isa($_[0], __PACKAGE__); my $sequence_name = shift; return "DROP TABLE seq_$sequence_name"; } sub limit_sql { my $self = shift; return (limit => shift); } 1; Tangram-2.10/lib/Tangram/Relational.pm0000644000175000017500000000772710412412631016321 0ustar samvsamv use Tangram::Relational::Engine; package Tangram::Relational; sub new { bless { }, shift } sub connect { my ($pkg, $schema, $cs, $user, $pw, $opt) = @_; $opt ||= {}; $opt->{driver} = $pkg->new(); my $storage = Tangram::Storage->connect( $schema, $cs, $user, $pw, $opt ); } sub schema { my $self = shift; return Tangram::Schema->new( @_ ); } sub _with_handle { my $self = shift; my $method = shift; my $schema = shift; if (@_) { my $arg = shift; if (ref $arg) { Tangram::Relational::Engine->new($schema, driver => $self)->$method($arg) } else { my $dbh = DBI->connect($arg, @_); eval { Tangram::Relational::Engine->new($schema, driver => $self)->$method($dbh) }; $dbh->disconnect(); die $@ if $@; } } else { Tangram::Relational::Engine->new($schema, driver => $self)->$method(); } } sub deploy { my $self = (shift) || __PACKAGE__; $self->_with_handle('deploy', @_); } sub retreat { my $self = (shift) || __PACKAGE__; $self->_with_handle('retreat', @_); } # handle virtual SQL types. Isn't SQL silly? our ($sql_t_qr, @sql_t); BEGIN { @sql_t = ( 'VARCHAR' => 'varchar', # variable width 'CHAR' => 'char', # fixed width 'BLOB' => 'blob', # generic, large data store 'DATE|TIME|DATETIME|TIMESTAMP' => 'date', 'BOOL' => 'bool', 'INT|SHORTINT|TINYINT|LONGINT|MEDIUMINT|SMALLINT' => 'integer', 'DECIMAL|NUMERIC|FLOAT|REAL|DOUBLE|SINGLE|EXTENDED' => 'number', 'ENUM|SET' => 'special', '' => 'general', ); # compile the types to a single regexp. { my $c = 0; $sql_t_qr = "^(?:".join("|", map { "($_)" } grep {(++$c)&1} @sql_t).")"; $sql_t_qr = qr/$sql_t_qr/i; } } sub type { my $self = shift if ref $_[0] or UNIVERSAL::isa($_[0], __PACKAGE__); $self ||= __PACKAGE__; my $type = shift; my @x = ($type =~ m{$sql_t_qr}); my $c = 1; $c+=2 while not defined shift @x; my $func = $sql_t[$c]; return $self->$func($type); } # convert a value from an RDBMS format => an internal format sub from_dbms { my $self = ( (ref $_[0] and UNIVERSAL::isa($_[0], __PACKAGE__)) ? shift : __PACKAGE__); my $type = shift; my $value = shift; #print STDERR "Relational: converting (TO) $type $value\n"; my $method = "from_$type"; if ( $self->can($method) ) { return $self->$method($value); } else { return $value; } } # convert a value from an internal format => an RDBMS format sub to_dbms { my $self = ( (ref $_[0] and UNIVERSAL::isa($_[0], __PACKAGE__)) ? shift : __PACKAGE__); my $type = shift; my $value = shift; #print STDERR "Relational: converting (TO) $type $value\n"; my $method = "to_$type"; if ( $self->can($method) ) { return $self->$method($value); } else { return $value; } } # generic / fallback date handler. Use Date::Manip to parse # `anything' and return a full ISO date sub from_date { my $self = shift; my $value = shift; require 'Date/Manip.pm'; return Date::Manip::UnixDate($value, '%Y-%m-%dT%H:%M:%S'); } # an alternate ISO-8601 form that databases are more likely to grok sub to_date { my $self = shift; my $value = shift; require 'Date/Manip.pm'; return Date::Manip::UnixDate($value, '%Y-%m-%d %H:%M:%S'); } use Carp; # return a query to get a sequence value sub sequence_sql { my $self = shift; my $sequence_name = shift or confess "no sequence name?"; return "SELECT $sequence_name.nextval"; } sub mk_sequence_sql { my $self = shift; my $sequence_name = shift; return "CREATE SEQUENCE $sequence_name"; } sub drop_sequence_sql { my $self = shift; my $sequence_name = shift; return "DROP SEQUENCE $sequence_name"; } # default mappings are no-ops BEGIN { no strict 'refs'; my $c = 0; *{$_} = sub { shift if UNIVERSAL::isa($_[0], __PACKAGE__); shift; } foreach grep {($c++)&1} @sql_t; } 1; Tangram-2.10/lib/Tangram/Deploy.pod0000644000175000017500000000025610412412630015616 0ustar samvsamv=head1 NAME Tangram::Deploy - obsolete =head1 DESCRIPTION This module is now obsolete; its functionality has been moved to Tangram::Relational. See L.Tangram-2.10/lib/Tangram/Core.pod0000644000175000017500000000136310412412631015253 0ustar samvsamv=head1 NAME Tangram::Core - import core Tangram modules =head1 SYNOPSIS use Tangram::Core; # use additional types, e.g.: use Tangram::Type::Array::FromMany; use Tangram::Type::Set::FromOne; =head1 DESCRIPTION This module imports only the parts of Tangram that are thought to be essential to any app. This includes: Schema, Storage, Cursor, Expr, Scalar and Ref. None of the modules that map collections (Array, Hash, Set and their intrusive variants) are imported. Neither is Deploy. Tangram::Core allows you to reduce script startup time (and executable size when perlcc can handle Tangram) by importing only what you really need. It also makes it possible to add new mappings to Tangram without penalizing apps that don't need them. Tangram-2.10/lib/Tangram/Schema/0000755000175000017500000000000010412420117015052 5ustar samvsamvTangram-2.10/lib/Tangram/Schema/ClassHash.pm0000644000175000017500000000025410412412630017263 0ustar samvsamvpackage Tangram::Schema::ClassHash; use strict; use strict; use Carp; sub class { my ($self, $class) = @_; $self->{$class} or croak "unknown class '$class'"; } 1; Tangram-2.10/lib/Tangram/Schema/Class.pm0000644000175000017500000000135310412412630016460 0ustar samvsamv package Tangram::Schema::Class; use strict; use Tangram::Schema::Node; use vars qw(@ISA); @ISA = qw( Tangram::Schema::Node ); sub members { my ($self, $type) = @_; return @{$self->{$type}}; } sub is_root { !@{ shift->{BASES} } } sub get_direct_fields { map { values %$_ } values %{ shift->{fields} } } sub get_table { shift->{table} } *direct_fields = \&get_direct_fields; sub get_import_cols { my ($self, $context) = @_; my $table = $self->{table}; map { map { [ $table, $_ ] } $_->get_import_cols($context) } $self->get_direct_fields() } sub get_export_cols { my ($self, $context) = @_; my $table = $self->{table}; map { map { [ $table, $_ ] } $_->get_export_cols($context) } $self->get_direct_fields() } Tangram-2.10/lib/Tangram/Schema/Node.pm0000644000175000017500000000666610412412630016314 0ustar samvsamvpackage Tangram::Schema::Node; # base class for Tangram::Class in Tangram::Schema (now # Tangram::Schema::Class) and Tangram::Relational::Engine::Class use strict; sub get_bases { @{ shift->{BASES} } } *direct_bases = \&get_bases; sub get_specs { @{ shift->{SPECS} } } sub for_conforming { my ($class, $fun, @args) = @_; my $done = Set::Object->new; my $traverse; $traverse = sub { my $class = shift; return if $done->includes($class); $done->insert($class); $fun->($class, @args); foreach my $derived (@{ $class->{SPECS} }) { $traverse->($derived); } }; $traverse->($class); } #--------------------------------------------------------------------- # Tangram::Node->for_composing($closure, @_) # # Runs the given closure once for this class, and all its superclasses # listed in the schema as $class->{BASES} # #--------------------------------------------------------------------- sub for_composing { my ($class, $fun, @args) = @_; my $done = Set::Object->new; my $traverse; $traverse = sub { my $class = shift; return if $done->includes($class); $done->insert($class); foreach my $base (@{ $class->{BASES} }) { $traverse->($base); } $fun->($class, @args); }; $traverse->($class); } sub get_exporter { my ($self, $context) = @_; return $self->{EXPORTER} ||= do { my (@export_sources, @export_closures); $self->for_composing ( sub { my ($part) = @_; $context->{class} = $part; for my $field ($part->direct_fields()) { if (my $exporter = $field->get_exporter($context)) { if (ref $exporter) { push @export_closures, $exporter; push @export_sources, 'shift(@closures)->($obj, $context)'; } else { push @export_sources, $exporter; } } } } ); my $export_source = join ",\n", @export_sources; my $copy_closures = ( @export_closures ? ' my @closures = @export_closures;' : '' ); # $Tangram::TRACE = \*STDOUT; $export_source = ("sub { my (\$obj, \$context) = \@_;" ."$copy_closures\n$export_source }"); print $Tangram::TRACE "Compiling exporter for $self->{name}...\n".($Tangram::DEBUG_LEVEL > 1 ? "$export_source\n" : "") if $Tangram::TRACE; eval $export_source or die; } } sub get_importer { my ($self, $context) = @_; return $self->{IMPORTER} ||= do { my (@import_sources, @import_closures); $self->for_composing ( sub { my ($part) = @_; $context->{class} = $part; for my $field ($part->get_direct_fields()) { my $importer = $field->get_importer($context) or next; if (ref $importer) { push @import_closures, $importer; push @import_sources, 'shift(@closures)->($obj, $row, $context)'; } else { push @import_sources, $importer; } } } ); my $import_source = join ";\n", @import_sources; my $copy_closures = ( @import_closures ? ' my @closures = @import_closures;' : '' ); # $Tangram::TRACE = \*STDOUT; $import_source = ( "sub { my (\$obj, \$row, \$context) = \@_;" ."(ref(\$row) eq 'ARRAY') and (\@\$row) or Carp::confess('no row!');\n" ."# line 1 'tangram-$self->{table}-to-$self->{name}.pl'\n" ."$copy_closures\n$import_source }" ); print $Tangram::TRACE "Compiling importer for $self->{name}...\n".($Tangram::DEBUG_LEVEL > 1 ? "$import_source\n" : "")."\n" if $Tangram::TRACE; # use Data::Dumper; print Dumper \@cols; eval $import_source or die; }; } 1; Tangram-2.10/lib/Tangram/Remote.pod0000644000175000017500000000146410412412630015617 0ustar samvsamv=head1 NAME Tangram::Remote - represent persistent objects in client space =head1 SYNOPSIS use Tangram; $remote = $storage->remote( $class ); @remotes = $storage->remote( @classes ); ... $remote->{$field} ... =head1 DESCRIPTION A Remote object is a client-side representation of an object that resides in a database. It has the same fields as a normal object of the same class - as declared in the Schema associated to the database the Remote was obtained from. The values of the fields are not normal Perl values, but Ls that will be evaluated on the database server side. Remote objects are somewhat similar to SQL table aliases. Note that there are no objects which are actually C instances; the objects will be called L et al. =cut Tangram-2.10/lib/Tangram/Cursor.pod0000644000175000017500000000311610412412630015635 0ustar samvsamv# -*- perl -*- =head1 NAME Tangram::Cursor - traverse a result set =head1 SYNOPSIS $cursor = $storage->cursor($remote, $filter); while (my $obj = $cursor->current()) { # process $obj $cursor->next(); } $cursor->execute(); while (my $obj = $cursor->current()) { # process $obj $cursor->next(); } =head1 DESCRIPTION A Cursor makes it possible to iterate over a result set without loading all the objects in memory. See also the "limit" option to the select method of the Tangram::Storage class. =head1 INSTANCE METHODS =head2 current $obj = $cursor->current(); Returns the current object, or undef() if the result set is exhausted. =head2 next $obj = $cursor->next(); @obj = $cursor->next(); Moves to the next object in the result set, if any. Returns the new current object, or undef() if the result set is exhausted. In list context, return all the remaining objects. =head2 execute $cursor->execute(); Moves the cursor to the first object in the result set, and return it. Note that preparing Cursors is an expensive operation, you should reuse them if possible. execute() allows just that. execute() may be called several times in a row, or on a Cursor that has just been obtained from a Storage, without ill effects. =head2 residue my @vals = $cursor->residue(); Returns the values of the Expr that were passed to the C directive of the Storage::select() or Storage::cursor() statement. =head1 CURSORS AND CONNECTIONS Each Cursor opens its own connection to the database. =head1 SEE ALSO L Tangram-2.10/lib/Tangram/Cursor.pm0000644000175000017500000001601610412412630015472 0ustar samvsamvpackage Tangram::Cursor; use strict; use Tangram::Cursor::Data; use Carp; use vars qw( $stored %done ); sub new { my ($pkg, $storage, $remote, $conn) = @_; confess unless $conn; $remote = $storage->remote($remote) unless ref $remote or not defined $remote; my $self = {}; $self->{TARGET} = $remote; $self->{STORAGE} = $storage; $self->{SELECTS} = []; $self->{CONNECTION} = $conn; $self->{OWN_CONNECTION} = $conn != $storage->{db}; bless $self, $pkg; } sub DESTROY { my $self = shift; $self->close(); } sub close { my $self = shift; if ($self->{SELECTS}) { for my $select ( @{ $self->{SELECTS} } ) { my $sth = $select->[1] or next; $sth->finish() if $sth->{Active}; } } $self->{CONNECTION}->disconnect() if $self->{OWN_CONNECTION}; } sub select { my $self = shift; my %args; if (@_ > 1) { %args = @_; } else { $args{filter} = shift; } $self->{-order} = $args{order}; $self->{-group} = $args{group}; $self->{-desc} = $args{desc}; $self->{-distinct} = $args{distinct}; $self->{-limit} = $args{limit}; $self->{-noexec} = $args{noexec}; # with outer queries, each remote object is either inside or # outside the query. my ($inner_objects, $outer_objects) = (Set::Object->new(), Set::Object->new()); if (exists $args{retrieve}) { $self->retrieve( @{ $args{retrieve} } ); # assume that objects are outside the query until joined $outer_objects->insert ( map { $_->{objects}->members } @{ $args{retrieve} } ); } my $target = $self->{TARGET}; my (@filter_from, @filter_where); $inner_objects->insert($target->object) if $target; my $filter = Tangram::Expr::Filter->new( tight => 100, objects => $inner_objects ); my ($seen_inner, $outer); # anything mentioned in the `filter' is part of the inner query if (my $user_filter = $args{filter}) { $seen_inner = 1; $filter->{expr} = $user_filter->{expr}; $inner_objects->insert($user_filter->{objects}->members); } $outer_objects->remove($inner_objects->members); # anything mentioned in the `outer_filter' is part of the # outer query if (my $outer_filter = $args{outer_filter}) { #kill 2, $$; if ( my $forced_outer = $args{force_outer} ) { $inner_objects->remove(map { $_->object } @$forced_outer); } $outer = Tangram::Expr::Filter->new( tight => 100, objects => $outer_objects ); $outer->{expr} = $outer_filter->{expr}; $outer->{objects}->insert($outer_filter->{objects}->members); $outer->{objects}->remove($inner_objects->members); } elsif ( $outer_objects->size ) { # If there is no outer query, then we must add the # selected tables to the inner query part. # this follows old behaviour, but may result in cartesian # products. $inner_objects->insert($outer_objects->members); } # insert all inner tables to the inner filter $filter->{objects}->insert($inner_objects->members); $filter->{objects}->remove($target->object) if $target; my @polysel = $self->{STORAGE}->get_polymorphic_select ( $target ? ($target->class||confess("argh!")) : ""); $self->{SELECTS} = [ map { [ $self->build_select( $_, [], [ $filter->from ], [ $filter->where ], ( $outer ? ([ $outer->from ], [ $outer->where ], ) : () ) ), undef, $_ ] } @polysel ]; $self->{position} = -1; return $self->execute() unless delete $self->{-noexec}; } sub execute { my ($self) = @_; return $self->{-current} if $self->{position} == 0; $self->{cur_select} = [ @{ $self->{SELECTS} } ]; $self->prepare_next_statement() && $self->next(); } sub sql_string { my $self = shift; if ( $self->{_last_sql} ) { print STDERR "RETURNING FROM _last_sql\n"; return $self->{_last_sql}; } elsif ( $self->{ACTIVE} ) { print STDERR "RETURNING FROM ACTIVE\n"; return $self->{ACTIVE}[0]; } elsif ( $self->{cur_select} and @{$self->{cur_select}} ) { print STDERR "RETURNING FROM CUR_SELECT\n"; return $self->{cur_select}[0][0]; } elsif ( $self->{SELECTS} ) { print STDERR "RETURNING FROM SELECTS\n"; return $self->{SELECTS}[0][0]; } } sub prepare_next_statement { my ($self) = @_; my $select = $self->{ACTIVE} = shift @{ $self->{cur_select} } or do { #print $Tangram::TRACE "Cursor - no active selects?\n" #if $Tangram::TRACE; return undef; }; my ($sql, $sth, $template) = @$select; $self->{sth}->finish() if $self->{sth}; $sth = $select->[1] = $self->{STORAGE}->sql_prepare($sql, $self->{CONNECTION}) unless $sth; $self->{sth} = $sth; $sth->execute() or croak "Execute failed; $DBI::errstr"; return $sth; } sub build_select { my ($self, $template, $cols, $from, $where, $ofrom, $owhere) = @_; if (my $retrieve = $self->{-retrieve}) { @$cols = map { $_->{expr} } @$retrieve; } my @options; # this needs a hack to get right... if ( $self->{-limit} ) { @options = $self->{STORAGE}->limit_sql($self->{-limit}); } my $select = $template->instantiate ( $self->{TARGET}, $cols, $from, $where, ( $self->{-group} ? (group => $self->{-group}) : () ), ( $self->{-order} ? (order => $self->{-order}) : () ), ( $self->{-distinct} ? (distinct => $self->{-distinct}) : () ), ( $self->{-desc} ? (desc => $self->{-desc}) : () ), ( $ofrom ? ( ofrom => $ofrom ) : () ), ( $owhere ? ( owhere => $owhere ) : () ), @options, ); return $select; } sub _next { my ($self) = @_; $self->{-current} = undef; ++$self->{position}; my $sth = $self->{sth} or confess "no sth"; my @row; while (1) { @row = $sth->fetchrow(); last if @row; $sth = $self->prepare_next_statement() or return undef; } my $storage = $self->{STORAGE}; if ($self->{TARGET}) { my ($id, $classId, $state) = $self->{ACTIVE}[-1]->extract(\@row); $id = $storage->{import_id}->($id, $classId); my $class = $storage->{id2class}{$classId} or die "unknown class id $classId"; # even if object is already loaded we must read it so that @rpw only contains residue my $obj = $storage->read_object($id, $class, $state); # if object is already loaded return previous copy $obj = $storage->{objects}{$id} if exists $storage->{objects}{$id}; $self->{-current} = $obj; } else { $self->{-current} = undef; } $self->{-residue} = exists $self->{-retrieve} ? [ map { ref $_ ? $_->{type}->read_data(\@row) : shift @row } @{$self->{-retrieve}} ] : \@row; $self->{-current} ||= (@{$self->{-residue}} > 1 ? $self->{-residue} : $self->{-residue}[0]); return $self->{-current}; } sub next { my ($self) = @_; return $self->_next unless wantarray; my ($obj, @results); while (defined($obj = $self->_next)) { push @results, $obj; } return @results; } sub current { my ($self) = @_; $self->{-current} } sub retrieve { my $self = shift; push @{$self->{-retrieve}}, @_; } sub residue { @{shift->{-residue}}; } sub object { my ($self) = @_; return $self->{_object}; } 1; Tangram-2.10/lib/Tangram/Core.pm0000644000175000017500000000146410412412630015106 0ustar samvsamvuse strict; use Set::Object; use Tangram::Compat; BEGIN { } use Tangram::Type::Scalar; use Tangram::Type::Ref::FromMany; use Tangram::Schema; use Tangram::Cursor; use Tangram::Storage; use Tangram::Expr; use Tangram::Relational; package Tangram; # Why does this package continue here? -- ank use vars qw( $TRACE $DEBUG_LEVEL ); $TRACE = (\*STDOUT, \*STDERR)[$ENV{TANGRAM_TRACE} - 1] || \*STDERR if exists $ENV{TANGRAM_TRACE} && $ENV{TANGRAM_TRACE}; $DEBUG_LEVEL = $ENV{TANGRAM_DEBUG_LEVEL} || 0; package Tangram::Core; use Exporter; use vars qw(@ISA @EXPORT_OK); BEGIN { @ISA = qw(Exporter); @EXPORT_OK = qw(pretty); } # pretty("bla") -> "`bla'" # pretty(undef) -> undef sub pretty { my $thingy = shift; if (defined($thingy)) { return "`$thingy'"; } else { return "undef"; } } 1; Tangram-2.10/lib/Tangram/Springfield.pod0000644000175000017500000000116210412412630016625 0ustar samvsamv=head1 NAME Tangram::Springfield - classes and schema used in the Guided Tour =head1 SYNOPSIS use Tangram; use Tangram::Springfield; # deploy the storage # store & retrieve objects =head1 DESCRIPTION This modules contains the declarations of the classes used in the Guided Tour. It also creates Schema object for that class system, and stores it in the $schema variable. That variable is exported to the C
package by default. The UML diagram for the classes can be found in L. =head1 SEE ALSO L, L, L, L, L. Tangram-2.10/lib/Tangram/Tour.pod0000644000175000017500000004733510412412630015324 0ustar samvsamv=head1 NAME Tangram::Tour - Guided Tour =head1 INTRODUCTION In this tour, we add persistence to a simple Person design. A Person is either a NaturalPerson or a LegalPerson. Persons (in general) have a collection of addresses. An address consists in a type (a string) and a city (also a string). NaturalPerson - a subclass of Person - represents persons of flesh and blood. NaturalPersons have a name and a firstName (both strings) and an age (an integer). NaturalPersons sometimes have a partner (another NaturalPerson) and even children (a collection of NaturalPersons). LegalPerson - another subclass of Person - represents companies and other entities that the law regards as 'persons'. A LegalPerson has a name (a string) and a manager (a NaturalPerson). All this is expressed in the following UML diagram: +---------------------+ +--------------+ | Person | | Address | | { abstract } |1<>-->-*|--------------| |---------------------| | kind: string | +---------------------+ | city: string | | +--------------+ | +--------------A--------------+ | | +-------------------+ +---------------+ +--*| NaturalPerson | | LegalPerson | | |-------------------|manager |---------------| V | firstName: string |1---<-----1| name: string | | | name: string | +---------------+ +--*| age: integer | children +-------------------+ 1 1 | partner | | +--->---+ B create the corresponding Perl packages!>. That's up to the user. However, to facilitate experimentation, Tangram comes with a module that implements the necessary classes. For more information see L. Before we can actually store objects we must complete two steps: =over 4 =item 1 Create a Schema =item 2 Create a database =back =head2 Creating a Schema A Schema object contains information about the persistent aspects of a system of classes. It also gives a degree of control over the way Tangram performs the object-relational mapping, but in this tour we will use all the defaults. Here is the Schema for Springfield: $schema = Tangram::Relational->schema( { classes => [ Person => { abstract => 1, fields => { iarray => { addresses => { class => 'Address', aggreg => 1 } } } }, Address => { fields => { string => [ qw( kind city ) ], }, }, NaturalPerson => { bases => [ qw( Person ) ], fields => { string => [ qw( firstName name ) ], int => [ qw( age ) ], ref => [ qw( partner ) ], array => { children => 'NaturalPerson' }, } }, LegalPerson => { bases => [ qw( Person ) ], fields => { string => [ qw( name ) ], ref => [ qw( manager ) ], } }, ] } ); The Schema lists all the classes that need persistence, along with their attributes and the inheritance relationships. We must provide type information for the attributes, because SQL is more typed than Perl. We also tell Tangram that C is an abstract class, so it wastes no time attempting to retrieve objects of that exact class. Note that Tangram cannot deduce this information by itself. While Perl makes it possible to extract the list of all the classes in an application, in general not all classes will need to persist. A class may have both persistent and non-persistent bases. As for attributes, Perl's most typical representation for objects - a hash - even allows two objects of the same class to have a different set of attributes. For more information on creating Schemas, see L and L. =head2 Setting up a database Now we create a database. The simplest way is to create an empty database and let Tangram initialize it: use Tangram; $dbh = DBI->connect( @cp ); Tangram::Relational->deploy($schema, $dbh ); $dbh->disconnect(); Tangram::Relational is the vanilla object-relational backend. It assumes that the database understands standard SQL, and that both the database and the related DBI driver fully implements the DBI specification. Tangram also comes with vendor-specific backends for Mysql and Sybase. When a vendor-specific backend exists, it should be used in place of the vanilla backend. For more information, see L, L and L. =head2 Connecting to a database We are now ready to store objects. First we connect to the database, using the class method Tangram::Relational::connect (or Tangram::mysql::connect for Mysql). The first argument of connect() the schema object; the others are passed directly to DBI::connect. The method returns a Tangram::Storage object that will be used to communicate with the database. For example: $storage = Tangram::Relational->connect( $schema, @cp ); connects to a database named Springfield via the vanilla Relational backend, using a specific account and password. For more information on connecting to databases, see L and L. =head2 Inserting objects Now we can populate the database: $storage->insert( NaturalPerson->new( firstName => 'Montgomery', name => 'Burns' ) ); This inserts a single NaturalPerson object into the database. We can insert several objects in one call: $storage->insert( NaturalPerson->new( firstName => 'Patty', name => 'Bouvier' ), NaturalPerson->new( firstName => 'Selma', name => 'Bouvier' ) ); Sometimes Tangram saves objects implicitly: @kids = ( NaturalPerson->new( firstName => 'Bart', name => 'Simpson' ), NaturalPerson->new( firstName => 'Lisa', name => 'Simpson' ) ); $marge = NaturalPerson->new( firstName => 'Marge', name => 'Simpson', addresses => [ Address->new( kind => 'residence', city => 'Springfield' ) ], children => [ @kids ] ); $homer = NaturalPerson->new( firstName => 'Homer', name => 'Simpson', addresses => [ Address->new( kind => 'residence', city => 'Springfield' ), Address->new( kind => 'work', city => 'Springfield' ) ], children => [ @kids ] ); $homer->{partner} = $marge; $marge->{partner} = $homer; $homer_id = $storage->insert( $homer ); In the process of saving Homer, Tangram detects that it contains references to objects that are not persistent yet (Marge, the addresses and the kids), and inserts them automatically. Note that Tangram can handle cycles: Homer and Marge refer to each other. insert() returns an object id, or a list of object ids, that uniquely identify the object(s) that have been inserted. For more information on inserting objects, see L. =head2 Updating objects Updating works pretty much the same as inserting: my $maggie = NaturalPerson->new( firstName => 'Maggie', name => 'Simpson' ); push @{ $homer->{children} }, $maggie; push @{ $marge->{children} }, $maggie; $storage->update( $homer, $marge ); Here again Tangram detects that Maggie is not already persistent in $storage and automatically inserts it. Note that we need to update Marge explicitly because she was already persistent. For more information on updating objects, see L. =head2 Memory management ...is still up to you. Tangram won't break in-memory cycles, it's a persistence tool, not a memory management tool. Let's make sure we don't leak objects: $homer->{partner} = undef; # do this before $homer goes out of scope Also, when we're finished with a storage, we can explicitly disconnect it: $storage->disconnect(); Whether it's important or not to disconnect the Storage depends on what version of Perl you use. If it's prior to 5.6, you I disconnect the storage explicitly (or at least call unload()) otherwise the Storage will prevent the objects it controls from being reclaimed by Perl. For more information see see L. =head2 Finding objects After reconnecting to Springfield, we now want to retrieve some objects. But how do we find them? Basically there are three options =over 4 =item * We know their IDs. =item * We obtain them from another object. =item * We use a query. =back =head2 Loading by ID When an object is inserted, Tangram assigns an identifier to it. IDs are numbers that uniquely identify objects in the database. C returns the ID(s) of the object(s) it was passed: $storage = Tangram::Relational->connect( $schema, @cp ); $ned_id = $storage->insert( NaturalPerson->new( firstNname => 'Ned', name => 'Flanders' ) ); @sisters_id = $storage->insert( NaturalPerson->new( firstName => 'Patty', name => 'Bouvier' ), NaturalPerson->new( firstName => 'Selma', name => 'Bouvier' ) ); This enables us to retrieve the objects: $ned = $storage->load( $ned_id ); @sisters = $storage->load( @sisters_id ); For more information on loading objects by id, see L. =head2 Obtaining objects from other objects Once Homer has been restored to his previous state, including his relations with his family. Thus we can say: $storage = Tangram::Relational->connect( $schema, @cp ); $homer = $storage->load( $homer_id ); # load by id $marge = $homer->{partner}; @kids = @{ $homer->{children} }; Actually, when Tangram loads an object that contains references to other persistent objects, it doesn't retrieve the referenced objects immediately. Marge is retrieved only when Homer's 'partner' field is accessed. This mechanism is almost totally transparent, we'd have to use C to observe a non-present collection or reference. For more information on relationships, see L, L, L, L, L and L. =head2 select To retrieve all the objects of a given class, we use C
sets the name of the table that Tangram should use to store the state of objects pertaining to this class. This field is optional: it defaults to the class name. If the class name is not an acceptable SQL table identifier, you will need to set this field. Field C sets the type of the table, for instance, the storage back-end to the RDBMS or storage format; it specifies on a per-table basis what the C attribute of the schema defines. You almost certainly don't want to set this on a per-table basis. Field C contains an integer identifier for this class. That identifier must be unique within the same schema. If this field is not present, Tangram sets it to the last class id plus one. Fields C and C are per-class versions of their schema-wide versions documented above. These should be inherited by their subclasses, but currently (as of 2.07_06) aren't. To be safe, until this documentation is fixed, define them in all subclasses. =head2 field hash Each persistent type is identified by a 'typetag', e.g. C, C or C. All the persistent fields of a given type are grouped together inside the field hash, where the typetag is used as a key. The individual fields are specified in an array or a hash, whose layout is type-dependant. For example: fields => { string => [ qw( firstName name ) ], int => [ qw( age ) ], ref => { partner => { null => 1 } }, array => { children => 'NaturalPerson' }, }, The typetag not only specifies the type of a field, but also the way in which it should be mapped to SQL constructs. Sometimes the same Perl type lends itself to more than one mapping, for example there are at least two plausible ways of mapping a Perl array (see L and L). Tangram's persistent type system is extensible, allowing you to mount your own types and make them persistent. All you have to do is to register your type and provide mapping code. See L. Tangram comes with built-in support for the following types: * string, int, real: see L * reference : see L * array : see L, L * Set::Object : see L, L =head1 INSTANCE METHODS =head2 deploy This method is deprecated. See L. =head2 retreat This method is deprecated. See L. Tangram-2.10/lib/Tangram/Type.pod0000644000175000017500000000725610412412631015313 0ustar samvsamv=head1 NAME Tangram::Type - mapping individual fields =head1 DESCRIPTION Tangram's persistent type system is extensible, allowing you to mount your own types and make them persistent. All you have to do is to register your type and provide mapping code. See L. Tangram comes with built-in support for the following types: =over =item B Supported are strings, integers, real numbers and dates. More types of this ilk are easily added. C, C, C: see L C, C