PROP-0.1/0040755000076400007640000000000010111455645011766 5ustar awgibbsawgibbsPROP-0.1/test.pl0100700000076400007640000000032710111455555013272 0ustar awgibbsawgibbs#!/usr/bin/perl use strict; use Test::Unit::HarnessUnit; use PROP::Conf; set_rdbms($ENV{'PROP_RDBMS'}); set_cnxn_conf($ENV{'PROP_CNXNCONF'}); my $r = Test::Unit::HarnessUnit->new(); $r->start('PROP::TestSuite'); PROP-0.1/Changes0100644000076400007640000000000010110143402013224 0ustar awgibbsawgibbsPROP-0.1/MANIFEST0100644000076400007640000000154010110143402013074 0ustar awgibbsawgibbsChanges Makefile.PL MANIFEST README test.pl lib/PROP/Object/MySQL.pm lib/PROP/Conf.pm lib/PROP/Link.pm lib/PROP/Query/Object.pm lib/PROP/Query/Link.pm lib/PROP/Constants.pm lib/PROP/Util.pm lib/PROP/DBH.pm lib/PROP/Schema/MySQL.pm lib/PROP/TestSuite.pm lib/PROP/LinkTest.pm lib/PROP/SQL/Delete.pm lib/PROP/SQL/Insert.pm lib/PROP/SQL/Select.pm lib/PROP/SQL/Update.pm lib/PROP/SQL/SelectTest.pm lib/PROP/SQL/UpdateTest.pm lib/PROP/SQL/TestSuite.pm lib/PROP/SQL/InsertTest.pm lib/PROP/SQL/DeleteTest.pm lib/PROP/SQL.pm lib/PROP/TestCommon.pm lib/PROP/Object.pm lib/PROP/ResultSet/Object.pm lib/PROP/ResultSet/Link.pm lib/PROP/ResultSet/ObjectTest.pm lib/PROP/ResultSet/TestSuite.pm lib/PROP/ResultSet/LinkTest.pm lib/PROP/Conf/MySQLTest.pm lib/PROP/Conf/TestSuite.pm lib/PROP/Conf/MySQL.pm lib/PROP/Schema.pm lib/PROP/ObjectTest.pm lib/PROP/SchemaTest.pm lib/PROP.pm PROP-0.1/lib/0040755000076400007640000000000010110143432012517 5ustar awgibbsawgibbsPROP-0.1/lib/PROP.pm0100644000076400007640000001675410110143402013644 0ustar awgibbsawgibbspackage PROP; our $VERSION = 0.1; =head1 Name PROP =head1 Description This module serves as a framework for both object and relationship persistence via a SQL capable database. Interaction with an underlying database is accomplished via Perl objects that abstract away all of the tedious construction, issuance, and processing of SQL queries. Within this framework, users may create, modify and delete objects, as well as link them together in arbitrary ways, and perform a variety of querying operations. The querying engine is reasonably sophisticated, allowing for a large degree of flexibility without becoming overly cumbersome, and performs intelligent buffering of results so as to be extensible to large queries. Divided into several conceptual components, this module provides several well isolated sub-components that are reasonably easy to understand on their own. Short descriptions of these modules may be found in the following section. =head1 SYNOPSIS =over =item Create Database Tables The first thing you need to do is to create the underlying database tables for object and relationship persistence. This is very simple. Object tables can have arbitrary fields, but must have a single automatically incrementing integer field as primary key. Link tables, for specifying relationships, must have a dual integer primary key, keys that will refer to the primary keys of rows in object tables, and then may also have arbitrarily many "context" fields that are used to specify information about the context from which an object was loaded. =item Wrapping Database Functionality With Perl Classes Once the database has been configured with the appropriate tables, the next thing to do is to write the Perl that will interface to it. For objects, the only thing required is to create classes that specify PROP::Object as the base class, and provide a get_table_name method that returns the name of the table in the database. For relationships, there is no subclassing involved; rather, one simply constructs objects of class PROP::Link, passing to its constructor the name of the link table in the underlying database, and the class names of the parent and child classes. =item Create Application Initialization of your application will entail working with the PROP::Conf class, in order to let the framework know where the database with which it will be working lives. Once the framework has been configured, working with objects, links, queries, and result sets is a seamless process that cleanly conceals the underlying database implementation. All of the classes know how to work with the database in a way that is (hopefully) totally transparent to the user. You just need to know how to employ their APIs to your end. =back =head1 Modules =over =item PROP::Object If any class were said to lie at the center of this module, this would be the one. This class serves as the base class for all object types, and provides a collection of methods for performing all common object operations, such as saving, modifying, and deleting. Subclasses to this class must provide a get_table_name() method, and will probably also include various and sundry wrapper methods to flesh out the functionality of the class. One can load single objects via themselves, or obtain collections of objects by using the PROP::Query::Object class. =item PROP::Link A PROP::Link object specifies a linking relationship in the database, and also provides mechanisms for creating, modifying and deleting relationships between objects as specified by the link in question. =item PROP::Query::Object This class is used to specify a query of a collection of objects. Queries of this type are specified with conditions, bindings of condition variables to values, and orderings. One may additionally specify a list of PROP::Query::Link objects which will specify that the objects loaded should be loaded with certain parent and/or children objects. An object of this class is passed to the constructor of PROP::ResultSet::Object to perform an actual query. =item PROP::Query::Link A PROP::Query::Link object is used to specify a query of a collection of linked objects. Queries of this type are specified with a link, conditions, and orderings. An object of this class is passed to the constructor of PROP::ResultSet::Link to perform an actual query. =item PROP::ResultSet::Object A PROP::ResultSet::Object is the source of objects as specified by a PROP::Query::Object object.. By repeatedly invoking the get_next_result() method until it returns undef, one can iterate over the results of a query, getting back instances of classes that derive from PROP::Object. =item PROP::ResultSet::Link A PROP::ResultSet::Link is the source of results of a query on a link as specified by a PROP::Query::Link object. By repeatedly invoking the get_next_result() method until it returns undef, one can iterate over the results of a query, getting back instances of the class PROP::ResultSet::Link::Result, a helper class for PPO::ResultSet::Link, the documentation for which may be found within the documentation for PROP::ResultSet::Link. =item PROP::Schema A PROP::Schema object contains all pertinent information about a database table. Users will probably never have need to create a PROP::Schema object directly. Rather, the PPO::NIST::Object class provides a get_table() method that returns an object of this type. The table returned is contingent upon the derived class's get_table_name() method. Using the name of the table, PROP::Object constructs a PROP::Schema object which populates itself with table structure information by querying the database. =item PROP::SQL The PROP::SQL class is a base class for several derived classes, each of which provides for a certain type of SQL statement. This class takes table names, field names, conditions, orderings, and other such statement parameters, and then via the stringify() method returns a scalar that holds the statement string. This tree of classes is mostly used internally by the framework to populate objects and manipulate the underlying database, but may also be useful to users who wish to issue queries that are not directly supported by the framework and thus need to craft custom queries. =item PROP::Util This class holds a collection of static utility methods that allow for performing common database tasks. =item PROP::Conf The PROP::Conf class is a base class for classes that parse connection configuration information for various RDBMS, e.g. PROP::Conf::MySQL. =item PROP::DBH The PROP::DBH class has but a single static method, get_handle(), which creates database handles via calling DBI->connect(...). It pulls configuration information from PROP::Conf. =back =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/0040755000076400007640000000000010111454751013311 5ustar awgibbsawgibbsPROP-0.1/lib/PROP/Query/0040755000076400007640000000000010111453154014412 5ustar awgibbsawgibbsPROP-0.1/lib/PROP/Query/Link.pm0100644000076400007640000001373010111453144015645 0ustar awgibbsawgibbspackage PROP::Query::Link; use strict; use Carp; use PROP::Constants; use Hash::Util qw/lock_keys/; use PROP::ResultSet::Link; use PROP::Conditions::Local; use PROP::Conditions::Foreign; use PROP::Exception::IllegalArgument; sub new { my ($invocant, $foreign_conditions, $orderings, $buffer_size, $limit) = @_; die new PROP::Exception::IllegalArgument("was expecting foreign conditions") unless ref($foreign_conditions) eq 'PROP::Conditions::Foreign'; my $link = $foreign_conditions->get_link(); my $relationship = $foreign_conditions->get_relationship(); my $conditions = new PROP::Conditions::Local($foreign_conditions->get_expressions() || [], $foreign_conditions->get_bindings() || []); my $class = ref($invocant) || $invocant; my $self = bless({}, $class); unless($relationship eq 'parents' or $relationship eq 'children') { my $msg = "was expecting either 'parents' or 'children', but got '$relationship'"; die new PROP::Exception::IllegalArgument($msg); } $self->{-link} = $link; $self->{-relationship} = $relationship; $self->{-conditions} = $conditions || new PROP::Conditions::Local([], []); $self->{-orderings} = $orderings || []; $self->{-buffer_size} = $buffer_size || LIMIT; $self->{-limit} = $limit; unless(ref($self->{-conditions}) eq 'PROP::Conditions::Local') { my $msg = "invalid conditions argument: " . $conditions; die new PROP::Exception::IllegalArgument($msg); } lock_keys(%$self) if DEBUG; return $self; } sub push_conditional_expression { my ($self, $condition) = @_; $self->{-conditions}->push_expression($condition); } sub push_binding { my ($self, $binding) = @_; $self->{-conditions}->push_binding($binding); } sub get_link { my ($self) = @_; return $self->{-link}; } sub get_relationship { my ($self) = @_; return $self->{-relationship}; } sub get_expressions { my ($self) = @_; return $self->{-conditions}->get_expressions(); } sub get_bindings { my ($self) = @_; return $self->{-conditions}->get_bindings(); } sub get_orderings { my ($self) = @_; return unless $self->{-orderings}; return @{$self->{-orderings}}; } sub get_buffer_size { my ($self) = @_; return $self->{-buffer_size}; } sub get_limit { my ($self) = @_; return $self->{-limit}; } 1; =head1 Name PROP::Query::Link =head1 Description Objects of this class are used to specify and execute queries on collections of pairings for the given link, obtaining either the parents or the children in the relationship. Specifically, they are used to specify whether parents or children are to be loaded, which of those relatives are of interest, how the results should be ordered, and how many results should be buffered in memory at a time. =head1 Synopsis $ql = new PROP::Query::Link($link, $relationship, $foreign_conditions, $orderings, $buffer_size); $rsl = new PROP::ResultSet::Link($ql); =head1 Methods =over =item new $ql = PROP::Query::Link->new($link, $relationship, $foreign_conditions, $orderings, $buffer_size); This method constructs a query as follows... =over =item $link This argument is an instance of the class PROP::Link that specifies the link upon which this query operation will be performed. =item $relationship This argument is a string value, either 'parents' or 'children', specifying which part of the relationship will be loaded by the query =item $foreign_conditions This argument is an instance of the class PROP::Conditions::Foreign, and specifies restrictions on which relatives will be loaded. =item $orderings This argument is an array reference that contains zero or more fields by which to order the results of the query. =item $buffer_size This argument specifies the maximum number of rows that will be pulled into memory at a time. Programmatically speaking, this argument has no ultimate effect on what the resulting result set will contain, but can potentially affect performance dramatically, and as such it may be desirable to tune it, taking into account the size of the things being queried and the memory/cpu/disk of the machine. Basically, you want to load as many rows at a time as you can without choking the system's resources. =back =item get_link $ql->get_link() This method returns the link on which this query is to be performed. =item get_relationship $ql->get_relationship() This method returns the relationship of the objects to be obtained in the resulting result set. =item get_expressions $ql->get_expressions() This method returns the reference to the array that holds the list of conditional expressions for this query. =item get_bindings $ql->get_bindings() This method returns the reference to the array that holds the list of bindings for the conditions for this query. =item get_orderings $ql->get_orderings() This method returns the reference to the array that holds the list of fields by which to order the results. =item get_buffer_size $ql->get_buffer_size() This method returns the integer value that is the maximum number of fields that will be requested from the underlying database at a time. =back =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/Query/Object.pm0100644000076400007640000001730410110446067016164 0ustar awgibbsawgibbspackage PROP::Query::Object; use strict; use DBI; use PROP::ResultSet::Object; use PROP::ResultSet::Link; use PROP::Query::Link; use PROP::Constants; use Hash::Util qw/lock_keys/; use Carp; use UNIVERSAL qw/isa/; sub new { my ($invocant, $class, $local_conditions, $foreign_conditions, $orderings, $link_queries, $buffer_size, $limit) = @_; my $self = bless({}, ref($invocant) || $invocant); my $err_msg; unless(not($limit) or (ref($limit) eq 'ARRAY' and scalar(@$limit) == 2 and $limit->[0] =~ /\d+/ and $limit->[1] =~ /\d+/) or (not(ref($limit)) and $limit =~ /\d+/)) { $err_msg = "was expecting either an interger, " . "or an array ref holding two integers as seventh argument"; } $err_msg = "was expecting an integer value as sixth argument" unless $buffer_size and $buffer_size =~ /\d+/; unless(ref($link_queries) eq 'ARRAY' and (scalar(@$link_queries) == 0 or not grep { not isa($_, 'PROP::Query::Link') } @$link_queries)) { $err_msg = "was expecting an array reference of " . "PROP::Query::Link objects as fifth argument"; } unless(ref($orderings) eq 'ARRAY' and (scalar(@$orderings) == 0 or not grep { not $class->has_field($_) } @$orderings)) { $err_msg = "was expecting an array ref of orderings as fourth argument"; } unless(ref($foreign_conditions) eq 'ARRAY' and (scalar(@$foreign_conditions) == 0 or not grep { not isa($_, 'PROP::Conditions::Foreign') } @$foreign_conditions)) { $err_msg = "was expecting an array ref of " . "PROP::Conditions::Foreign objects as third argument"; } $err_msg = "was expecting a PROP::Conditions::Local object as second argument" unless isa($local_conditions, 'PROP::Conditions::Local'); $err_msg = "was expecting a class name of a subclass of PROP::Object as first argument" unless isa($class, 'PROP::Object'); if($err_msg) { my ($pkg, $file, $line) = caller(); die new PROP::Exception::IllegalArgument($err_msg, $file, $line); } $self->{-class} = $class; $self->{-local_conditions} = $local_conditions; $self->{-foreign_conditions} = $foreign_conditions; $self->{-orderings} = $orderings; $self->{-link_queries} = $link_queries; $self->{-buffer_size} = $buffer_size; $self->{-limit} = $limit; lock_keys(%$self) if DEBUG; return $self; } sub get_class { my ($self) = @_; return $self->{-class}; } sub get_foreign_conditions { my ($self) = @_; return $self->{-foreign_conditions}; } sub get_local_conditions { my ($self) = @_; return $self->{-local_conditions}; } sub get_link_queries { my ($self) = @_; return $self->{-link_queries}; } sub push_conditional_expression { my ($self, $condition) = @_; $self->{-local_conditions}->push_expression($condition); } sub get_bindings { my ($self) = @_; return $self->{-local_conditions}->get_bindings(); } sub push_binding { my ($self, $binding) = @_; $self->{-local_conditions}->push_binding($binding); } sub get_orderings { my ($self) = @_; return $self->{-orderings}; } sub get_buffer_size { my ($self) = @_; return $self->{-buffer_size}; } sub get_limit { my ($self) = @_; return $self->{-limit}; } sub execute { my ($self) = @_; return new PROP::ResultSet::Object($self, $self->{-link_queries}); } 1; =head1 Name PROP::Query::Object =head1 Description Objects of this class are used to specify how queries on collections of objects are performed. =head1 Synopsis $qo = PROP::Query::Object->new($class, $lc, [$fc1, $fc2, ..., $fcn], ['field1', 'field2'], [$lq1, $lq2, ..., $lqn], $buffer_size, $limit); $rso = new PROP::ResultSet::Object($qo); =head1 Methods =over =item new $oq = PROP::Query::Object->new($class, $local_conditions, $foreign_conditions, $orderings, $link_queries, $buffer_size, $limit); This method constructs a query as follows... =over =item $class This argument specifies the class of the collection to be queried, which must be a subclass of PROP::Object. =item $local_conditions This argument is an instance of PROP::Conditions::Local. It is used to specify which objects of the class will be loaded as per restrictions on its own field values. =item $foreign_conditions This argument is an array reference containing zero or more instances of the class PROP::Conditions::Foreign. The PPO::Conditions::Foreign objects specify which objects of the class will be loaded as per restrictions on the objects with which it is associated, e.g. "only load objects that have children that have such and such values". =item $orderings This argument is an array reference that contains zero or more fields by which to order the results of the query. =item $link_queries This argument is an array reference that contains zero or more PROP::Query::Link objects that specify which related objects should be loaded in the course of executing the query. =item $buffer_size This argument specifies the maximum number of rows that will be pulled into memory at a time. Programmatically speaking, this argument has no ultimate effect on what the resulting result set will contain, but can potentially affect performance dramatically, and as such it may be desirable to tune it, taking into account the size of the things being queried and the memory/cpu/disk of the machine. Basically, you want to load as many rows at a time as you can without choking the system's resources. =item $limit This argument specifies a maximum number of rows to return, and possibly also an offset into the result being returned. It has two forms: it can be an integer value, in which case it is interpreted as the maximum number of rows to return; it can be an array reference that holds two intergers, the first being the offset into the results at which to start returning results, and the second being the maximum number of results to return. =back =item get_class $oq->get_class() This method returns the class of the object collection that is being queried. =item get_local_conditions $oq->get_local_conditions() This method returns the PROP::Conditions::Local object that is associated with this query, i.e. the one that was passed into its constructor. =item get_foreign_conditions $oq->get_foreign_conditions() This method returns the array reference of PROP::Conditions::Foreign objects that are associated with this query, i.e. the ones that were passed into its constructor. =item get_orderings $oq->get_orderings() This method returns the reference to the array that holds the list of fields by which the results of the query should be ordered. =item get_buffer_size $oq->get_buffer_size() This method returns the integer value that is the maximum number of fields that will be loaded from the underlying database at a time. =back =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/ObjectTest.pm0100644000076400007640000001572210110143402015704 0ustar awgibbsawgibbspackage PROP::ObjectTest; use strict; use base qw/Test::Unit::TestCase/; use PROP::DBH; use PROP::TestCommon; use PROP::Util; use PROP::Link; sub new { my ($invocant, @args) = @_; my $self = $invocant->SUPER::new(@args); return $self; } sub set_up { my ($self) = @_; drop_tables(); create_tables(); } sub tear_down { my ($self) = @_; drop_tables(); } sub test_object_field_verification { my ($self) = @_; my $class = 'Dummy::Foo'; # first see if the guard clauses for add_field_verifier work... eval { PROP::Object::add_field_verifier({}); }; my $err = $@; $self->assert_equals('PROP::Exception::IllegalArgument', ref($err)); $self->assert_matches(qr/invalid invocant/, $err); eval { $class->add_field_verifier('blah'); }; $err = $@; $self->assert_equals('PROP::Exception::IllegalArgument', ref($err)); $self->assert_matches(qr/unknown field 'blah' specified/, $err); eval { $class->add_field_verifier('bar', "not a code ref!"); }; $err = $@; $self->assert_equals('PROP::Exception::IllegalArgument', ref($err)); $self->assert_matches(qr/verifier must be a code ref/, $err); # create a couple of objects to play with my @objects = ($class->new(), $class->new()); # this should work, because we have no field verifiers eval { $objects[0]->set_field_value('bar', 'blah'); $objects[1]->set_field_value('bar', 'meh'); }; $self->assert_equals('', $@); # this should work because we're not abusing the method arguments eval { $class->add_field_verifier('bar', sub { shift() =~ /\d+/; }); }; $self->assert_str_equals('', $@); eval { $objects[0]->add_field_verifier('bar', sub { $_[0] > 3 }); }; $self->assert_str_equals('', $@); # this should work because we obey the wishes of the field verifiers eval { $objects[0]->set_field_value('bar', 5); $objects[1]->set_field_value('bar', 1); }; $self->assert_str_equals('', $@); # this should work because we set a field that isn't verified eval { $objects[0]->set_field_value('baz', 2); $objects[0]->set_field_value('baz', 'meh'); $objects[1]->set_field_value('baz', 1); $objects[1]->set_field_value('baz', 'feh'); }; $self->assert_str_equals('', $@); eval { $objects[0]->set_field_value('bar', 2); }; $err = $@; $self->assert_equals('PROP::Exception::IllegalArgument', ref($@)); $self->assert_matches(qr/invalid value '2' specified for field 'bar' for class Dummy::Foo/, $err); eval { $objects[0]->set_field_value('bar', 'meh'); }; $err = $@; $self->assert_equals('PROP::Exception::IllegalArgument', ref($err)); $self->assert_matches(qr/invalid value 'meh' specified for field 'bar' for class Dummy::Foo/, $err); eval { $objects[1]->set_field_value('bar', 'blah'); }; $err = $@; $self->assert_equals('PROP::Exception::IllegalArgument', ref($err)); $self->assert_matches(qr/invalid value 'blah' specified for field 'bar' for class Dummy::Foo/, $err); } sub test_update { my ($self) = @_; my $foo = new Dummy::Foo(); $foo->set_bar(34); $foo->set_baz('whatever'); my $pk_val = $foo->save(); $foo = new Dummy::Foo($pk_val); $self->assert_equals($foo->get_bar(), 34); $self->assert_equals($foo->get_baz(), 'whatever'); $foo->set_bar(45); $foo->save(); $foo = new Dummy::Foo($pk_val); $self->assert_equals($foo->get_bar(), 45); $self->assert_equals($foo->get_baz(), 'whatever'); $foo->set_baz('something'); $foo->save(); $foo = new Dummy::Foo({ bar => 45 }); $self->assert_equals($pk_val, $foo->get_pk_value()); $self->assert_equals(45, $foo->get_bar()); $self->assert_equals('something', $foo->get_baz()); } sub test_delete { my ($self) = @_; my $foo = new Dummy::Foo(); $foo->set_bar(56); $foo->set_baz('So long, and thanks for all the fish!'); my $pk_val = $foo->save(); $foo = new Dummy::Foo($pk_val); $self->assert_equals($foo->get_bar(), 56); $self->assert_equals($foo->get_baz(), 'So long, and thanks for all the fish!'); $foo->delete(); $foo = new Dummy::Foo({ bar => 56 }); $self->assert_null($foo->get_pk_value()); } sub test_load_relatives { my ($self) = @_; my ($f, $b, $fz, $links) = populate_database(); my $foo = Dummy::Foo->new({ foo => 3 }); # NEW my $foreign_conditions = new PROP::Conditions::Foreign($links->[0], 'children'); my $link_query = new PROP::Query::Link($foreign_conditions); # my $link_query = new PROP::Query::Link($links->[0], 'children'); $self->assert(not defined $foo->get_children($links->[0]->get_table_name())); $foo->load_relatives([$link_query]); $self->assert_equals(4, scalar($foo->get_children($links->[0]->get_table_name()))); } sub test_object_invalid_params { my ($self) = @_; my ($f, $b, $fz, $links) = populate_database(); eval { $f->[0]->set_pk_value("meh"); }; $self->assert_equals('PROP::Exception::IllegalArgument', ref($@)); eval { $f->[0]->_add_parent("meh"); }; $self->assert_equals('PROP::Exception::IllegalArgument', ref($@)); eval { $f->[0]->_add_parent($links->[0], $b->[0]); }; $self->assert_equals('PROP::Exception::IllegalArgument', ref($@)); eval { $b->[0]->_add_parent($links->[0], $f->[0]); }; $self->assert_equals('', ref($@)); eval { $f->[0]->_add_child("meh"); }; $self->assert_equals('PROP::Exception::IllegalArgument', ref($@)); eval { $f->[0]->_add_child($links->[0], $fz->[0]); }; $self->assert_equals('PROP::Exception::IllegalArgument', ref($@)); eval { $f->[0]->_add_child($links->[0], $b->[0]); }; $self->assert_equals('', ref($@)); eval { $f->[0]->set_field_value('asdfzxcv'); }; $self->assert_equals('PROP::Exception::IllegalArgument', ref($@)); eval { $f->[0]->set_field_value('asdfzxcv', 34); }; $self->assert_equals('PROP::Exception::IllegalArgument', ref($@)); eval { $f->[0]->load_relatives(['foo', 'bar', 'baz']); }; $self->assert_equals('PROP::Exception::IllegalArgument', ref($@)); } 1; =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/Schema/0040755000076400007640000000000010110143432014477 5ustar awgibbsawgibbsPROP-0.1/lib/PROP/Schema/MySQL.pm0100644000076400007640000000272410110143402016001 0ustar awgibbsawgibbspackage PROP::Schema::MySQL; use strict; use PROP::Schema; use base qw/PROP::Schema/; use PROP::Exception; sub _query_schema { my ($self) = @_; my $statement = 'describe ' . $self->get_table_name(); my $sth = PROP::DBH->get_handle()->prepare($statement); unless($sth->execute()) { my $msg = "problem querying schema for table '" . $self->get_table_name() . "'"; die new PROP::Exception($msg); } my $row; while($row = $sth->fetchrow_arrayref()) { my $field = new PROP::Schema::Field($row->[0], $row->[3] eq 'PRI' ? 1 : 0); $self->_add_field($field); } } 1; =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/TestCommon.pm0100644000076400007640000000752110110143402015724 0ustar awgibbsawgibbspackage PROP::TestCommon; use strict; use PROP::DBH; use PROP::Util; use base qw/Exporter/; our @EXPORT = qw/create_tables drop_tables populate_database create_links/; sub create_tables { my $sth; my $dbh = PROP::DBH->get_handle(); $sth = $dbh->prepare("create table Foo (\n" . "foo int(10) NOT NULL auto_increment,\n" . "bar int(10),\n" . "baz varchar(80),\n" . "primary key (foo))\n"); $sth->execute(); $sth = $dbh->prepare("create table Biz (\n" . "biz int(10) NOT NULL auto_increment,\n" . "boz int(10),\n" . "buzz varchar(80),\n" . "primary key (biz))\n"); $sth->execute(); $sth = $dbh->prepare("create table Fizz (\n" . "fizz int(10) NOT NULL auto_increment,\n" . "fuzz int(10),\n" . "fozz varchar(80),\n" . "primary key (fizz))\n"); $sth->execute(); $sth = $dbh->prepare("create table LinkFooToBiz (\n" . "foo_id int(10) NOT NULL,\n" . "biz_id int(10) NOT NULL,\n" . "c1 varchar(80),\n" . "c2 varchar(80),\n" . "c3 varchar(80),\n" . "primary key (foo_id, biz_id))\n"); $sth->execute(); $sth = $dbh->prepare("create table LinkFooToFizz (\n" . "foo_id int(10) NOT NULL,\n" . "fizz_id int(10) NOT NULL,\n" . "c1 varchar(80),\n" . "c2 varchar(80),\n" . "c3 varchar(80),\n" . "primary key (foo_id, fizz_id))\n"); $sth->execute(); } sub drop_tables { PROP::Util::drop_table('Foo'); PROP::Util::drop_table('Biz'); PROP::Util::drop_table('Fizz'); PROP::Util::drop_table('LinkFooToBiz'); PROP::Util::drop_table('LinkFooToFizz'); } sub create_links { return [new PROP::Link('LinkFooToBiz', 'Dummy::Foo', 'Dummy::Biz'), new PROP::Link('LinkFooToFizz', 'Dummy::Foo', 'Dummy::Fizz')]; } sub populate_database { my (@f, @b, @fz); my $links = create_links(); foreach (1..4) { my $f = new Dummy::Foo(); $f->set_bar($_); $f->set_baz('blah' . $_); $f->save(); push(@f, $f); } foreach (1..16) { my $b = new Dummy::Biz(); $b->set_boz($_); $b->set_buzz('bleh' . $_); $b->save(); push(@b, $b); } foreach (1..16) { my $fz = new Dummy::Fizz(); $fz->set_fuzz($_ * 2); $fz->set_fozz('bleh' . ($_ * 2)); $fz->save(); push(@fz, $fz); } for(my $i = 0; $i < 4; ++$i) { for(my $j = 0; $j < 4; ++$j) { $links->[0]->insert($f[$i]->get_pk_value(), $b[$j]->get_pk_value(), {'c1' => $i, 'c2' => $i * $j, 'c3' => 'meh'}); } } for(my $i = 0; $i < 4; ++$i) { for(my $j = 0; $j < 4; ++$j) { $links->[1]->insert($f[$i]->get_pk_value(), $fz[$j]->get_pk_value(), {'c1' => $i * 2, 'c2' => 2 * $i * $j , 'c3' => 'bleh'}); } } return (\@f, \@b, \@fz, $links); } package Dummy::Foo; use strict; use base qw/PROP::Object/; sub get_table_name { return 'Foo'; } package Dummy::Biz; use strict; use base qw/PROP::Object/; sub get_table_name { return 'Biz'; } package Dummy::Fizz; use strict; use base qw/PROP::Object/; sub get_table_name { return 'Fizz'; } 1; =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/ResultSet/0040755000076400007640000000000010111453527015243 5ustar awgibbsawgibbsPROP-0.1/lib/PROP/ResultSet/ObjectTest.pm0100644000076400007640000001305510110143402017633 0ustar awgibbsawgibbspackage PROP::ResultSet::ObjectTest; use strict; use base qw/Test::Unit::TestCase/; use PROP::DBH; use PROP::TestCommon; use PROP::Util; use PROP::Link; use PROP::Query::Link; use PROP::ResultSet::Link; use PROP::Conditions::Foreign; use Data::Dumper; sub new { my ($invocant, @args) = @_; my $self = $invocant->SUPER::new(@args); return $self; } sub set_up { my ($self) = @_; drop_tables(); create_tables(); } sub tear_down { my ($self) = @_; # drop_tables(); } sub test_simple_lookup { my ($self) = @_; my ($f, $b, $fz, $links) = populate_database(); # NEW my $fc1 = new PROP::Conditions::Foreign($links->[0], 'children', [], []); my $lqs1 = new PROP::Query::Link($fc1, ['l.biz_id']); # my $lqs1 = new PROP::Query::Link($links->[0], 'children', undef, ['l.biz_id']); my $fc2 = new PROP::Conditions::Foreign($links->[1], 'children', [], []); my $lqs2 = new PROP::Query::Link($fc2, ['l.fizz_id']); # my $lqs2 = new PROP::Query::Link($links->[1], 'children', undef, ['l.fizz_id']); my $rqs = new PROP::Query::Object('Dummy::Foo', new PROP::Conditions::Local([], []), [], [], [$lqs1, $lqs2], 5000); my $result_set = $rqs->execute(); my $result; my $i = 0; while($result = $result_set->get_next_result()) { my @bars = $result->get_children($links->[0]->get_table_name()); my @fizzes = $result->get_children($links->[1]->get_table_name()); $self->assert_equals(scalar(@$b) / scalar(@$f), scalar(@bars)); $self->assert_equals(scalar(@$fz) / scalar(@$f), scalar(@fizzes)); for(my $j = 0; $j < 4; ++$j) { $self->assert_equals($i, $bars[$j]->get_contextual_value('c1')); $self->assert_equals($i * $j, $bars[$j]->get_contextual_value('c2')); $self->assert_equals('meh', $bars[$j]->get_contextual_value('c3')); $self->assert_equals(2 * $i, $fizzes[$j]->get_contextual_value('c1')); $self->assert_equals(2 * $i * $j, $fizzes[$j]->get_contextual_value('c2')); $self->assert_equals('bleh', $fizzes[$j]->get_contextual_value('c3')); } ++$i; } } sub test_conditional_lookup { my ($self) = @_; my ($f, $b, $fz, $links) = populate_database(); my $link_conditions = new PROP::Conditions::Local(['p.foo % ?'], [2]); # NEW my $fc = new PROP::Conditions::Foreign($links->[0], 'children', ['p.foo % ?'], [2]); my $lq = new PROP::Query::Link($fc, ['l.biz_id']); # my $lq = new PROP::Query::Link($links->[0], 'children', $link_conditions, ['l.biz_id']); my $object_conditions = new PROP::Conditions::Local(['o.foo % ?'], [2]); my $oq = new PROP::Query::Object('Dummy::Foo', $object_conditions, [], [], [$lq], 5000); my $result_set = $oq->execute(); my $result; foreach my $pk_value (1,3) { $result = $result_set->get_next_result(); $self->assert_equals($pk_value, $result->get_pk_value()); my $i = 0; foreach ($result->get_children('LinkFooToBiz')) { $self->assert_equals($pk_value, $_->get_contextual_value('foo_id')); $self->assert_equals($pk_value - 1, $_->get_contextual_value('c1')); $self->assert_equals(($pk_value - 1) * $i, $_->get_contextual_value('c2')); $self->assert_equals('meh', $_->get_contextual_value('c3')); ++$i; } } } sub test_conditional_lookup_with_foreign { my ($self) = @_; my ($f, $b, $fz, $links) = populate_database(); $links->[0]->delete(2, 3); my $fc = new PROP::Conditions::Foreign($links->[0], 'children', ['c.boz = ?'], [3]); my $oq = new PROP::Query::Object('Dummy::Foo', new PROP::Conditions::Local([], []), [$fc], ['foo'], [], 5000); my $rs = $oq->execute(); my $result = $rs->get_next_result(); $self->assert_equals(1, $result->get_pk_value()); $result = $rs->get_next_result(); $self->assert_equals(3, $result->get_pk_value()); $result = $rs->get_next_result(); $self->assert_equals(4, $result->get_pk_value()); $self->assert_null($rs->get_next_result()); } sub test_limited_object_query { my ($self) = @_; my ($f, $b, $fz, $links) = populate_database(); my $qo = new PROP::Query::Object('Dummy::Fizz', new PROP::Conditions::Local([], []), [], [], [], 5000, 7); my $rso = new PROP::ResultSet::Object($qo); my @results = $rso->get_all_results(); $self->assert_equals(7, scalar(@results)); $qo = new PROP::Query::Object('Dummy::Fizz', new PROP::Conditions::Local([], []), [], [], [], 5000, [4, 5]); $rso = new PROP::ResultSet::Object($qo); @results = $rso->get_all_results(); $self->assert_equals(5, scalar(@results)); my $i = 5; while(@results) { my $result = shift(@results); $self->assert_equals($i, $result->get_pk_value()); $i++; } } 1; =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/ResultSet/Link.pm0100644000076400007640000002252710110143402016466 0ustar awgibbsawgibbspackage PROP::ResultSet::Link; use strict; use DBI; use PROP::Constants; use Hash::Util qw/lock_keys/; use PROP::SQL::Select; use Carp; sub new { my ($invocant, $query) = @_; my $class = ref($invocant) || $invocant; my $self = bless({}, $class); $self->{-query} = $query; $self->{-lower_bound} = 0; $self->{-stmt} = undef; $self->{-saved_row} = undef; $self->{-returned_rows} = 0; $self->{-done} = 0; $self->{-sth} = undef; $self->{-last_instance} = undef; lock_keys(%$self) if DEBUG; $self->build_base_statement(); $self->execute_next_statement(); return $self; } sub get_link { my ($self) = @_; return $self->{-query}->get_link(); } sub get_relationship { my ($self) = @_; return $self->{-query}->get_relationship(); } sub get_link_table_name { my ($self) = @_; return $self->{-query}->get_link()->get_table_name(); } sub get_parent_table_name { my ($self) = @_; return $self->{-query}->get_link()->get_parent_table_name(); } sub get_child_table_name { my ($self) = @_; return $self->{-query}->get_link()->get_child_table_name(); } sub put_last_result { my ($self, $instance) = @_; $self->{-last_instance} = $instance; } sub get_all_results { my ($self) = @_; my (@instances, $instance); push(@instances, $instance) while($instance = $self->get_next_result()); return \@instances; } sub get_next_result { my ($self) = @_; if($self->{-last_instance}) { my $result = $self->{-last_instance}; $self->{-last_instance} = undef; return $result; } return undef if $self->{-done}; my $last_pk_value = 0; my $result = PROP::ResultSet::Link::Result->new(); if($self->{-saved_row}) { my ($pk_value, $object) = $self->instantiate_object($self->{-saved_row}); $result->set_pk_value($pk_value); $last_pk_value = $pk_value; $result->add_relative($object); $self->{-saved_row} = undef; } while(1) { my @row; while(@row = $self->{-sth}->fetchrow_array()) { $self->{-returned_rows}++; if($last_pk_value and $row[0] != $last_pk_value) { $self->{-saved_row} = \@row; last; } my ($pk_value, $object) = $self->instantiate_object(\@row); $result->set_pk_value($pk_value); $last_pk_value = $pk_value; $result->add_relative($object); } last if $self->{-saved_row}; if($self->{-returned_rows} < $self->{-query}->get_buffer_size()) { $self->{-done} = 1; last; } $self->execute_next_statement(); } return $result->get_pk_value() ? $result : undef; } sub execute_next_statement { my ($self) = @_; $self->{-returned_rows} = 0; $self->{-stmt}->set_limit([$self->{-lower_bound}, $self->{-query}->get_buffer_size()]); $self->{-lower_bound} += $self->{-query}->get_buffer_size(); $self->{-sth} = PROP::DBH->get_handle()->prepare($self->{-stmt}->stringify()); $self->{-sth}->execute($self->{-query}->get_bindings()); } sub instantiate_object { my ($self, $row) = @_; my ($class, $obj); my $r = $self->{-query}->get_relationship(); my $pk_value = shift(@$row); if($r eq 'parents') { $class = $self->{-query}->get_link()->get_parent_class(); $obj = $class->new(); $obj->_set_contextual_value($self->{-query}->get_link()->get_child_field_name(), $pk_value); } else { $class = $self->{-query}->get_link()->get_child_class(); $obj = $class->new(); $obj->_set_contextual_value($self->{-query}->get_link()->get_parent_field_name(), $pk_value); } foreach ($obj->get_field_names()) { $obj->set_field_value($_, shift(@$row)); } foreach ($self->{-query}->get_link()->get_contextual_field_names()) { $obj->_set_contextual_value($_, shift(@$row)); } return ($pk_value, $obj); } sub build_base_statement { my ($self) = @_; my $link = $self->{-query}->get_link(); my $query = $self->{-query}; my $stmt = new PROP::SQL::Select; $self->{-stmt} = $stmt; my %added_tables; $stmt->add_table($link->get_table_name() . ' l'); $added_tables{$link->get_table_name()} = 1; $stmt->add_table($link->get_parent_table_name() . ' p'); $added_tables{$link->get_parent_table_name()} = 1; $stmt->add_table($link->get_child_table_name() . ' c'); $added_tables{$link->get_child_table_name()} = 1; $stmt->push_conditional_expression('p.' . $link->get_parent_class()->get_pk_name() . '=' . 'l.' . $link->get_parent_field_name()); $stmt->push_conditional_expression('c.' . $link->get_child_class()->get_pk_name() . '=' . 'l.' . $link->get_child_field_name()); $stmt->push_conditional_expression($_) foreach ($query->get_expressions()); $stmt->push_ordering($_) foreach ($query->get_orderings()); my $r = $query->get_relationship(); if($r eq 'parents') { $stmt->push_field('c.' . $link->get_child_class()->get_pk_name()); foreach ($link->get_parent_class()->get_field_names()) { $stmt->push_field('p.' . $_); } $stmt->unshift_ordering('c.' . $link->get_child_class()->get_pk_name()); } elsif($r eq 'children') { $stmt->push_field('p.' . $link->get_parent_class()->get_pk_name()); foreach ($link->get_child_class()->get_field_names()) { $stmt->push_field('c.' . $_); } $stmt->unshift_ordering('p.' . $link->get_parent_class()->get_pk_name()); } else { my $msg = "unknown relationship"; die new PROP::Exception($msg); } $stmt->push_field('l.' . $_) foreach ($link->get_contextual_field_names()); } package PROP::ResultSet::Link::Result; use strict; use PROP::Constants; use Hash::Util qw/lock_keys/; sub new { my ($invocant, $pk_value, $relatives) = @_; my $self = bless({}, ref($invocant) || $invocant); $self->{-pk_value} = $pk_value || 0; $self->{-relatives} = $relatives || []; lock_keys(%$self) if DEBUG; return $self; } sub get_pk_value { my ($self) = @_; return $self->{-pk_value}; } sub set_pk_value { my ($self, $pk_value) = @_; $self->{-pk_value} = $pk_value; } sub get_relatives { my ($self) = @_; return $self->{-relatives}; } sub add_relative { my ($self, $relative) = @_; push(@{$self->{-relatives}}, $relative); } 1; =head1 Name PROP::ResultSet::Link::ResultSet =head1 Description Objects of this class are used to instantiate the results of a query specified by the PROP::Query::Link object passed to its constructor. The actual results can be obtained by repeated invocation of get_next_result() which will return an instance of the class PROP::ResultSet::Link::Result as long as there are more results, and eventually undef. Each PROP::ResultSet::Link::Result object holds the id of an object and a list of its relatives that were loaded from the database by the specified query. =head1 Synopsis $ql = new PROP::Query::Link(...); $rsl = new PROP::ResultSet::Link($ql); while($result = $rsl->get_next_result()) { # do stuff with $result, an instance of PROP::ResultSet::Link::Result } =head1 Methods =over =item new $rsl = PROP::ResultSet::Link->new($ql); This method constructs a new PROP::ResultSet::Link, as specified by the PROP::Query::Link $ql. =item get_next_result $result = $rsl->get_next_result() This method returns the next PROP::ResultSet::Link::Result in the result set, from which the loaded relatives for a given object can be extracted. =back =head1 Name PROP::ResultSet::Link::Result =head1 Description An instance of this class is returned upon each invocation of the get_next_result() method of a PROP::ResultSet::Link object. It contains the results from the result set that correspond to the relatives for one particular object. Specifically, it contains the primary key value of the object for which relatives were loaded, and a list containing those relatives. =head1 Synopsis $result = $rsl->get_next_result(); print "object primary key: ", $result->get_pk_value(), "\n"; foreach $relative (@{$result->get_relatives()}) { print "relative primary key: ", $relative->get_pk_value(), "\n"; } =head1 Methods =over =item get_pk_value $result->get_pk_value() This method returns the value of the primary key of the object for which a list of relatives has been returned within this PROP::ResultSet::Link::Result object. =item get_relatives $result->get_relatives() This method returns an array reference that contains the relatives that were loaded for a specific object as the result of the query specified for the PROP::ResultSet::Link object that returned this PROP::ResultSet::Link::Result object. Each of these relatives is an instance of a subclass of PROP::Object. =back =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/ResultSet/LinkTest.pm0100644000076400007640000000465210110143402017325 0ustar awgibbsawgibbspackage PROP::ResultSet::LinkTest; use strict; use base qw/Test::Unit::TestCase/; use PROP::DBH; use PROP::TestCommon; use PROP::Util; use PROP::Link; use PROP::Query::Link; use PROP::ResultSet::Link; use Data::Dumper; sub new { my ($invocant, @args) = @_; my $self = $invocant->SUPER::new(@args); return $self; } sub set_up { my ($self) = @_; drop_tables(); create_tables(); } sub tear_down { my ($self) = @_; drop_tables(); } sub test_stuff { my ($self) = @_; my ($f, $b, $fz, $links) = populate_database(); # NEW my $fc = new PROP::Conditions::Foreign($links->[0], 'children'); my $query = new PROP::Query::Link($fc); # my $query = new PROP::Query::Link($links->[0], 'children'); my $result_set = $query->execute(); my $result; my $i = 0; while($result = $result_set->get_next_result()) { $self->assert_equals($f->[$i]->get_pk_value(), $result->get_pk_value()); $self->assert_equals(4, scalar(@{$result->get_relatives()})); for(my $j = 0; $j < scalar(@{$result->get_relatives()}); ++$j) { $self->assert_equals($b->[$j]->get_pk_value(), $result->get_relatives()->[$j]->get_pk_value()); $self->assert_equals($i + 1, $result->get_relatives()->[$j]->get_contextual_value('foo_id')); $self->assert_equals($i, $result->get_relatives()->[$j]->get_contextual_value('c1')); $self->assert_equals($i * $j, $result->get_relatives()->[$j]->get_contextual_value('c2')); $self->assert_equals('meh', $result->get_relatives()->[$j]->get_contextual_value('c3')); } ++$i; } } 1; =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/ResultSet/TestSuite.pm0100644000076400007640000000201510110143402017510 0ustar awgibbsawgibbspackage PROP::ResultSet::TestSuite; use strict; use base qw/Test::Unit::TestSuite/; sub include_tests { return ('PROP::ResultSet::ObjectTest'); } 1; =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/ResultSet/Object.pm0100644000076400007640000002110510110417277017004 0ustar awgibbsawgibbspackage PROP::ResultSet::Object; use strict; use DBI; use PROP::Constants; use Hash::Util qw/lock_keys/; use PROP::SQL::Select; use Data::Dumper; use PROP::Query::Object; use Data::Dumper; use UNIVERSAL qw/isa/; sub new { my ($invocant, $object_query) = @_; my $self = bless({}, ref($invocant) || $invocant); my $err_msg; $err_msg = "was expecting a PROP::Query::Object object as first argument" unless isa($object_query, 'PROP::Query::Object'); if($err_msg) { my ($pkg, $file, $line) = caller(); die new PROP::Exception::IllegalArgument($err_msg, $file, $line); } $self->{-object_query} = $object_query; $self->{-link_result_sets} = [map { new PROP::ResultSet::Link($_) } @{$object_query->get_link_queries()}]; $self->{-stmt} = undef; $self->{-sth} = undef; $self->{-lower_bound} = 0; $self->{-done} = 0; $self->{-returned_rows} = 0; $self->{-limit} = 0; lock_keys(%$self) if DEBUG; my $limit = $object_query->get_limit(); if($limit) { if(ref($limit)) { $self->{-lower_bound} = $limit->[0]; $self->{-limit} = $limit->[1]; } else { $self->{-limit} = $limit; } } $self->build_base_statement(); $self->execute_next_statement(); return $self; } sub get_all_results { my ($self) = @_; my (@results, $result); push(@results, $result) while($result = $self->get_next_result()); return @results; } sub get_next_result { my ($self) = @_; return undef if $self->{-done}; my @row = $self->{-sth}->fetchrow_array(); unless(@row) { if($self->{-returned_rows} < $self->{-object_query}->get_buffer_size()) { $self->{-done} = 1; return undef; } else { $self->execute_next_statement(); @row = $self->{-sth}->fetchrow_array(); unless(@row) { $self->{-done} = 1; return undef; } } } $self->{-returned_rows}++; $self->{-done} = 1 if $self->{-returned_rows} == $self->{-limit}; return $self->instantiate_object(\@row); } sub instantiate_object { my ($self, $row) = @_; my $obj = $self->{-object_query}->get_class()->new(); $obj->set_field_value($_, shift(@$row)) foreach($self->{-object_query}->get_class()->get_field_names()); $obj->_clear_modification_flags(); foreach my $result_set (@{$self->{-link_result_sets}}) { my $instance = $result_set->get_next_result(); next unless $instance; while($instance->get_pk_value() < $obj->get_pk_value()) { last unless $instance; $instance = $result_set->get_next_result(); } next unless $instance; if($instance->get_pk_value() == $obj->get_pk_value()) { if($result_set->get_relationship() eq 'parents') { foreach my $parent (@{$instance->get_relatives()}) { $obj->_add_parent($result_set->get_link(), $parent); } } else { foreach my $child (@{$instance->get_relatives()}) { $obj->_add_child($result_set->get_link(), $child); } } } elsif($instance->get_pk_value() > $obj->get_pk_value) { $result_set->put_last_result($instance); } else { my $msg = "ok, that is weird... probably an algorithm bug :-("; die new PROP::Exception($msg); } } return $obj; } sub build_base_statement { my ($self) = @_; my $class = $self->{-object_query}->get_class(); my @field_names = $class->get_schema(PROP::DBH->get_handle())->get_field_names(); my $stmt = new PROP::SQL::Select; $stmt->set_distinct(); $stmt->add_table($class->get_table_name() . ' o'); $stmt->push_field('o.' . $_) foreach (@field_names); foreach ($self->{-object_query}->get_local_conditions()->get_expressions()) { my $expression = $_; # prepend the table alias to the conditions that reference # fields without the alias foreach my $field (@field_names) { $expression =~ s/(?push_conditional_expression($expression); } my $i = 1; foreach my $foreign_conditions (@{$self->{-object_query}->get_foreign_conditions()}) { my $foreign_alias = 't' . $i; my $link_alias = 'l' . $i; $stmt->add_table($foreign_conditions->get_link()->get_table_name() . ' ' . $link_alias); if($foreign_conditions->get_relationship() eq 'parents') { $stmt->add_table($foreign_conditions->get_link->get_parent_table_name() . ' ' . $foreign_alias); # join the tables $stmt->push_conditional_expression('o.' . $class->get_pk_name() . '=' . $link_alias . '.' . $foreign_conditions->get_link()->get_child_field_name()); $stmt->push_conditional_expression($foreign_alias . '.' . $foreign_conditions->get_link()->get_parent_class()->get_pk_name() . '=' . $link_alias . '.' . $foreign_conditions->get_link()->get_parent_field_name()); foreach (@{$foreign_conditions->get_expressions()}) { my $expression = $_; $expression =~ s/c\./o\./g; $expression =~ s/p\./$foreign_alias\./g; $expression =~ s/l\./$link_alias\./; $stmt->push_conditional_expression($expression); } } else { $stmt->add_table($foreign_conditions->get_link()->get_child_table_name() . ' ' . $foreign_alias); # join the tables $stmt->push_conditional_expression('o.' . $class->get_pk_name() . '=' . $link_alias . '.' . $foreign_conditions->get_link()->get_parent_field_name()); $stmt->push_conditional_expression($foreign_alias . '.' . $foreign_conditions->get_link()->get_child_class()->get_pk_name() . '=' . $link_alias . '.' . $foreign_conditions->get_link()->get_child_field_name()); foreach (@{$foreign_conditions->get_expressions()}) { my $expression = $_; $expression =~ s/p\./o\./g; $expression =~ s/c\./$foreign_alias\./g; $expression =~ s/l\./$link_alias\./; $stmt->push_conditional_expression($expression); } } ++$i; } foreach (@{$self->{-object_query}->get_orderings()}) { $stmt->push_ordering(/^o\./ ? $_ : 'o.' . $_); } # print "stmt: ", $stmt->stringify(), "\n"; $self->{-stmt} = $stmt; } sub execute_next_statement { my ($self) = @_; $self->{-returned_rows} = 0; $self->{-stmt}->set_limit([$self->{-lower_bound}, $self->{-object_query}->get_buffer_size()]); $self->{-lower_bound} += $self->{-object_query}->get_buffer_size(); $self->{-sth} = PROP::DBH->get_handle()->prepare($self->{-stmt}->stringify()); my @bindings = $self->{-object_query}->get_local_conditions()->get_bindings(); foreach my $foreign_conditions (@{$self->{-object_query}->get_foreign_conditions()}) { push(@bindings, @{$foreign_conditions->get_bindings()}); } $self->{-sth}->execute(@bindings); } 1; =head1 Name PROP::ResultSet::Object =head1 Description Objects of this class are used to instantiate the results of a query specified by the PROP::Query::Object object passed to its constructor. The actual results can be obtained by repeated invocation of get_next_result() which will return an instance of a subclass of PROP::Object as long as there are more results, and eventually undef. =head1 Synopsis $qo = new PROP::Query::Object(...); $rso = new PROP::ResultSet::Object($qo); while($result = $rso->get_next_result()) { # do stuff with $result, which ISA PROP::Object } =head1 Methods =over =item new $rso = new PROP::ResultSet::Object($qo); This method constructs a new PROP::ResultSet::Object, as specified by the PROP::Query::Object $qo. =item get_next_result $result = $rso->get_next_result() This method returns the next object in the result set. The returned object ISA PROP::Object, and is an instance of the subclass that was specified in the contructor of the PROP::Query::Object object that was passed to the constructor of this PROP::ResultSet::Object object. =back =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/SchemaTest.pm0100644000076400007640000000426410110143402015675 0ustar awgibbsawgibbspackage PROP::SchemaTest; use strict; use base qw/Test::Unit::TestCase/; use PROP::DBH; use PROP::TestCommon; use PROP::Schema; sub new { my ($invocant, @args) = @_; my $self = $invocant->SUPER::new(@args); return $self; } sub set_up { my ($self) = @_; drop_tables(); create_tables(); } sub tear_down { my ($self) = @_; drop_tables(); } sub test_object_table { my ($self) = @_; my $table = new PROP::Schema('Foo'); $self->assert_equals('Foo', $table->get_table_name()); my @fields = $table->get_field_names(); $self->assert_equals('foo', $fields[0]); $self->assert_equals('bar', $fields[1]); $self->assert_equals('baz', $fields[2]); $self->assert_equals('foo', $table->get_pk_name()); } sub test_link_table { my ($self) = @_; my $table = new PROP::Schema('LinkFooToBiz'); $self->assert_equals('LinkFooToBiz', $table->get_table_name()); my @fields = $table->get_field_names(); $self->assert_equals('foo_id', $fields[0]); $self->assert_equals('biz_id', $fields[1]); $self->assert_equals('c1', $fields[2]); $self->assert_equals('c2', $fields[3]); $self->assert_equals('c3', $fields[4]); $self->assert_equals('foo_id', $table->get_pk_name()->[0]); $self->assert_equals('biz_id', $table->get_pk_name()->[1]); } 1; =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/Object/0040755000076400007640000000000010110143432014505 5ustar awgibbsawgibbsPROP-0.1/lib/PROP/Object/MySQL.pm0100644000076400007640000000207110110143402016002 0ustar awgibbsawgibbspackage PROP::Object::MySQL; use strict; use base qw/PROP::Object/; use DBI; use PROP::Object; use Carp; sub extract_insert_id { my ($self, $sth) = @_; return $sth->{mysql_insertid}; } 1; =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/SQL.pm0100644000076400007640000001200610110143402014265 0ustar awgibbsawgibbspackage PROP::SQL; use Hash::Util qw/lock_keys/; use PROP::Constants; sub new { my ($invocant) = @_; my $class = ref($invocant) || $invocant; my $self = {}; bless($self, $class); $self->{-fields} = []; $self->{-tables} = []; $self->{-conditions} = []; $self->{-orderings} = []; $self->{-limit} = undef; $self->{-distinct} = 0; lock_keys(%$self) if DEBUG; return $self; } sub add_table { my ($self, $table) = @_; push(@{$self->{-tables}}, $table); } sub push_field { my ($self, $field) = @_; push(@{$self->{-fields}}, $field); } sub unshift_field { my ($self, $field) = @_; unshift(@{$self->{-fields}}, $field); } sub push_conditional_expression { my ($self, $condition) = @_; push(@{$self->{-conditions}}, $condition); } sub push_ordering { my ($self, $ordering) = @_; push(@{$self->{-orderings}}, $ordering); } sub unshift_ordering { my ($self, $ordering) = @_; unshift(@{$self->{-orderings}}, $ordering); } sub set_limit { my ($self, $limit) = @_; $self->{-limit} = $limit; } sub set_distinct { my ($self) = @_; $self->{-distinct} = 1; } 1; =head1 Name PROP::SQL =head1 Description This class relieves the user from the burden of manually building up a SQL statement by providing methods that allow the addition of components of a query, and a stringify method that builds the statement string from all of the constituent components. The PROP::SQL class is actually an abstract class that should not be instantiated directly. Rather, create instances of PROP::SQL::* classes, e.g. PPO::SQL::Select. In fact, users will rarely have need of this class hierarchy at all. Mostly, it is used internal to other classes to do the work of manipulating objects and relationships. It is, however, available to users who wish to construct statements that do not have a nice analog within the object oriented framework. =head1 Synopsis $stmt = PROP::SQL::Select->new(); $stmt->add_table('Foo'); $stmt->push_field('foo'); $stmt->push_field('bar'); $stmt->push_conditional_expression('bar > ?'); $stmt->push_ordering('bar'); $stmt->set_limit(5000); # Where $dbh was obtained from DBI->connect(...) $sth = $dbh->prepare($stmt->stringify()); $sth->execute(3); =head1 Methods Note: some of these methods only make sense for certain types of statements. =over =item new $stmt = PROP::SQL::Select->new() This method is the base constructor for all subclasses of PROP::SQL, and as such is never called directly... Rather, this constructor is invoked via a subclass, as illustrated. =item stringify $stmt->stringify() This method builds and returns the statement string that results from all of the things specified in the query. =item add_table $stmt->add_table($name); This method adds a table by the name of $name to the statment. =item push_field $stmt->push_field($name) This method adds a field by the name of $name to the list of fields specified by the statement, adding it to the end of the list. =item unshift_field $stmt->unshift_field($name) This method adds a field by the name of $name to the list of fields specified by the statement, adding it to the beginning of the list. =item push_conditional_expression $stmt->push_conditional_expression($name) This method adds a condition by the name of $name to the list of conditions specified by the statement, adding it to the end of the list. =item push_ordering $stmt->push_ordering($name) This method adds a ordering by the name of $name to the list of orderings specified by the statement, adding it to the end of the list. =item unshift_ordering $stmt->unshift_ordering($name) This method adds a ordering by the name of $name to the list of orderings specified by the statement, adding it to the beginning of the list. =item set_limit $stmt->set_limit($value); This method sets the limit specified by the statement. =item set_distinct $stmt->set_distinct() Invocation of this method indicates that you are only intersted in the distinct results of this statement. This probably only makes sense in the context of a select statement, so maybe it ought to live in the Select subclass. =back =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/Conf/0040755000076400007640000000000010110143432014164 5ustar awgibbsawgibbsPROP-0.1/lib/PROP/Conf/MySQL.pm0100644000076400007640000000402210110143402015457 0ustar awgibbsawgibbspackage PROP::Conf::MySQL; use strict; use base qw/PROP::Conf/; use IO::File; sub _read_configuration { my ($self, $cnxn_conf) = @_; my $should_close = 0; unless(ref($cnxn_conf)) { unless($cnxn_conf = new IO::File($cnxn_conf)) { my $msg = "could not open $cnxn_conf"; die new PROP::Exception($msg); } $should_close = 1; } $self->_parse_file($cnxn_conf); if($should_close) { unless($cnxn_conf->close()) { my $msg = "could not close file: $!"; die new PROP::Exception($msg); } } } sub _parse_file { my ($self, $file) = @_; my $current_section = ''; while(<$file>) { chomp; if(/^\s*\[(.+)\]\s*$/) { $current_section = $1; } elsif(/^\s*(\S+)\s*=\s*(\S+)\s*$/) { $self->_set_param($1, $2) if $current_section eq 'client'; } } } sub get_dbd_name { return 'mysql'; } 1; =head1 Name PROP::Conf::MySQL =head1 Description This class is a subclass for PROP::Conf, and designed to parse configuration information for the MySQL RDBMS. Presently, it allows the $cnxn_conf variable passed into _read_configuration to be a path to a .my.cnf file that specifies all of the connection parameters. =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/Conf/MySQLTest.pm0100644000076400007640000000557410110143402016334 0ustar awgibbsawgibbspackage PROP::Conf::MySQLTest; use strict; use base qw/Test::Unit::TestCase/; use IO::Pipe; use PROP::Conf::MySQL; sub new { my ($invocant, @args) = @_; my $self = $invocant->SUPER::new(@args); return $self; } sub set_up { my ($self) = @_; my $reader = new IO::Handle; my $writer = new IO::Handle; pipe($reader, $writer); $self->set_read_handle($reader); $self->set_write_handle($writer); $self->fill_pipe(); close($writer); } sub tear_down { my ($self) = @_; close($self->get_read_handle()); } sub get_read_handle { my ($self) = @_; return $self->{-read_handle}; } sub set_read_handle { my ($self, $read_handle) = @_; $self->{-read_handle} = $read_handle; } sub get_write_handle { my ($self) = @_; return $self->{-write_handle}; } sub set_write_handle { my ($self, $write_handle) = @_; $self->{-write_handle} = $write_handle; } sub fill_pipe { my ($self) = @_; my $writer = $self->get_write_handle(); print $writer "[mysqld]\n"; print $writer "datadir=/var/lib/mysql\n"; print $writer "socket=/var/lib/mysql/mysql.sock\n"; print $writer "[client]\n"; print $writer "user = jsmith\n"; print $writer "password = f00b4r\n"; print $writer "host = localhost\n"; print $writer "port = 3306\n"; print $writer "database = test\n"; print $writer "[mysql.server]\n"; print $writer "user=mysql\n"; print $writer "basedir=/var/lib\n"; print $writer "[safe_mysqld]\n"; print $writer "err-log=/var/log/mysqld.log\n"; print $writer "pid-file=/var/run/mysqld/mysqld.pid\n"; } sub test_params { my ($self) = @_; my $reader = $self->get_read_handle(); my $conf = new PROP::Conf('MySQL', $reader); $self->assert_equals('jsmith', $conf->get_user()); $self->assert_equals('f00b4r', $conf->get_password()); $self->assert_equals('localhost', $conf->get_host()); $self->assert_equals(3306, $conf->get_port()); $self->assert_equals('test', $conf->get_database()); } 1; =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/Conf/TestSuite.pm0100644000076400007640000000200210110143402016437 0ustar awgibbsawgibbspackage PROP::Conf::TestSuite; use strict; use base qw/Test::Unit::TestSuite/; sub include_tests { return ('PROP::Conf::MySQLTest'); } 1; =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/Link.pm0100644000076400007640000002140510111453337014542 0ustar awgibbsawgibbspackage PROP::Link; use strict; use Carp; use PROP::Schema; use PROP::Constants; use PROP::SQL::Select; use PROP::SQL::Insert; use PROP::SQL::Update; use PROP::SQL::Delete; use PROP::ResultSet::Link; use PROP::Exception; use PROP::Exception::Configuration; use Hash::Util qw/lock_hash/; sub new { my ($invocant, $table_name, $parent_class, $child_class) = @_; my $class = ref($invocant) || $invocant; my $self = bless({}, $class); $self->{-table_name} = $table_name; $self->{-parent_class} = $parent_class; $self->{-child_class} = $child_class; $self->{-table} = new PROP::Schema($table_name); my $pk = $self->{-table}->get_pk_name(); unless(ref($pk) eq 'ARRAY' and scalar(@$pk) == 2) { my $msg = "link table $table_name does not have a properly configured" . " primary key (it must be a dual primary key, for a parent id" . " and child id)"; die new PROP::Exception::Configuration($msg); } lock_hash(%$self) if DEBUG; return $self; } sub get_table_name { my ($self) = @_; return $self->{-table_name}; } sub get_parent_table_name { my ($self) = @_; return $self->get_parent_class()->get_table_name(); } sub get_child_table_name { my ($self) = @_; return $self->get_child_class()->get_table_name(); } sub get_parent_class { my ($self) = @_; return $self->{-parent_class}; } sub get_child_class { my ($self) = @_; return $self->{-child_class}; } sub get_parent_field_name { my ($self) = @_; return $self->get_schema()->get_pk_name()->[0]; } sub get_child_field_name { my ($self) = @_; return $self->get_schema()->get_pk_name()->[1]; } sub get_contextual_field_names { my ($self) = @_; my @fields = $self->get_schema()->get_field_names(); return unless scalar(@fields) > 2; return @fields[2..$#fields]; } sub get_schema { my ($self) = @_; return $self->{-table}; } sub insert { my ($self, $parent, $child, $contextual_values) = @_; # allow passing as arguments either a primary key, or the object itself unless($parent =~ /^\d+$/) { die new PROP::Exception::IllegalArgument('parent cannot be undefined') unless($parent); die new PROP::Exception("parent's primary key is not set") unless $parent->get_pk_value(); $parent = $parent->get_pk_value(); } unless($child =~ /^\d+$/) { die new PROP::Exception::IllegalArgument('child cannot be undefined') unless($child); die new PROP::Exception("child's primary key is not set") unless $child->get_pk_value(); $child = $child->get_pk_value(); } my $stmt = new PROP::SQL::Insert; $stmt->add_table($self->{-table_name}); my @bindings = ($parent, $child); $stmt->push_field($self->get_parent_field_name()); $stmt->push_field($self->get_child_field_name()); foreach (keys(%$contextual_values)) { unless($self->get_schema()->has_field($_)) { my $msg = "unknown contextual field '$_' for link table " . $self->get_table_name(); die new PROP::Exception::IllegalArgument($msg); } $stmt->push_field($_); push(@bindings, $contextual_values->{$_}); } my $sth = PROP::DBH->get_handle()->prepare($stmt->stringify()); unless($sth->execute(@bindings)) { my $msg = "problem inserting into link table " . $self->{-table_name} . " with parent=" . $parent . " and child=" . $child; die new PROP::Exception($msg); } } sub update { my ($self, $parent, $child, $contextual_values) = @_; # allow passing as arguments either a primary key, or the object itself $parent = $parent->get_pk_value() unless $parent =~ /^\d+$/; $child = $child->get_pk_value() unless $child =~ /^\d+$/; my $stmt = new PROP::SQL::Update; $stmt->add_table($self->{-table_name}); my @bindings; foreach (keys(%$contextual_values)) { unless($self->get_schema()->has_field($_)) { my $msg = "unknown contextual field '$_' for link table " . $self->get_table_name(); die new PROP::Exception($msg); } $stmt->push_field($_); push(@bindings, $contextual_values->{$_}); } $stmt->push_conditional_expression($self->get_parent_field_name() . ' = ?'); $stmt->push_conditional_expression($self->get_child_field_name() . ' = ?'); push(@bindings, ($parent, $child)); my $sth = PROP::DBH->get_handle()->prepare($stmt->stringify()); $sth->execute(@bindings); } sub delete { my ($self, $parent, $child) = @_; # allow passing as arguments either a primary key, or the object itself $parent = $parent->get_pk_value() unless $parent =~ /^\d+$/; $child = $child->get_pk_value() unless $child =~ /^\d+$/; my $stmt = new PROP::SQL::Delete; $stmt->add_table($self->{-table_name}); $stmt->push_conditional_expression($self->get_parent_field_name() . ' = ?'); $stmt->push_conditional_expression($self->get_child_field_name() . ' = ?'); my $sth = PROP::DBH->get_handle()->prepare($stmt->stringify()); unless($sth->execute($parent, $child)) { my $msg = 'problem while removing link from ' . $self->{-table_name} . ' for ' . $self->get_parent_field_name() . '=' . $parent . ' and ' . $self->get_child_field_name() . '=' . $child; die new PROP::Exception($msg); } } 1; =head1 Name PROP::Link =head1 Description This class is an abstraction of a link table in a database that ties together pairs of objects, possibly with additional contextual information. Relationships can be inserted, updated, and deleted. =head1 Synopsis $l = PROP::Link->new($table_name, $parent_class, $child_class); =head1 Methods =over =item new $l = PROP::Link->new($table_name, $parent_class, $child_class); This method creates an instance of the class PROP::Link as follow: $table_name is the name of the link table; $parent_class is the name of the class that is represented by the parent field in the link table; $child_class is the name of the class that is represented by the child field in the link table. =item insert $l->insert($parent, $child, $contextual_values); This method inserts a relationship into the link table as follows: $parent is either the parent object or the ID thereof; $child is either the child object or the ID thereof; $contextual_values is a hash array reference containing a mapping of contextual field names to values. =item update $l->update($parent, $child, $contextual_values); This method is much the same as insert, except it operates on a pre-existing row. =item delete $l->delete($parent, $child); This method deletes a link in the link table as follows: $parent is either the parent object or the ID thereof; $child is either the child object or the ID thereof. =item get_table_name $l->get_table_name() This method returns the name of the link table. =item get_schema $l->get_schema() This method returns a PROP::Schema object that represents the underlying database table. =item get_parent_table_name $l->get_parent_table_name() This method returns the name of the table in which objects of the parent class are stored. =item get_child_table_name $l->get_child_table_name() This method returns the name of the table in which objects of the child class are stored. =item get_parent_class $l->get_parent_class() This method returns the name of the class for parental objects. =item get_child_class $l->get_child_class() This method returns the name of the class for child objects. =item get_parent_field_name $l->get_parent_field_name() This method returns the name of the parent field in the link table, which must be the first column. =item get_child_field_name $l->get_child_field_name() This method returns the name of the child field in the link table, which must be the second column. =item get_contextual_field_names $l->get_contextual_field_names() This method returns an array that contains the names of the contextual fields, in the order that they appear in the table, which must begin at the third column and run through the end of the table, if there are any. =back =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/Schema.pm0100644000076400007640000001025410110143402015031 0ustar awgibbsawgibbspackage PROP::Schema; use strict; use Hash::Util qw/lock_keys/; use PROP::Constants; use PROP::Schema::MySQL; use PROP::Conf; use PROP::DBH; use PROP::Exception::Configuration; sub new { my ($invocant, $table_name) = @_; my $self = bless({}, 'PROP::Schema::' . get_rdbms()); $self->{-table_name} = $table_name; $self->{-pk_name} = undef; $self->{-fields} = []; $self->{-field_hash} = {}; lock_keys(%$self) if DEBUG; eval { $self->_query_schema(); }; die if $@; return $self; } sub _query_schema { my ($self) = @_; my $class = ref($self); my $msg = "class '$class' did not define a _query_schema method"; die new PROP::Exception::Configuration($msg); } sub _add_field { my ($self, $field) = @_; push(@{$self->{-fields}}, $field); $self->{-field_hash}{$field->get_name()} = $field; $self->_add_pk($field->get_name()) if $field->is_pk(); } sub _add_pk { my ($self, $name) = @_; my $pk = $self->{-pk_name}; if($pk) { if(ref($pk)) { push(@$pk, $name); } else { $self->{-pk_name} = [$pk, $name]; } } else { $self->{-pk_name} = $name; } } sub get_table_name { my ($self) = @_; return $self->{-table_name}; } sub get_pk_name { my ($self) = @_; # make a defensive copy if the pk is an array return ref($self->{-pk_name}) ? [@{$self->{-pk_name}}] : $self->{-pk_name}; } sub get_field_names { my ($self) = @_; return map { $_->get_name() } @{$self->{-fields}}; } sub has_field { my ($self, $field_name) = @_; return $self->{-field_hash}{$field_name} ? 1 : 0; } package PROP::Schema::Field; use strict; use PROP::Constants; use Hash::Util qw/lock_keys/; sub new { my ($invocant, $name, $is_pk) = @_; my $self = bless({}, ref($invocant) || $invocant); $self->{-name} = $name; $self->{-is_pk} = $is_pk; lock_keys(%$self) if DEBUG; return $self; } sub get_name { my ($self) = @_; return $self->{-name}; } sub is_pk { my ($self) = @_; return $self->{-is_pk}; } 1; =head1 Name PROP::Schema =head1 Description This class houses information about the schema of a database table. Given the name of a table, passed to its constructor, it automatically populates itself with this information. =head1 Synopsis $schema = new PROP::Schema('MyTable'); print "MyTable's primary key field is ", $schema->get_pk_name(), "\n"; =head1 Methods =over =item new $schema = new PROP::Schema('MyTable'); This method constructs and returns a PROP::Schema object. The actual table structure is pulled automatically from the underlying database. =item get_table_name $schema->get_table_name(); This method returns the name of the table. =item get_pk_name $schema->get_pk_name() This method returns a scalar value that is either a string that contains the name of the primary key, or an array reference that holds two or more string values, each of which contains a name of a field that makes up a multi-field primary key. =item get_field_names $schema->get_field_names() This method returns an array that holds the names of the fields of this table, in the order in which they appear in the table. =item has_field $schema->has_field($field_name) This method returns a boolean value, indicating whether the table in question has a field by the name of $field_name. =back =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/ExceptionTest.pm0100644000076400007640000000362510110143402016433 0ustar awgibbsawgibbspackage PROP::ExceptionTest; use strict; use base qw/Test::Unit::TestCase/; use PROP::Exception; sub new { my ($invocant, @args) = @_; my $self = $invocant->SUPER::new(@args); return $self; } sub set_up { my ($self) = @_; } sub tear_down { my ($self) = @_; } sub test_exception_propagation { my ($self) = @_; eval { eval { eval { die new PROP::Exception("woe is I"); }; die $@->PROPAGATE("well, look what I caught"); }; die $@->PROPAGATE("and in turn I caught you"); }; # note that if you move this assert statement you will break it # $self->assert_str_equals("\nPROP::Exception" . # "\n" . # " ...woe is I in file " . # __FILE__ . " at line " . (__LINE__ - 11) . # "\n" . # " ...well, look what I caught in file " . # __FILE__ . " at line " . (__LINE__ - 12) . # "\n" . # " ...and in turn I caught you in file " . # __FILE__ . " at line " . (__LINE__ - 13) . # "\n", # $@->stringify()); } 1; =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/Exception.pm0100644000076400007640000002200110110143402015560 0ustar awgibbsawgibbspackage PROP::Exception; use strict; use overload ('""' => \&stringify); sub new { my ($class, $msg, $file, $line) = @_; my $self = bless({}, $class); $msg ||= 'Died'; unless($file and $line) { (undef, $file, $line) = caller(); } $self->{-msg} = format_text("...$msg in file $file at line $line", 80, 4); return $self; } sub throw { my ($self) = @_; die $self; } sub clone { my ($self) = @_; my $twin = bless({}, ref($self)); $twin->{-msg} = $self->{-msg}; return $twin; } sub PROPAGATE { my ($self, @args) = @_; my ($pkg, $file, $line, $msg); my $twin = $self->clone(); if(scalar(@args) == 1) { $msg = $args[0]; ($pkg, $file, $line) = caller(); } elsif(scalar(@args) == 2) { $msg = 'propagated'; ($file, $line) = @args; } else { ($pkg, $file, $line) = caller(); die "inappropriate args given to PROPAGATE at $file $line"; } $twin->{-msg} .= "\n" . format_text("...$msg in file $file at line $line", 80, 4); return $twin; } sub format_text { my ($input, $max_length, $indent) = @_; my $line_length = $indent; my $output = ' ' x $indent; my @chunks = split /(\s+)/, $input; while(@chunks) { my $chunk = shift(@chunks); if($line_length == 0 or $line_length + length($chunk) < $max_length) { $line_length += length($chunk); $output .= $chunk; } else { unless($chunk =~ /^\s+$/) { $output .= "\n" . (' ' x $indent); $line_length = length($chunk) + $indent; $output .= $chunk; } } } return $output; } sub stringify { my ($self) = @_; my ($pkg, $file, $line) = caller(); return "\n" . ref($self) . "\n" . $self->{-msg} . "\n"; } 1; =head1 Name PROP::Exception =head1 Description PROP::Exception is the base class of all exceptions thrown within the PROP framework. It may itself be thrown, or it may be subclassed to provide for different types of exceptions. Among other things (OK, there aren't really other things), this class provides for elegant propagation of exceptions and clean formatting of the resultant trace. =head1 Synopsis foo(); sub foo { eval { bar(); }; die $@->PROPAGATE("and in turn foo fell") if $@; } sub bar { eval { baz(); }; die if $@; } sub baz { die new PROP::Exception("baz is dead! long live baz!"); } __END__ PROP::Exception ...baz is dead! long live baz! in file ./foo.pl at line 26 ...propagated in file ./foo.pl at line 22 ...and in turn foo fell in file ./foo.pl at line 14 =head1 Usage When in the course of execution your application runs up against an exceptional condition, an exception of some sort should the thrown. This entails nothing more than constructing a new exception object and invoking die with it as the sole argument. The exception object may be constructed with a string argument, and it is recommended that this string contain contextual information that will help either a human or a program at a higher context ascertain what went wrong. Not only might you find need for initiating an exception, but you may also find yourself in the position of trapping an exception and wishing to propagate it to a higher level, perhaps first adding some contextual information to it. If you wish merely to propagate the exception, simply invoke die without any argument, and the exception object will auto-magically have propagation information embedded in it, including the file name and line number from whence you propagated it. If, instead, you desire to embed some kind of additional contextual information, then invoke with the return value of an invocation of the exceptions PROPGATE method, passing a string into it, for example... die $@->PROPAGATE("we got hosed when x was equal to $x") if $@; Now, eventually the exception might percolate up to a level at which it is uncaught, in which case Perl will convert the exception to a string value, print it, and then terminate. You will first see a line that tells you that there was an exception and what type it was. Underneath this you will see one or more lines, each indented with a tab, and each of which contains a the message from the corresponding propagation step. With this information you will hopefully be able to ascertain what went wrong with your program with much greater ease than had your program bottomed out and died without a hierarchy of contextual information. Of course, you might be able to handle an exception at some level, averting program termination and allowing for continued execution. In this case, you might want to continue on silently as if nothing had happened, or you might want to print the exception either to a console or a log file. The same message that you see for an uncaught exception may be obtained by invoking the exception object's stringify method, for example... print "we averted the following disaster...\n", $@->stringify(); It is conceivable that in a given situation you might receive notification of one of several different types of exceptions (because you might have created a bunch of different ones by subclassing PROP::Exception). In this case, you will want to figure out which type it was and act appropriately. For example... if($@) { if(ref($@) eq 'MyTolerableException') { # handle it and bravely soldier on } elsif(ref($@) eq 'MyIntolerableException') { # propagate with some useful context info die $@->PROPAGATE("we got hosed when x was equal to $x"); } else { # don't even know what kind of exception this is... die; } } In the first case, you caught a recognizable exception from which you can recover. In the second case you caught a recognizable exception from which you cannot recover, and so you propagate it with some useful information, in hopes that a higher context will be able to deal with it, or at least glean some valuable information from the failure. In the last case, you caught an exception that you don't even recognize, so you just blindly propagate it, letting the no argument form of die do its magic. =head1 Methods =over =item new die new PROP::Exception(); die new PROP::Exception($message); die new PROP::Exception($message, $file, $line); The "new" method constructs an exception object, and Perl's built-in "die" method throws it. Three forms of the constructor are available. The no arguments form defaults the message to "Died", and the file and line to the point at which the exception object was created. The one argument form defaults the file and line to the point at which the exception object was created, allowing you to specify the message yourself. The three argument form allows you to fully specify the exception yourself, which is useful if you wish to have the error appear from the perspective of somewhere other than the point where the exception object was created (for example, the subclass PROP::Exception::IllegalArgument specifies the file and line to be the point at which the subroutine that threw the exception was invoked, aiding a developer in the quest to find the location of the invalid subroutine invocation). =item PROPAGATE die $@->PROPAGATE($message); die $@->PROPAGATE($file, $line); The PROPAGATE method is used when you have caught an exception and wish to throw it up to a higher level for further processing. The one argument form is used when you wish to include some additional information in the exception, filling in file and line information automatically from the point at which the exception was propagated. The two argument form really only exists to allow proper functioning of the "magical" zero argument form of Perl's built-in "die" which translates to die $@->PROPAGATE(__FILE__, __LINE); =item stringify This method returns a pleasantly formatted string version of the exception. The format is as follow... On the first line and flush to the left is the name of the exception class. On subsequent lines and indented by four spaces is information about the exception. Each level of propagation starts with an ellipsis and may span multiple lines, as lines are wrapped to avoid extending past eighty characters, since exceeding the width of a terminal can make reading error messages an eye-blurring experience. =back =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/TestSuite.pm0100644000076400007640000000230510110143402015560 0ustar awgibbsawgibbspackage PROP::TestSuite; use strict; use base qw/Test::Unit::TestSuite/; sub include_tests { return ('PROP::ObjectTest', 'PROP::LinkTest', 'PROP::SchemaTest', 'PROP::SQL::TestSuite', 'PROP::Conf::TestSuite', 'PROP::ResultSet::TestSuite', 'PROP::Conditions::TestSuite', 'PROP::ExceptionTest'); } 1; =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/Link/0040755000076400007640000000000010106175575014216 5ustar awgibbsawgibbsPROP-0.1/lib/PROP/LinkTest.pm0100644000076400007640000001210310110143402015361 0ustar awgibbsawgibbspackage PROP::LinkTest; use strict; use base qw/Test::Unit::TestCase/; use Data::Dumper; use PROP::DBH; use PROP::Util; use PROP::Link; use PROP::TestCommon; use PROP::Query::Link; sub new { my ($invocant, @args) = @_; my $self = $invocant->SUPER::new(@args); return $self; } sub set_up { my ($self) = @_; drop_tables(); create_tables(); } sub tear_down { my ($self) = @_; drop_tables(); } sub test_attributes { my ($self) = @_; my $links = create_links(); $self->assert_equals('LinkFooToBiz', $links->[0]->get_table_name()); $self->assert_equals('Dummy::Foo', $links->[0]->get_parent_class()); $self->assert_equals('Dummy::Biz', $links->[0]->get_child_class()); $self->assert_equals('Foo', $links->[0]->get_parent_table_name()); $self->assert_equals('Biz', $links->[0]->get_child_table_name()); $self->assert_equals('foo_id', $links->[0]->get_parent_field_name()); $self->assert_equals('biz_id', $links->[0]->get_child_field_name()); my @contextual_fields = $links->[0]->get_contextual_field_names(); $self->assert_equals($contextual_fields[$_ - 1], 'c' . $_) foreach (1..3); } sub test_update { my ($self) = @_; my ($f, $b, $fz, $links) = populate_database(); # NEW my $fc = new PROP::Conditions::Foreign($links->[0], 'children', ['l.foo_id = ?', 'l.biz_id = ?'], [2, 3]); my $query = new PROP::Query::Link($fc); # my $conditions = # new PROP::Conditions::Local(['l.foo_id = ?', 'l.biz_id = ?'], [2, 3]); # # my $query = new PROP::Query::Link($links->[0], 'children', $conditions); my $rs = new PROP::ResultSet::Link($query); my $results = $rs->get_all_results(); my $obj = $results->[0]->get_relatives()->[0]; $self->assert_equals(3, $obj->get_pk_value()); $self->assert_equals(1, $obj->get_contextual_value('c1')); $self->assert_equals(2, $obj->get_contextual_value('c2')); $links->[0]->update(2, 3, { c1 => 5, c2 => 7}); $rs = new PROP::ResultSet::Link($query); $results = $rs->get_all_results(); $obj = $results->[0]->get_relatives()->[0]; $self->assert_equals(3, $obj->get_pk_value()); $self->assert_equals(5, $obj->get_contextual_value('c1')); $self->assert_equals(7, $obj->get_contextual_value('c2')); } sub test_delete { my ($self) = @_; my ($f, $b, $fz, $links) = populate_database(); # NEW my $fc = new PROP::Conditions::Foreign($links->[0], 'children', ['l.foo_id in (?, ?)', 'l.biz_id in (?, ?)'], [$f->[0]->get_pk_value(), $f->[2]->get_pk_value(), $b->[0]->get_pk_value(), $b->[1]->get_pk_value()]); my $query = new PROP::Query::Link($fc, ['l.biz_id']); # my $conditions = # new PROP::Conditions::Local(['l.foo_id in (?, ?)', # 'l.biz_id in (?, ?)'], # [$f->[0]->get_pk_value(), # $f->[2]->get_pk_value(), # $b->[0]->get_pk_value(), # $b->[1]->get_pk_value()]); # my $query = new PROP::Query::Link($links->[0], 'children', $conditions, ['l.biz_id']); my $results = new PROP::ResultSet::Link($query)->get_all_results(); $self->assert_equals(2, scalar(@$results)); $self->assert_equals($f->[0]->get_pk_value(), $results->[0]->get_pk_value()); $self->assert_equals($b->[0]->get_pk_value(), $results->[0]->get_relatives()->[0]->get_pk_value()); $self->assert_equals($b->[1]->get_pk_value(), $results->[0]->get_relatives()->[1]->get_pk_value()); $self->assert_equals($f->[2]->get_pk_value(), $results->[1]->get_pk_value()); $self->assert_equals($b->[0]->get_pk_value(), $results->[1]->get_relatives()->[0]->get_pk_value()); $self->assert_equals($b->[1]->get_pk_value(), $results->[1]->get_relatives()->[1]->get_pk_value()); $links->[0]->delete($f->[0], $b->[0]); $links->[0]->delete($f->[2], $b->[0]); $links->[0]->delete($f->[0], $b->[1]); $results = new PROP::ResultSet::Link($query)->get_all_results(); $self->assert_equals(1, scalar(@$results)); $self->assert_equals(1, scalar(@{$results->[0]->get_relatives()})); $self->assert_equals($f->[2]->get_pk_value(), $results->[0]->get_pk_value()); $self->assert_equals($b->[1]->get_pk_value(), $results->[0]->get_relatives()->[0]->get_pk_value()); } 1; =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/UtilTest.pm0100664000076400007640000000220710110143402015407 0ustar awgibbsawgibbspackage PROP::UtilTest; use strict; use base qw/Test::Unit::TestCase/; use PROP::Util; sub new { my ($invocant, @args) = @_; my $self = $invocant->SUPER::new(@args); return $self; } sub set_up { my ($self) = @_; } sub tear_down { my ($self) = @_; } 1; =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/Constants.pm0100644000076400007640000000336310110143402015610 0ustar awgibbsawgibbspackage PROP::Constants; use strict; use base qw/Exporter/; our @EXPORT = qw/DEBUG LIMIT/; use constant DEBUG => 1; use constant LIMIT => 5000; 1; =head1 Name PROP::Constants =head1 Description This class holds various and sundry constants that are common to the entire SQL framework. =head1 Constants =over =item DEBUG This constant specifies whether various debugging mechanisms are active. This mechanisms greatly aid in the debugging of programming defects, but impose a run-time penalty. As such, it should be enabled in the development environment, but disabled in the production environment and ddata_sourceng benchmarking. =item LIMIT This constant specifies the default number of rows on which a SQL select statement will operate at a time. It will not affect the ultimate algorithmic behavior of the program, but it can greatly affect run time and resource usage. =back =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/Object.pm0100644000076400007640000004470210111136325015053 0ustar awgibbsawgibbspackage PROP::Object; use strict; no strict "refs"; use vars qw/$AUTOLOAD/; use UNIVERSAL qw/isa/; use DBI; use Hash::Util qw/lock_hash lock_keys/; use Data::Dumper; use PROP::Schema; use PROP::SQL::Insert; use PROP::SQL::Update; use PROP::SQL::Select; use PROP::SQL::Delete; use PROP::Constants; use PROP::ResultSet::Link; use PROP::ResultSet::Object; use PROP::Conf; use PROP::Exception; use PROP::Exception::IllegalArgument; use PROP::Exception::Configuration; use PROP::Object::MySQL; my %schemas = (); my %verifiers = (); sub new { my ($invocant, $specifier) = @_; my $class = ref($invocant) || $invocant; my $self = bless({}, $class); my $ISA = $class . '::ISA'; for(my $i = 0; $i < scalar(@$ISA); ++$i) { if($ISA->[$i] eq 'PROP::Object') { $ISA->[$i] = 'PROP::Object::' . get_rdbms(); } } $self->{-field_values} = { map { ($_, undef) } $self->get_field_names() }; $self->{-contextual_values} = {}; $self->{-modified_fields} = {}; $self->{-parents} = {}; $self->{-children} = {}; $self->{-verifiers} = {}; lock_hash(%$self) if DEBUG; lock_keys(%{$self->{-field_values}}) if DEBUG; if($specifier) { if(ref($specifier) eq 'HASH') { foreach (keys(%$specifier)) { $self->{-field_values}{$_} = $specifier->{$_}; $self->{-modified_fields}{$_} = 1; } } elsif($specifier =~ m/^\d+$/) { $self->{-field_values}{$self->get_schema()->get_pk_name()} = $specifier; } else { die new PROP::Exception::IllegalArgument("invalid object specifier"); } $self->load(); } return $self; } sub add_field_verifier { my ($invocant, $field, $verifier) = @_; die new PROP::Exception::IllegalArgument('invalid invocant') if(ref($invocant) and not isa($invocant, 'PROP::Object')); die new PROP::Exception::IllegalArgument("unknown field '$field' specified") unless($invocant->get_schema()->has_field($field)); die new PROP::Exception::IllegalArgument("verifier must be a code reference") unless(ref($verifier) eq 'CODE'); if(ref($invocant)) { push(@{$invocant->{-verifiers}{$field}}, $verifier); } else { push(@{$verifiers{$field}}, $verifier); } } sub save { my ($self) = @_; my @modified_fields = keys(%{$self->{-modified_fields}}); return unless @modified_fields; if($self->get_pk_value() and not $self->{-modified_fields}{$self->get_pk_name()}) { my $stmt = new PROP::SQL::Update; $stmt->add_table($self->get_table_name()); $stmt->push_field($_) foreach (@modified_fields); $stmt->push_conditional_expression($self->get_pk_name() . ' = ?'); eval { my $sth = PROP::DBH->get_handle()->prepare($stmt->stringify()); $sth->execute((map { $self->get_field_value($_) } @modified_fields), $self->get_pk_value()); }; if($@) { my $class = ref($self); my $pk = $self->get_pk_value(); die new PROP::Exception("update for $class with primary key $pk failed: $@"); } } else { my $stmt = new PROP::SQL::Insert; $stmt->add_table($self->get_table_name()); $stmt->push_field($_) foreach (@modified_fields); my $sth = PROP::DBH->get_handle()->prepare($stmt->stringify()); unless($sth->execute(map { $self->get_field_value($_) } @modified_fields)) { my $class = ref($self); die new PROP::Exception("insert for class $class failed"); } if(not $self->{-modified_fields}{$self->get_pk_name()}) { $self->{-field_values}{$self->get_schema()->get_pk_name()} = $self->extract_insert_id($sth); } } $self->_clear_modification_flags(); return $self->get_pk_value(); } sub load_relatives { my ($self, $link_queries) = @_; unless(ref($link_queries) eq 'ARRAY' and not grep { not ref($_) eq 'PROP::Query::Link' } @$link_queries) { my $msg = 'was expecting a reference to an array of PROP::Query::Link objects'; die new PROP::Exception::IllegalArgument($msg); } foreach my $lq (@$link_queries) { $lq->push_binding($self->get_pk_value()); if($lq->get_relationship() eq 'parents') { $lq->push_conditional_expression('c.' . $self->get_pk_name() . ' = ?'); my $result_set = new PROP::ResultSet::Link($lq); while(my $result = $result_set->get_next_result()) { foreach my $parent (@{$result->get_relatives()}) { $self->_add_parent($lq->get_link()->get_table_name(), $parent); } } } elsif($lq->get_relationship() eq 'children') { $lq->push_conditional_expression('p.' . $self->get_pk_name() . ' = ?'); my $result_set = new PROP::ResultSet::Link($lq); while(my $result = $result_set->get_next_result()) { foreach my $child (@{$result->get_relatives()}) { $self->_add_child($lq->get_link(), $child); } } } else { my $msg = "unexpected relationship type '" . $lq->get_relationship() . "' for link " . $lq->get_link()->get_table_name();; die new PROP::Exception($msg); } } } # get the name of the table associated with the derived class # (the derived class should provide this method) sub get_table_name { my ($invocant) = @_; my $class = ref($invocant) || $invocant; my $msg = "class '$class' did not define a get_table_name method"; die new PROP::Exception::Configuration($msg); } # get the PROP::Schema object associated with this class sub get_schema { my ($invocant) = @_; my $class = ref($invocant) || $invocant; $schemas{$class} = new PROP::Schema($class->get_table_name()) unless $schemas{$class}; return $schemas{$class}; } # get the name of the primary key for the derived class sub get_pk_name { my ($self) = @_; return $self->get_schema()->get_pk_name(); } # get the names of the fields of the table associated with the derived # class, in the order that they appear as columns in the table sub get_field_names { my ($self) = @_; return $self->get_schema()->get_field_names(); } # get the value of the primary key for this object sub get_pk_value { my ($self) = @_; return $self->{-field_values}{$self->get_pk_name()}; } # called by user of API, in the rare case of wanting to set a pk # directly instead of letting the underlying database auto-increment one sub set_pk_value { my ($self, $value) = @_; unless($value =~ /d+/) { my $msg = "primary key must be an integer (value '$value' is unacceptable)"; die new PROP::Exception::IllegalArgument($msg); } $self->{-field_values}{$self->get_pk_name()} = $value; $self->{-modified_fields}{$self->get_pk_name()} = 1; } # get a particular field value sub get_field_value { my ($self, $field) = @_; if(DEBUG and not $self->get_schema()->has_field($field)) { my $msg = ref($self) . " has no field named '$field'"; die new PROP::Exception::IllegalArgument($msg); } return $self->{-field_values}{$field}; } # set a particular field to some new value sub set_field_value { my ($self, $field, $value) = @_; if(DEBUG and not $self->get_schema()->has_field($field)) { my $msg = ref($self) . " has no field named '$field'"; die new PROP::Exception::IllegalArgument($msg); } unless($self->verify_field_value($field, $value)) { my $msg = "invalid value '$value' specified for field '" . $field . "' for class " . ref($self); die new PROP::Exception::IllegalArgument($msg); } $self->{-field_values}{$field} = $value; $self->{-modified_fields}{$field} = 1; } sub verify_field_value { my ($self, $field, $value) = @_; foreach (@{$verifiers{$field}}, @{$self->{-verifiers}{$field}}) { return 0 unless &$_($value); } return 1; } sub _add_parent { my ($self, $link, $parent) = @_; unless(ref($link) eq 'PROP::Link') { my $msg = "first argument should have been a PROP::Link object"; die new PROP::Exception::IllegalArgument($msg); } unless(ref($parent) eq $link->get_parent_class()) { my $msg = "trying to add a parent of class '" . ref($parent) . "' when class '" . $link->get_parent_class() . "' is expected"; die new PROP::Exception::IllegalArgument($msg); } push(@{$self->{-parents}{$link->get_table_name()}}, $parent); } sub get_parents { my ($self, $link_table_name) = @_; my $parents = $self->{-parents}{$link_table_name}; return () unless $parents; return @$parents; } sub _add_child { my ($self, $link, $child) = @_; unless(ref($link) eq 'PROP::Link') { my $msg = "first argument should have been a PROP::Link object"; die new PROP::Exception::IllegalArgument($msg); } unless(ref($child) eq $link->get_child_class()) { my $msg = "trying to add a child of class '" . ref($child) . "' when class '" . $link->get_child_class() . "' is expected"; die new PROP::Exception::IllegalArgument($msg); } push(@{$self->{-children}{$link->get_table_name()}}, $child); } sub get_children { my ($self, $link_table_name) = @_; my $children = $self->{-children}{$link_table_name}; return () unless $children; return @$children; } # load an object from the database into a memory representation sub load { my ($self) = @_; my @field_names = $self->get_field_names(); my $stmt = new PROP::SQL::Select; $stmt->push_field($_) foreach (@field_names); $stmt->add_table($self->get_schema()->get_table_name()); my @values; foreach my $field (grep { $self->{-field_values}{$_} } keys(%{$self->{-field_values}})) { $stmt->push_conditional_expression($field . ' = ?'); push(@values, $self->get_field_value($field)); } my $sth = PROP::DBH::get_handle()->prepare($stmt->stringify()); $sth->execute(@values); my @row = $sth->fetchrow_array(); unless(@row) { if($self->get_pk_value()) { my $err_msg = 'could not query ' . ref($self) . ' with pk=' . $self->get_pk_value(); die new PROP::Exception($err_msg); } else { return; } } $self->{-field_values}{$_} = shift(@row) foreach (@field_names); @row = $sth->fetchrow_array(); die new PROP::Exception('object was not specified uniquely') if @row; $self->_clear_modification_flags(); } sub _clear_modification_flags { my ($self) = @_; foreach (keys(%{$self->{-modified_fields}})) { delete $self->{-modified_fields}{$_}; } } # for a memory representation of an object, remove its stored # representation in the database sub delete { my ($self) = @_; die new PROP::Exception("delete method invoked when primary key is unset") unless $self->get_pk_value(); my $stmt = new PROP::SQL::Delete; $stmt->add_table($self->get_table_name()); $stmt->push_conditional_expression($self->get_pk_name() . ' = ?'); eval { my $sth = PROP::DBH->get_handle()->prepare($stmt->stringify()); $sth->execute($self->get_pk_value()); }; if($@) { my $class = ref($self); my $pk = $self->get_pk_value(); die new PROP::Exception("deletion for $class with primary key $pk failed: $@"); } } sub get_contextual_value { my ($self, $field) = @_; return $self->{-contextual_values}{$field}; } sub _set_contextual_value { my ($self, $field, $value) = @_; $self->{-contextual_values}{$field} = $value; } sub has_field { my ($invocant, $field) = @_; my $class = ref($invocant) || $invocant; return $schemas{$class}->has_field($field) ? 1 : 0; } # autoload get and set methods for object attributes sub AUTOLOAD { my $sub = $AUTOLOAD; if($sub =~ /(.*)::(get|set)_(.*)/) { my ($class, $type, $field) = ($1, $2, $3); my $table = $schemas{$class}; if($table and $table->has_field($field)) { if($type eq 'get') { *$sub = sub { my ($self) = @_; return $self->get_field_value($field); } } else { *$sub = sub { my ($self, $value) = @_; return $self->set_field_value($field, $value); } } goto &$sub; } } die "can't autoload $sub" unless($sub =~ /::DESTROY$/); } 1; =head1 NAME PROP::Object =head1 Description This class is an abstraction of objects that are stored in the rows of database tables. It supports the ability to load single objects, as specified by a set of conditions, as well as to modify and delete them, and to load relatives of an object into memory as well. This class is not intended to be used directly. Rather, it should be subclassed, and the derived class should provide a get_table_name() method which simply returns the name of the table in the database that corresponds to the type of object being embodied by the subclass. =head1 Methods =over =item new $obj = new Foo() $obj = new Foo($specifier) This method creates an instance of object Foo, a derived class of PROP::Object, possibly loading its contents from the database if $specifier is passed to new. The variable $specifier is optional, depending on your intent, and can either be an integer that specifies a primary key, or it can be a hash reference that specifies a mapping of field values. If $specifier is a primary key and lookup from the database fails, then an exception will be thrown. If specifier is a hash reference and lookup fails, then this may be ascertained by subsequently calling the get_pk_value() method which will return an undefined value. If specifier matches more than one object, then an exception will be thrown. =item get_pk_name $obj->get_pk_name() This method returns the name of the primary key for the class of this object. =item get_field_names $obj->get_field_names() This method returns the list of field names for the class of this object, in the order that they appear in the underlying table. =item has_field $obj->has_field($field_name); This method returns a boolean value indicating whether this object has a field by the name of $field_name. =item get_pk_value $obj->get_pk_value() This method returns the value of the primary key for this instance of the class. =item set_pk_value $obj->set_pk_value() This method sets the value of the primary key for this instance of the class. You will almost never want to do this. Usually the primary key value is set via an automatic incrementation mechanism in the underlying database. The only time that this makes sense is if you are importing data from another database and you want to preserve keying information. =item get_field_value $obj->get_field_value($field) This method returns the value of the field named $field. =item set_field_value $obj->set_field_value($field, $value) This method sets the value of the field named $field to $value. Note that this does not result in an immediate update to the object's representation in the underlying database. For that to happen, you must invoke the save() method. =item get_contextual_value $obj->get_contextual_value($field) This method gets the value of the contextual field $field. Contextual values are assigned to objects that are loaded via a link as either a parent or child of some other object. =item add_field_verifier $class->add_field_verifier($field, $verifier); $obj->add_field_verifier($field, $verifier); This method may be invoked either with a class name or an object reference. The first argument is a name of a field, and the second is a code reference for a subroutine that takes a single argument and returns a boolean value. The code reference will be used as a call-back function, invoked every time the set_field_value method is invoked. Namely, set_field_value will pass the value that was passed to it into the code reference and check the return value, throwing an exception if execution of the code reference returns false, and allowing execution to continue if execution of the code reference returns true. This allows for an elegant way to automate parameter validation, and you may add as many verifiers as you like. If any of the verifiers return a false value, then despite what the other verifiers return, verification fails (failure of a verifier causes short-circuiting of the verification process). An important thing to note is that different behavior results from invoking this method with either a class name or an object reference. In the case of a class name, the verifier is added to the list of verifiers for all objects of this class. In the case of an object reference, the verifier will only be used to verify the field values for this particular object. The process of verification involves first checking that all of the class-wide verifiers pass, and if they do, then subsequently checking all of the object specific verifiers. =item save $obj->save() This method saves the in memory representation of an object to the database. An actual write to the database will only occur if any fields have been set via the set_field_values() method since the object was loaded or last saved. The primary key assigned to the object is returned as a convenience. =item delete $obj->delete() This method deletes the object from the database, as specified by its primary key, presuming that this object is in fact in the database. =item get_parents $obj->get_parents($link_table_name) This method returns a list of parent objects for this object from $link_table_name that have been loaded, either explicitly with the load_relatives method, or as part of a query of a collection of objects. =item get_children $obj->get_children($link_table_name) This method returns a list of child objects for this object from $link_table_name that have been loaded, either explicitly with the load_relatives method, or as part of a query of a collection of objects. =item get_table_name $obj->get_table_name() This method returns the name of the table associated with the subclass of which the invoking object is an instance. This method must be overridden by the subclass for things to work. =item get_schema $obj->get_schema() This method returns an instance of the class PROP::Schema that corresponds to the table specified by the get_table_name() method. This object is populated upon the first execution of the method by querying the database. =back =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/Conf.pm0100644000076400007640000001234610110143402014522 0ustar awgibbsawgibbspackage PROP::Conf; use strict; use base qw/Exporter/; no strict 'refs'; use vars qw/%rdbms/; our @EXPORT = qw/get_rdbms get_cnxn_conf set_rdbms set_cnxn_conf/; use PROP::Constants; use Hash::Util qw/lock_keys/; use PROP::Exception::Configuration; use PROP::Exception::IllegalArgument; use PROP::Conf::MySQL; my %param_names; my $rdbms = undef; my $cnxn_conf = undef; sub set_rdbms { $rdbms = $_[0]; } sub set_cnxn_conf { $cnxn_conf = $_[0]; } sub get_rdbms { return $rdbms || $ENV{'PROP_RDBMS'} or die new PROP::Exception::Configuration("RDBMS is unascertainable"); } sub get_cnxn_conf { return $cnxn_conf || $ENV{'PROP_CNXNCONF'} || die new PROP::Exception::Configuration('connection configuration is unascertainable'); } BEGIN { my @params = ('user', 'password', 'host', 'port', 'database'); %param_names = map { ($_, 1) } @params; foreach my $param (@params) { *{'get_' . $param} = sub { my ($self) = @_; return $self->get_param($param); }; } } sub new { my ($invocant, $rdbms, $cnxn_conf) = @_; unless($rdbms and $cnxn_conf) { $rdbms = get_rdbms(); $cnxn_conf = get_cnxn_conf(); } unless($rdbms) { my $msg = "PROP::Conf could not determine the RDBMS"; die new PROP::Exception::Configuration($msg); } unless($cnxn_conf) { my $msg = "PROP::Conf could not determine a uri for configuration data"; die new PROP::Exception::Configuration($msg); } my $subclass = 'PROP::Conf::' . $rdbms; my $self = bless({}, $subclass); $self->{-params} = {}; $self->_read_configuration($cnxn_conf); lock_keys(%$self) if DEBUG; return $self; } sub _read_configuration { my ($self, $cnxn_conf) = @_; my $class = ref($self); my $msg = "class '$class' should have provided a _read_configuration method"; die new PROP::Exception($msg); } sub get_dbd_name { my ($self) = @_; my $class = ref($self); my $msg = "class '$class' should have provided a get_dbd_name method"; die new DBI::NIST::Exception($msg); } sub get_param { my ($self, $name) = @_; unless($param_names{$name}) { my $msg = "unknown param '$name'"; die new PROP::Exception::IllegalArgument($msg); } return $self->{-params}{$name}; } sub _set_param { my ($self, $name, $value) = @_; unless($param_names{$name}) { my $msg = "unknown param '$name'"; die new PROP::Exception::IllegalArgument($msg); } $self->{-params}{$name} = $value; } 1; =head1 Name PROP::Conf =head1 Description The PROP::Conf class is an abstract base class for various subclasses, each of which acts as a configuration parser for a different RDBMS. The subclass is responsible for all actual parsing, and the base class provides the parsed information via the get_param method. When writing a PROP::Conf subclass, the subclass must provide the following methods: _read_configuration, get_dbd_name. The _read_configuration method must accept a single argument, from which configuration information can be drawn. The get_dbd_name method takes no argument and returns the name of the DBD driver to be used, e.g. 'mysql' in the case of the MySQL database. =head1 Methods =over =item new $conf = PROP::Conf::Foo->new($cnxn_conf); Presuming that PROP::Conf::Foo is a subclass of PPO::Conf, this method creates an instance of class PROP::Conf::Foo, and parses the configuration information specified by $cnxn_conf, extracting all of the configuration information that was available to be used later for establishing a database connection. A user is not, however, apt to ever directly instantiate or use a subclass of PROP::Conf. Rather, one will be created behind the scenes by the PROP::DBH class when a handle is requested. =item get_param $conf->get_param($name); This method returns the value of the parameter specified by $name. As additional syntactic sugar, the following methods are also provided: get_user, get_password, get_host, get_port, get_database. =item set_rdbms PROP::Conf::set_rdbms($rdbms); This static method is used to indicate which RDBMS is to be used, and consequently dictates which subclass of PROP::Conf that PPO::DBH will instantiate. =item set_cnxn_conf PROP::Conf::set_cnxn_conf($cnxn_conf); This static method is used to indicate from where connection configuration information will be drawn. It can be anything that the subclass that corresponds to the argument passed to set_rdbms will accept. =back =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/DBH.pm0100644000076400007640000000411710110143402014227 0ustar awgibbsawgibbspackage PROP::DBH; use strict; use DBI; use PROP::Conf; my $dbh = undef; sub init_handle { my $conf = new PROP::Conf(); my $source = join(':', grep { defined $_ } ('dbi', $conf->get_dbd_name(), $conf->get_database(), $conf->get_host(), $conf->get_port())); unless($dbh = DBI->connect($source, $conf->get_user(), $conf->get_password())) { my $msg = "could not connect to source '$source': $!"; die new PROP::Exception($msg); } } sub get_handle { init_handle() unless $dbh; return $dbh; } 1; =head1 Name PROP::DBH =head1 Description This is a class for obtaining database handles. There exists just a single static method, get_handle. =head1 Methods =over =item get_handle $dbh = PROP::DBH::get_handle(); This method creates and returns a handle to a database as opened by DBI->connect(...). If a call to get_handle is made before information about how to construct a handle has been specified, then a PROP::Exception::Configuration exception will be thrown. This information can either be drawn from the environment variables PROP_RDBMS and PPO_CNXNCONF, or can be set explicitly by invocations of static methods that live within PROP::Conf. =back =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/SQL/0040755000076400007640000000000010110143432013736 5ustar awgibbsawgibbsPROP-0.1/lib/PROP/SQL/UpdateTest.pm0100644000076400007640000000375410110143402016361 0ustar awgibbsawgibbspackage PROP::SQL::UpdateTest; use strict; use base qw/Test::Unit::TestCase/; use PROP::SQL::Update; sub new { my ($invocant, @args) = @_; my $self = $invocant->SUPER::new(@args); $self->set_statement(new PROP::SQL::Update); return $self; } sub get_statement { my ($self) = @_; return $self->{-statement}; } sub set_statement { my ($self, $statement) = @_; $self->{-statement} = $statement; } sub test_simple { my ($self) = @_; my $stmt = $self->get_statement(); $stmt->add_table('foo'); $stmt->push_field('bar'); $self->assert_equals($stmt->stringify(), 'update foo set bar = ?'); } sub test_complex { my ($self) = @_; my $stmt = $self->get_statement(); $stmt->add_table('biz'); $stmt->push_field('fee'); $stmt->push_field('fie'); $stmt->push_field('foe'); $stmt->push_field('fum'); $stmt->push_conditional_expression('biz.fee > ?'); $stmt->push_conditional_expression('biz.fie < ?'); $self->assert_equals($stmt->stringify(), 'update biz set fee = ?, fie = ?, foe = ?, fum = ? ' . 'where biz.fee > ? and biz.fie < ?'); } 1; =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/SQL/Select.pm0100644000076400007640000000312610110143402015507 0ustar awgibbsawgibbspackage PROP::SQL::Select; use strict; use base qw/PROP::SQL/; sub stringify { my ($self) = @_; my $statement = 'select '; $statement .= ' distinct ' if $self->{-distinct}; $statement .= join(', ', @{$self->{-fields}}); $statement .= ' from '; $statement .= join(', ', @{$self->{-tables}}); $statement .= ' where ' . join(' and ', @{$self->{-conditions}}) if scalar(@{$self->{-conditions}}); $statement .= ' order by ' . join(', ', @{$self->{-orderings}}) if scalar(@{$self->{-orderings}}); if($self->{-limit}) { my $limit = $self->{-limit}; $limit = join(',', @{$self->{-limit}}) if ref($self->{-limit}) eq 'ARRAY'; $statement .= " limit $limit"; } return $statement; } 1; =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/SQL/DeleteTest.pm0100644000076400007640000000341610110143402016334 0ustar awgibbsawgibbspackage PROP::SQL::DeleteTest; use strict; use base qw/Test::Unit::TestCase/; use PROP::SQL::Delete; sub new { my ($invocant, @args) = @_; my $self = $invocant->SUPER::new(@args); $self->set_statement(new PROP::SQL::Delete); return $self; } sub get_statement { my ($self) = @_; return $self->{-statement}; } sub set_statement { my ($self, $statement) = @_; $self->{-statement} = $statement; } sub test_simple { my ($self) = @_; my $stmt = $self->get_statement(); $stmt->add_table('foo'); $self->assert_equals($stmt->stringify(), 'delete from foo'); } sub test_complex { my ($self) = @_; my $stmt = $self->get_statement(); $stmt->add_table('biz'); $stmt->push_conditional_expression('fee = ?'); $stmt->push_conditional_expression('foo < ?'); $self->assert_equals($stmt->stringify(), 'delete from biz where fee = ? and foo < ?'); } 1; =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/SQL/Insert.pm0100644000076400007640000000247610110143402015543 0ustar awgibbsawgibbspackage PROP::SQL::Insert; use strict; use base qw/PROP::SQL/; sub stringify { my ($self) = @_; my $statement = 'insert into '; $statement .= $self->{-tables}->[0]; $statement .= ' ('; $statement .= join(', ', @{$self->{-fields}}); $statement .= ') values ('; $statement .= '?, ' x scalar(@{$self->{-fields}}); $statement = substr($statement, 0, length($statement) - 2); $statement .= ')'; return $statement; } 1; =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/SQL/InsertTest.pm0100644000076400007640000000355410110143402016401 0ustar awgibbsawgibbspackage PROP::SQL::InsertTest; use strict; use base qw/Test::Unit::TestCase/; use PROP::SQL::Insert; sub new { my ($invocant, @args) = @_; my $self = $invocant->SUPER::new(@args); $self->set_statement(new PROP::SQL::Insert); return $self; } sub get_statement { my ($self) = @_; return $self->{-statement}; } sub set_statement { my ($self, $statement) = @_; $self->{-statement} = $statement; } sub test_simple { my ($self) = @_; my $stmt = $self->get_statement(); $stmt->add_table('foo'); $stmt->push_field('bar'); $self->assert_equals($stmt->stringify(), 'insert into foo (bar) values (?)'); } sub test_complex { my ($self) = @_; my $stmt = $self->get_statement(); $stmt->add_table('baz'); $stmt->push_field('fum'); $stmt->push_field('foe'); $stmt->push_field('fie'); $stmt->push_field('fee'); $self->assert_equals($stmt->stringify(), 'insert into baz (fum, foe, fie, fee) ' . 'values (?, ?, ?, ?)'); } 1; =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/SQL/Update.pm0100644000076400007640000000241110110143402015506 0ustar awgibbsawgibbspackage PROP::SQL::Update; use strict; use base qw/PROP::SQL/; sub stringify { my ($self) = @_; my $statement = 'update '; $statement .= $self->{-tables}->[0]; $statement .= ' set '; $statement .= join(', ', map { "$_ = ?" } @{$self->{-fields}}); $statement .= ' where ' . join(' and ', @{$self->{-conditions}}) if scalar(@{$self->{-conditions}}); return $statement; } 1; =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/SQL/Delete.pm0100644000076400007640000000225710110143402015476 0ustar awgibbsawgibbspackage PROP::SQL::Delete; use strict; use base qw/PROP::SQL/; sub stringify { my ($self) = @_; my $statement = 'delete from '; $statement .= $self->{-tables}->[0]; $statement .= ' where ' . join(' and ', @{$self->{-conditions}}) if scalar(@{$self->{-conditions}}); return $statement; } 1; =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/SQL/TestSuite.pm0100644000076400007640000000213310110143402016216 0ustar awgibbsawgibbspackage PROP::SQL::TestSuite; use strict; use base qw/Test::Unit::TestSuite/; sub include_tests { return ('PROP::SQL::SelectTest', 'PROP::SQL::UpdateTest', 'PROP::SQL::InsertTest', 'PROP::SQL::DeleteTest'); } 1; =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/SQL/SelectTest.pm0100644000076400007640000000402010110143402016341 0ustar awgibbsawgibbspackage PROP::SQL::SelectTest; use strict; use base qw/Test::Unit::TestCase/; use PROP::SQL::Select; sub new { my ($invocant, @args) = @_; my $self = $invocant->SUPER::new(@args); $self->set_statement(new PROP::SQL::Select); return $self; } sub get_statement { my ($self) = @_; return $self->{-statement}; } sub set_statement { my ($self, $statement) = @_; $self->{-statement} = $statement; } sub test_simple { my ($self) = @_; my $stmt = $self->get_statement(); $stmt->add_table('foo'); $stmt->push_field('bar'); $self->assert_equals($stmt->stringify(), 'select bar from foo'); } sub test_complex { my ($self) = @_; my $stmt = $self->get_statement(); $stmt->add_table('baz'); $stmt->add_table('foo'); $stmt->push_field('baz.biz'); $stmt->push_field('foo.bar'); $stmt->push_conditional_expression('baz.biz > foo.bar'); $stmt->push_conditional_expression('baz.biz < ?'); $stmt->push_ordering('baz.biz'); $self->assert_equals($stmt->stringify, 'select baz.biz, foo.bar from baz, foo ' . 'where baz.biz > foo.bar and baz.biz < ? ' . 'order by baz.biz'); } 1; =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/Util.pm0100644000076400007640000000443010110143402014545 0ustar awgibbsawgibbspackage PROP::Util; use strict; use base qw/Exporter/; our @EXPORT = qw/table_exists drop_table/; sub table_exists { my ($table_name) = @_; my $sth; eval { $sth = PROP::DBH->get_handle()->prepare('show tables'); $sth->execute(); }; if($@) { my $msg = "problem querying table list"; die $@->PROPAGATE($msg); } my $row; while($row = $sth->fetchrow_arrayref()) { return 1 if($row->[0] eq $table_name); } return 0; } sub drop_table { my ($table_name) = @_; return unless table_exists($table_name); eval { my $sth = PROP::DBH->get_handle()->prepare("drop table $table_name"); $sth->execute(); }; if($@) { my $msg = "problem dropping table '$table_name': $@"; die new PROP::Exception($msg); } } 1; =head1 Name PROP::Util =head1 Description This class is a collection of static utility methods for performing various tasks that are common to perhaps several different libraries, but couldn't find a good home in any particular one of them. =head1 Methods =over =item table_exists PROP::Util::table_exists($table_name); This method takes a database handle and the name of a table. It returns a Boolean value, true if the table exists within the database, and false if it does not. =item drop_table PROP::Util::drop_table($table_name); This method takes a database handle and the name of a table. It drops the table from the database if it exists. =back =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/Exception/0040755000076400007640000000000010110143432015235 5ustar awgibbsawgibbsPROP-0.1/lib/PROP/Exception/Configuration.pm0100664000076400007640000000114710110143402020401 0ustar awgibbsawgibbspackage PROP::Exception::Configuration; use strict; use base qw/PROP::Exception/; 1; =head1 Name PROP::Exception::Configuration =head1 Synopsis unless(configured_correctly()) { my $msg = "somebody didn't configure the system correctly!"; die new PROP::Exception::Configuration($msg); } =head1 Description This particular exception class is for indicating that the framework was configured incorrectly somehow. For example, an object table may lack a primary key field, a link table might not have a dual primary key, or connection information for a database handle was either wrong or missing. PROP-0.1/lib/PROP/Exception/IllegalArgument.pm0100644000076400007640000000206410110143402020643 0ustar awgibbsawgibbspackage PROP::Exception::IllegalArgument; use strict; use base qw/PROP::Exception/; sub new { my ($class, $msg) = @_; my ($pkg, $file, $line) = caller(1); # perspective of illegal invocation my $self = $class->SUPER::new($msg, $file, $line); return $self; } 1; =head1 Name PROP::Exception::IllegalArgument =head1 Synopsis sub foo { my ($arg1, $arg2) = @_; unless($arg1 > 3) { my $msg = "argh! you fool! arg1 must be greater than 3!"; die new PROP::Exception::IllegalArgument($msg); } unless(defined $arg2) { my $msg = "who said that a null arg2 was OK? Not I!"; die new PROP::Exception::IllegalArgument($msg); } } =head1 Description This particular exception is for indicating that a subroutine was passed an illegal value as a parameter. Of note is that while most other exceptions include call stack information from the point at which the exception object was created, IllegalArgument exceptions contain call stack information from the perspective of where the subroutine was illegally invoked. PROP-0.1/lib/PROP/Conditions/0040775000076400007640000000000010110143432015412 5ustar awgibbsawgibbsPROP-0.1/lib/PROP/Conditions/Foreign.pm0100664000076400007640000001102210110143402017327 0ustar awgibbsawgibbspackage PROP::Conditions::Foreign; use strict; use UNIVERSAL qw/isa/; use PROP::Link; use Hash::Util qw/lock_keys/; use PROP::Exception::IllegalArgument; sub new { my ($class, $link, $relationship, $expressions, $bindings) = @_; my $self = bless({}, $class); my $err_msg; $err_msg = "more arguments passed than expected" if scalar(@_) == 6; $err_msg = "was expecting an array reference as fourth argument" unless ref($bindings) eq 'ARRAY' or not defined $bindings; $err_msg = "was expecting an array reference as third argument" unless ref($expressions) eq 'ARRAY' or not defined $expressions; $err_msg = "was expecting either 'parents' or 'children' as second argument" unless $relationship eq 'parents' or $relationship eq 'children'; $err_msg = "was expecting a PROP::Link object as first argument" unless isa($link, 'PROP::Link'); die new PROP::Exception::IllegalArgument($err_msg) if $err_msg; $self->{-link} = $link; $self->{-relationship} = $relationship; $self->{-expressions} = $expressions; $self->{-bindings} = $bindings; lock_keys(%$self); push(@{$self->{-expressions}}, 'p.' . $link->get_parent_class()->get_pk_name() . ' = ' . 'l.' . $link->get_parent_field_name()); push(@{$self->{-expressions}}, 'c.' . $link->get_child_class()->get_pk_name() . ' = ' . 'l.' . $link->get_child_field_name()); return $self; } sub get_link { my ($self) = @_; return $self->{-link}; } sub get_relationship { my ($self) = @_; return $self->{-relationship}; } sub get_expressions { my ($self) = @_; return $self->{-expressions}; } sub get_bindings { my ($self) = @_; return $self->{-bindings}; } 1; =head1 Name PROP::Conditions::Foreign =head1 Synopsis $fc = new PROP::Conditions::Foreign($link, $relationship, $expressions, $bindings); =head1 Usage This class serves as a specifier for PROP::Query::Object objects, allowing users of the API to specify that objects be loaded only if they have relatives that satisfy specific conditions. For example, you might wish to load objects of type Foo only if they have children of type Bar that have biz fields of value greater than five. An array reference of zero or more PROP::Conditions::Foreign objects may be passed into the constructor of a PROP::Query::Object object to accomplish this. Each PROP::Conditions::Foreign object specifies one or more constraints on one relationship. The first argument to the constructor is a PROP::Link object which specifies the relationship of interest. The second argument to the constructor specifies on what aspect of the relationship we wish to impose a constraint, and it must be the string value "parents" or the string value "children". The former indicates that we wish to specify that loaded objects have parents that satisfy certain conditions, and the latter indicates that we wish to specify that the loaded objects have children that satisfy certain conditions. The third argument is a list of expressions that are used to spell out the constraints. Field names must be bound to tables explicitly using the aliases 'p', 'c', and 'l'. The 'p' alias refers to the parent table in the relationship, the 'c' alias to the child table, and the 'l' alias to the link table. When the underlying code eventually generates real SQL code, these aliases will be properly modified to deal with the fact that a PROP::Query::Object can accept multiple PROP::Conditions::Foreign objects, each of which used the same table aliasing. The fourth argument argument to the constructor is an array of values that are to be bound to the variables in the expressions specified by the third argument. =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/Conditions/Local.pm0100644000076400007640000000567510110143402017007 0ustar awgibbsawgibbspackage PROP::Conditions::Local; use strict; use Hash::Util qw/lock_keys/; use PROP::Constants; use PROP::Util; sub new { my ($class, $expressions, $bindings) = @_; my $self = bless({}, $class); my $err_msg; $err_msg = "was expecting array ref of bindings as second argument" unless ref $bindings eq 'ARRAY'; $err_msg = "was expecting array ref of expressions as first argument" unless ref $expressions eq 'ARRAY'; die new PROP::Exception::IllegalArgument($err_msg) if $err_msg; $self->{-expressions} = $expressions; $self->{-bindings} = $bindings; lock_keys(%$self) if DEBUG; return $self; } sub get_expressions { my ($self) = @_; return @{$self->{-expressions}}; } sub push_expression { my ($self, $expression) = @_; push(@{$self->{-expressions}}, $expression); } sub get_bindings { my ($self) = @_; return @{$self->{-bindings}}; } sub push_binding { my ($self, $binding) = @_; push(@{$self->{-bindings}}, $binding); } 1; =head1 Name PROP::Conditions::Local =head1 Synopsis $conds = new PROP::Conditions::Local($expressions, $bindings); =head1 Methods =over =item new $conds = new PROP::Conditions::Local($expressions, $bindings); This method constructs and returns a new PROP::Conditions::Local object, where $expressions is an array reference of strings that represent conditional expressions, e.g. 'foo < ?', and $bindings is an array reference of bindings for variables (?) in the conditional expressions. =item get_expressions @expressions = $conds->get_expressions(); This method returns a list that contains the conditional expressions that this object holds. =item get_bindings @bindings = $conds->get_bindings(); This method returns a list that contains the conditional bindings that this object holds. =item push_expression $conds->push_expression($expression); This method adds an expression to the end of the list of expressions held by this object. =item push_binding $conds->push_binding($binding); This method adds a binding to the end of the list of bindings held by this object. =back =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/Conditions/ForeignTest.pm0100664000076400007640000000372210110143402020177 0ustar awgibbsawgibbspackage PROP::Conditions::ForeignTest; use strict; use base qw/Test::Unit::TestCase/; use PROP::TestCommon; use PROP::Link; use PROP::Conditions::Foreign; sub new { my ($invocant, @args) = @_; my $self = $invocant->SUPER::new(@args); return $self; } sub set_up { my ($self) = @_; drop_tables(); create_tables(); } sub tear_down { my ($self) = @_; drop_tables(); } sub test_conditions_foreign { my ($self) = @_; my $link = new PROP::Link('LinkFooToBiz', 'Dummy::Foo', 'Dummy::Biz'); my $fc = new PROP::Conditions::Foreign($link, 'children', ['p.foo = c.baz', 'l.biz = ?'], [3]); $self->assert_equals($link, $fc->get_link()); $self->assert_equals('children', $fc->get_relationship()); $self->assert_equals(4, scalar(@{$fc->get_expressions()})); $self->assert_equals('p.foo = c.baz', $fc->get_expressions()->[0]); $self->assert_equals('l.biz = ?', $fc->get_expressions()->[1]); $self->assert_equals('p.foo = l.foo_id', $fc->get_expressions()->[2]); $self->assert_equals('c.biz = l.biz_id', $fc->get_expressions()->[3]); } 1; =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/Conditions/TestSuite.pm0100644000076400007640000000202010110143402017663 0ustar awgibbsawgibbspackage PROP::Conditions::TestSuite; use strict; use base qw/Test::Unit::TestSuite/; sub include_tests { return ('PROP::Conditions::ForeignTest'); } 1; =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/lib/PROP/Conditions/LocalTest.pm0100664000076400007640000000254410110143402017641 0ustar awgibbsawgibbspackage PROP::Conditions::LocalTest; use strict; use base qw/Test::Unit::TestCase/; use PROP::Conditions::Local; sub new { my ($invocant, @args) = @_; my $self = $invocant->SUPER::new(@args); return $self; } sub set_up { my ($self) = @_; $self->{-conditions} = new PROP::Conditions::Local(['Foo.bar < Bar.baz', 'Bar.biz = Fee.foo', 'Foo.meh > Foe.feh', 'Foo.meh < ?', 'Feh.bah > ?'], []); } sub tear_down { my ($self) = @_; } 1; =head1 Author Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov) =head1 Legalese This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgement if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. PROP-0.1/DESIGN0100644000076400007640000001442410110143402012644 0ustar awgibbsawgibbsINTRODUCTION The motivation for the design of this module is two-fold. First, it seeks to provide users with a powerful and rich feature set for object persistence that lives on top of SQL driven databases in a way that is transparent to the application programmer. Users of this framework create Perl objects, manipulate them as they please, indicate that they want them saved to the database, and later load them for further interaction. During all of this the user is relieved of the burden of hand-crafting SQL statements. Second, this framework seeks to enforce a judicious balance between efficiency and extensibility in database table structure and querying mechanisms. While you are certainly free to mix and match usage of this framework with custom tables and raw SQL of your own, you are not apt to need to so often, if ever, and the result will be a consistent and coherent system. Table layout will be clean, and manipulation of table contents will occur in a fashion that pays heed both the need to minimize resource consumption and program complexity. FRAMEWORK COMPONENTS The core classes of the framework embody the following things: objects, links, queries, and result sets. Objects lie at the center of this system, as every operation herein involves creating, modifying, deleting and linking them. Links serve as a way of tying together objects in arbitrary ways. Queries embody specifications of a collection of objects in a database, and possibly also relatives in which you are interested. Result sets are what you get back when you execute queries; they function more or less as iterators. OBJECTS Underneath the hood, objects are stored and loaded from database tables that have nearly limitless flexibility in their design, but must adhere to one constraint. Specifically, a table that holds objects must have a solo primary key, and it must be specified as an automatically incrementing integer. This will function as what is known as a surrogate primary key, a column that has no semantic meaning except to act as a row identifier. This key is of central importance to loading objects via links. The fields of an object consist of all of the columns of the table that house objects of the given type. You may get and set all of the field values of an object, except for the primary key, which may only be retrieved, not set. Objects also have contextual values, values that are set when an object is loaded via a link, that indicate the context from which they were instantiated. These contextual values can not be set directly via the object, but rather are set when object linking information is put into the database. To create an object class of your own, you will do so by subclassing PROP::Object. At the very simplest level, you can get away with doing nothing more than providing in this package a get_table_name() method that returns the name of the table in which objects of this type reside in the database. The PROP::Object base class will use this method to extract the format of the table, to auto-generate accessor methods, and to save/load objects to/from the table. While providing the get_table_name() method is the only thing that you strictly must do, you will probably want to treat your subclass as a decorator class, providing various convenience methods that wrap up invocations of methods in the base class, manipulating links to other objects, etc. LINKS Links are how one ties together objects into collections, and are embodied in the PROP::Link class. Under the hood, link tables have dual primary keys, and zero or more contextual fields. The two primary key fields house the surrogate primary keys of the objects being linked, and the contextual fields provide, well, contextual information, information that will be accessible from objects after they have been loaded via a link that indicates from whence they have sprung. This general format is conducive to specifying any kind of relationship information that is desired, whether it be on-to-one, one-to-many, or many-to-many. QUERIES Query objects are the mechanism via which one loads collections of objects. They come in two flavors: PROP::Query::Object and PROP::Query::Link. The former is used to query collections of objects. The latter is used to query collections of links, and one or more such objects can be specified to the former to facillitate the loading of objects along with specific relatives all in one fell swoop as opposed to doing lazy loading at a later point. Queries can specify conditions, orderings, and limits. With the right combination of properly constructed query objects, one can load pretty much any desired collection of information via the framework. RESULT SETS Result set objects, returned by the execute() methods of query objects, not only act as convenient iterators over collections of objects, but also perform behind-the-scenes work to avoid choking system memory when queries specify very large collections of data. While the user of a result set object can treat it like a stream, casually pulling back one object after another, underneath the hood the result set object repeatedly pulls in reasonable sized chunks of data, refilling its buffers every time it runs out of results. In the case of loading objects along with relatives, what the result set object is doing unbeknownst to the user is taking several disjointed streams of results, one for the objects and one for each type of relative, and sewing them together into a single stream of objects with the relatives loaded. EXTENSIBILITY Presently this framework only supports the MySQL database, but it has been designed to be highly database agnostic, and to allow for people to write extensions that allow for the use of other RDBMS. Specifically, DBD specific code lives in subclasses of more generic classes. For example, when you instantiate a subclass of PROP::Object, the base class constructor examines which RDBMS is in use, and mangle's the subclass's ISA array to no longer have PROP::Object as its base class, but rather PROP::Object::MySQL which is a subclass of PROP::Object that provides MySQL specific functionality, such as extracting auto_increment values from statement handles. The PROP::Conf class is another example of such subclassing, and PROP::Conf::MySQL is written to parse .my.cnf files to extract connection information. PROP-0.1/demo.pl0100755000076400007640000001642210110143402013234 0ustar awgibbsawgibbs#!/usr/bin/perl use strict; no strict 'refs'; use PROP::Conf; use PROP::DBH; use PROP::Util; use PROP::Link; use Data::Dumper; my $rdbms = shift(@ARGV); my $cnxn_conf = shift(@ARGV); configure_connection($rdbms, $cnxn_conf); # to where and how we connect my @demos = @ARGV || ('object_demo', 'lazy_link_loading_demo', 'preemptive_link_loading_demo'); foreach my $demo (@demos) { init_tables(); print "\n\n"; my $line = "# running $demo #"; print '#' x length($line), "\n"; print $line, "\n"; print '#' x length($line), "\n"; &$demo(); } sub object_demo { print "creating object...\n"; my $foo = Foo->new(); print "setting field values...\n"; $foo->set_bar(3); $foo->set_baz("meh"); print "saving object...\n"; $foo->save(); my $pk_value = $foo->get_pk_value(); print "loading object by primary key value (" . $pk_value . ")\n"; $foo = new Foo($pk_value); print "retrieving field values...\n"; print "bar: ", $foo->get_bar(), "\n"; print "baz: ", $foo->get_baz(), "\n"; print "changing bar to 5 and saving object...\n"; $foo->set_bar(5); $foo->save(); print "loading object by field value specification\n"; $foo = Foo->new({ bar => 5, baz => 'meh'}); print "verifying primary key value: ", $pk_value, "\n"; print "deleting object...\n"; $foo->delete(); print "attempting to load deleted object...\n"; $foo = new Foo({ bar => 3, baz => 'meh' }); print "primary key value should be unset: ", $foo->get_pk_value() ? 'uh-oh' : 'yup', "\n"; } # 'lazy' as in "load the object, and then load some relatives later sub lazy_link_loading_demo { my $link = new PROP::Link('LinkFooToBiz', 'Foo', 'Biz'); my $foo = new Foo(); $foo->set_bar(4); $foo->set_baz('score'); $foo->save(); for(my $i = 0; $i < 8; ++$i) { my $biz = new Biz(); $biz->set_boz($i); $biz->set_buzz('biz' . $i); $biz->save(); $link->insert($foo, $biz, { c1 => $i, c2 => $i * 2, c3 => 'bleh' . $i }); } my $lq = new PROP::Query::Link($link, 'children', ['c.boz % ?', 'l.c1 > ?'], [2, 4], ['l.c1 DESC']); $foo->load_relatives([$lq]); my @children = $foo->get_children('LinkFooToBiz'); foreach my $biz (@children) { print "biz = " . $biz->get_pk_value() . ", boz = " . $biz->get_boz() . ", buzz = " . $biz->get_buzz() . " c1 = " . $biz->get_contextual_value('c1') . " c2 = " . $biz->get_contextual_value('c2') . " c3 = " . $biz->get_contextual_value('c3') . "\n"; } } sub preemptive_link_loading_demo { my (@bizzes, @fuzzes); my $fb_link = new PROP::Link('LinkFooToBiz', 'Foo', 'Biz'); my $ff_link = new PROP::Link('LinkFooToFuzz', 'Foo', 'Fuzz'); for(my $i = 0; $i < 16; ++$i) { my $biz = new Biz(); $biz->set_boz($i + 1); $biz->set_buzz('meh' . $i); $biz->save(); push(@bizzes, $biz); } for(my $i = 0; $i < 16; ++$i) { my $fuzz = new Fuzz(); $fuzz->set_fooz($i + 1); $fuzz->set_fozz('bleh' . $i); $fuzz->save(); push(@fuzzes, $fuzz); } for(my $i = 0; $i < 4; ++$i) { my $foo = new Foo(); $foo->set_bar($i); $foo->set_baz('feh' . $i); $foo->save(); for(my $j = 0; $j < 4; ++$j) { $fb_link->insert($foo, $bizzes[$i * 4 + $j], { c1 => $j - $i, c2 => $i * $j, c3 => "blah_${i}_${j}" }); $ff_link->insert($foo, $fuzzes[$i * 4 + $j], { d1 => 2 * ($j - $i), d2 => 2 * ($i * $j), d3 => "meh_${i}_${j}" }); } } my $lq1 = new PROP::Query::Link($fb_link, 'children', ['c.boz % ?'], [2], []); my $lq2 = new PROP::Query::Link($ff_link, 'children', ['c.fuzz % ?'], [3], []); my $oq = new PROP::Query::Object('Foo', ['foo % ?'], [2], [], [$lq1, $lq2]); my $result_set = $oq->execute(); while(my $foo = $result_set->get_next_result()) { print "Foo: " . " foo = " . $foo->get_pk_value() . " bar = " . $foo->get_bar() . " baz = " . $foo->get_baz() . "\n"; foreach my $biz ($foo->get_children($fb_link->get_table_name())) { print "Biz: " . " biz = " . $biz->get_pk_value() . " boz = " . $biz->get_boz() . " buzz = " . $biz->get_buzz() . " c1 = " . $biz->get_contextual_value('c1') . " c2 = " . $biz->get_contextual_value('c2') . " c3 = " . $biz->get_contextual_value('c3') . "\n"; } foreach my $fuzz ($foo->get_children($ff_link->get_table_name())) { print "Fuzz: " . " fuzz = " . $fuzz->get_pk_value() . " fooz = " . $fuzz->get_fooz() . " fozz = " . $fuzz->get_fozz() . " d1 = " . $fuzz->get_contextual_value('d1') . " d2 = " . $fuzz->get_contextual_value('d2') . " d3 = " . $fuzz->get_contextual_value('d3') . "\n"; } print "------------------------------------------\n"; } } # the library framework requires information on which DBD to use and # information that specifies the database to which a connection will # be made sub configure_connection { my ($rdbms, $cnxn_conf) = @_; set_rdbms($rdbms); set_cnxn_conf($cnxn_conf); } # the library framework expects the database to have tables in it... sub init_tables { my @stmts; # object tables must have a primary key field, and can have as # many other data fields as you like $stmts[0] = q{ create table Foo ( foo int(10) NOT NULL auto_increment, bar int(10), baz varchar(50), primary key (foo)) }; $stmts[1] = q{ create table Biz ( biz int(10) NOT NULL auto_increment, boz int(10), buzz varchar(50), primary key (biz)) }; $stmts[2] = q{ create table Fuzz ( fuzz int(10) NOT NULL auto_increment, fooz int(10), fozz varchar(50), primary key (fuzz)) }; # link tables must have a dual primary key and may optionally have # "contextual values" $stmts[3] = q{ create table LinkFooToBiz ( foo_id int(10) NOT NULL, biz_id int(10) NOT NULL, c1 int(10), c2 int(10), c3 varchar(50), primary key (foo_id, biz_id)) }; $stmts[4] = q{ create table LinkFooToFuzz ( foo_id int(10) NOT NULL, fuzz_id int(10) NOT NULL, d1 int(10), d2 int(10), d3 varchar(50), primary key (foo_id, fuzz_id)) }; # drop the tables, if case they are already there drop_tables(); # grab the handle that the framework uses to create our tables my $dbh = PROP::DBH::get_handle(); eval { foreach (@stmts) { my $sth = $dbh->prepare($_); $sth->execute(); } }; if(@$) { die "oops, we had a problem creating the tables: $@\n"; } } sub drop_tables { PROP::Util::drop_table('Foo'); PROP::Util::drop_table('Biz'); PROP::Util::drop_table('Fuzz'); PROP::Util::drop_table('LinkFooToBiz'); PROP::Util::drop_table('LinkFooToFuzz'); } package Foo; use base qw/PROP::Object/; sub get_table_name { return 'Foo'; } package Biz; use base qw/PROP::Object/; sub get_table_name { return 'Biz'; } package Fuzz; use base qw/PROP::Object/; sub get_table_name { return 'Fuzz'; } PROP-0.1/Makefile.PL0100644000076400007640000000106310110143402013715 0ustar awgibbsawgibbsuse 5.008000; use ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( NAME => 'PROP', VERSION_FROM => 'lib/PROP.pm', # finds $VERSION PREREQ_PM => { DBI => 0, Test::Unit => 0 }, ($] >= 5.005 ? ## Add these new keywords supported since 5.005 (ABSTRACT => 'Cool Stuff', # retrieve abstract from module AUTHOR => 'Andrew William Gibbs ') : ()), ); PROP-0.1/README0100644000076400007640000000741410111455634012647 0ustar awgibbsawgibbsPROP version 0.01 ====================== This is pre-alpha software. You should not use it to control airplanes or nuclear power plants. You probably shouldn't even use it to control your coffee maker or toaster. INSTALLATION To install this module type the following: perl Makefile.PL make make test make install ** If you you want to install somewhere other than the root, then you will want to do "perl Makefile.PL PREFIX=/path/to/somewhere ** For "make test"... You will want to have the PROP_RDBMS environment variable set to a value that specifies your database type. currently the only supported value is 'MySQL'. You will also want to have the environment variable PROP_CNXNCONF set to a value that specifies how to initiate a connection to the database; Presently the only supported thing to do is to specify a path to a .my.cnf file for MySQL. ** If "make test" breaks, it may be because of missing symbols from a DLL on your system. After running "perl Makefile.PL" you can edit the resultant Makefile, changing all instances of "PERL_DL_NONLAZY=1" to "PERL_DL_NONLAZY=0", and then "make test" should run just fine. DEPENDENCIES This module requires these other modules and libraries: DBI DBD::whatever (e.g. mysql) Test::Unit GETTING STARTED For a simple demonstration, try running the included demo.pl script. The demo.pl script expects two arguments, the RDBMS you are using (MySQL is the only supported one currently) and a connection configuration specifier (currently only a path to a .my.cnf file is supported). Read the demo.pl source code, and try to follow along with its print-outs to get a hang of how things work. Also look at all of the included module tests. Tests are included with a name the same as each class, except with "Test" appended to the name. For example, the test module for PROP::Object is the PROP::ObjectTest class. For the most part the various classes have embedded POD which can be accessed via the perldoc command, e.g. "perldoc PROP::Object". There is actually a lot of documentation, though some sections may as of yet not be fully fleshed out, and its possible that some things have changed. A good starting point is PROP which isn't actually a class, but rather holds a description of all of the classes that play a part in the framework, so starting off with "perldoc PROP" is probably a good idea. DESIGN Please see the file called "DESIGN" for a high level discussion of design issues. BUGS Probably. If something seems broken, please don't waste a lot of time agonizing about it. There is a very good chance that there are broken internals as opposed to there being a misunderstanding of the API on your part. Furthermore, if some of the documentation is confusing, or your program dies in a confusing way, please let me know so I can either improve the documentation, or write more informative error handling code. LEGALESE This software was developed at the National Institute of Standards and Technology by employees of the Federal Government in the course of their official duties. Pursuant to title 17 Section 105 of the United States Code this software is not subject to copyright protection and is in the public domain. PROP is an experimental system. NIST assumes no responsibility whatsoever for its use by other parties, and makes no guarantees, expressed or implied, about its quality, reliability, or any other characteristic. We would appreciate acknowledgment if the software is used. This software can be redistributed and/or modified freely provided that any derivative works bear some notice that they are derived from it, and any modified versions bear some notice that they have been modified. AUTHOR Andrew William Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov)