Author: spadkins
Date: Tue Jun 22 20:50:54 2010
New Revision: 14184
Added:
p5ee/trunk/App-Moose/
p5ee/trunk/App-Moose/CHANGES
p5ee/trunk/App-Moose/INSTALL.SKIP
p5ee/trunk/App-Moose/MANIFEST.SKIP
p5ee/trunk/App-Moose/Makefile.PL
p5ee/trunk/App-Moose/README
p5ee/trunk/App-Moose/TODO
p5ee/trunk/App-Moose/lib/
p5ee/trunk/App-Moose/lib/App/
p5ee/trunk/App-Moose/lib/App/Moose/
p5ee/trunk/App-Moose/lib/App/Moose/RepositoryObject.pm
p5ee/trunk/App-Moose/lib/App/Moose/SessionObject.pm
p5ee/trunk/App-Moose/t/
p5ee/trunk/App-Moose/t/RepositoryObject.t (contents, props changed)
p5ee/trunk/App-Moose/t/RepositoryTestUtils.pm (contents, props changed)
p5ee/trunk/App-Moose/t/SessionObject.t (contents, props changed)
p5ee/trunk/App-Moose/t/app.conf.sample
Log:
add Moose support
Added: p5ee/trunk/App-Moose/CHANGES
==============================================================================
--- (empty file)
+++ p5ee/trunk/App-Moose/CHANGES Tue Jun 22 20:50:54 2010
@@ -0,0 +1,7 @@
+#############################################################################
+# CHANGE LOG
+#############################################################################
+
+VERSION 0.50
+ o First version
+
Added: p5ee/trunk/App-Moose/INSTALL.SKIP
==============================================================================
--- (empty file)
+++ p5ee/trunk/App-Moose/INSTALL.SKIP Tue Jun 22 20:50:54 2010
@@ -0,0 +1,19 @@
+# NOTE: the master INSTALL.SKIP is in the mv/common project
+~$
+^MANIFEST\.
+^Makefile$
+^pm_to_blib$
+^tmp
+\.trash$
+\.old$
+\.bak$
+\.swp$
+\.cvsignore$
+\.tar\.gz$
+\.zip$
+htdocs/.exists
+htdocs/lib
+.svn/
+CVS/
+\.#
+^pm_to
Added: p5ee/trunk/App-Moose/MANIFEST.SKIP
==============================================================================
--- (empty file)
+++ p5ee/trunk/App-Moose/MANIFEST.SKIP Tue Jun 22 20:50:54 2010
@@ -0,0 +1,14 @@
+~$
+^_build
+^Build$
+^MANIFEST\.
+^Makefile$
+^blib/
+^pm_to_blib$
+\.old$
+\.bak$
+\.cvsignore$
+\.tar\.gz$
+\.svn
+htdocs/.exists
+CVS/
Added: p5ee/trunk/App-Moose/Makefile.PL
==============================================================================
--- (empty file)
+++ p5ee/trunk/App-Moose/Makefile.PL Tue Jun 22 20:50:54 2010
@@ -0,0 +1,27 @@
+
+######################################################################
+## File: $Id: Makefile.PL 13875 2010-03-26 17:22:46Z spadkins $
+######################################################################
+
+use ExtUtils::MakeMaker;
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
+# the contents of the Makefile that is written.
+
+my @programs = (
+);
+
+%opts = (
+ NAME => "App-Moose",
+ DISTNAME => "App-Moose",
+ VERSION => "0.969", # the first release is 0.969 just to
make it even with App-Context and App-Repository
+ EXE_FILES => [ @programs ],
+ PREREQ_PM => {
+ "App-Context" => "0.969", # This is the first version
that supports App-Moose
+ "App-Repository" => "0.969", # This is the first version
that supports App-Moose
+ "Moose" => "0.93", # There's no particular
reason I chose this version. It is simply what I tested the code for.
+ "namespace::autoclean" => "0.11", # There's no particular
reason I chose this version. It is simply what I tested the code for.
+ },
+);
+
+WriteMakefile(%opts);
+
Added: p5ee/trunk/App-Moose/README
==============================================================================
--- (empty file)
+++ p5ee/trunk/App-Moose/README Tue Jun 22 20:50:54 2010
@@ -0,0 +1,30 @@
+######################################################################
+## File: $Id: README 3442 2005-05-14 14:14:01Z spadkins $
+######################################################################
+
+1. What is the App-Moose distribution?
+
+The App-Moose distribution implements three of the primary abstractions
+of the App-Context Framework as Moose-friendly classes.
+
+ App::Moose::SessionObject - a stateless or stateful object with methods
+ which implement business or application logic. If it has state,
+ that state is maintained in the current application session.
+
+ App::Moose::RepositoryObject - an object which represents a business
+ entity (i.e. a row from a database table). This object's state
+ is maintained in an App::Repository table (usually a database).
+
+ App::Moose::SessionObject::RepositoryObjectSet - an object which
+ represents a collection of RepositoryObjects.
+
+2. How do I install it?
+
+To install this module, cd to the directory that contains this README
+file and type the following (as usual).
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
Added: p5ee/trunk/App-Moose/TODO
==============================================================================
--- (empty file)
+++ p5ee/trunk/App-Moose/TODO Tue Jun 22 20:50:54 2010
@@ -0,0 +1,7 @@
+x######################################################################
+## File: $Id: TODO 10141 2007-10-30 19:11:51Z spadkins $
+######################################################################
+
+These items are what will be required to go to the next release to CPAN
+ o do it
+
Added: p5ee/trunk/App-Moose/lib/App/Moose/RepositoryObject.pm
==============================================================================
--- (empty file)
+++ p5ee/trunk/App-Moose/lib/App/Moose/RepositoryObject.pm Tue Jun 22
20:50:54 2010
@@ -0,0 +1,96 @@
+
+#############################################################################
+## $Id: RepositoryObject.pm 7868 2006-10-03 14:43:34Z spadkins $
+#############################################################################
+
+package App::Moose::RepositoryObject;
+$VERSION = (q$Revision: 7868 $ =~ /(\d[\d\.]*)/)[0]; # VERSION numbers
generated by svn
+use Moose;
+use namespace::autoclean;
+
+extends "Moose::Object", "App::RepositoryObject"; # We need the
Moose::Object::new constructor and the other methods from App::RepositoryObject
+
+has "_repository" => (is => "ro", isa => "App::Repository");
+has "_table" => (is => "ro", isa => "Str", required => 1);
+has "_key" => (is => "ro", isa => "Str");
+
+#TODO: I ought to make a RepositoryObject automatically define the attributes
based on the table (along with getters and setters)
+# But that will have to wait.
+
+=head1 NAME
+
+App::Moose::RepositoryObject - Persistent, global business entity objects
(i.e. rows in a database)
+
+=head1 SYNOPSIS
+
+ [in app.conf]
+ repositoryobject_class = App::Moose::RepositoryObject # the default
without this setting is App::RepositoryObject
+
+ [in perl code]
+
+ # For these examples, there is presumed to be a table in the database
named "person" with an auto-incrementing
+ # primary key called "person_id" and columns "first_name", "last_name",
and "age".
+
+ use App;
+ my $context = App->context();
+ my $db = $context->repository():
+
+ my ($person, $person2, $persons);
+ my ($first_name, $last_name, $age, $success);
+
+ # retrieve an existing person or set of persons
+ $person = $db->get_object("person", 1); # a scalar for
$params implies a primary key value
+ $person = $db->get_object("person", { person_id => 1 }); # use arbitrary
$params. get the first object.
+ $persons = $db->get_objects("person", { last_name => "Smith" }); # use
arbitrary $params, all objects.
+
+ # create a new person (
+ $person2 = $db->new_object("person", { first_name => "John", last_name =
"Doe", age => 18 });
+
+ # delete a person (
+ $success = $db->delete("person", 1); # on the App::Repository (preferred)
+ $success = $person2->delete(); # on the App::RepositoryObject
itself
+
+ # getters and setters (consistent with App::RepositoryObject)
+ $age = $person->get("age");
# get a single attribute
+ ($first_name, $last_name) = $person->get(["first_name", "last_name"]);
# get multiple attributes
+ $success = $person->set("age",19);
# set a single attribute
+ $success = $person->set(["first_name", "last_name"], ["Jane","Smith"]);
# set multiple attributes
+
+ # FUTURE: NOT YET IMPLEMENTED
+
+ # getters and setters (new with App::Moose::RepositoryObject) (only
available for physical or default columns)
+ $age = $person->age;
# get a single attribute
+ $success = $person->age(19);
# set a single attribute
+
+=cut
+
+=head1 DESCRIPTION
+
+The App::Moose::RepositoryObject class is a reimplementation of the
+App::RepositoryObject class as a base class written with Moose.
+
+Moose is the next generation of Object-Oriented capabilities implemented
+in Perl 5. Many of these features are from Perl 6.
+
+See the documentation for App::RepositoryObject for a discussion of
+what a RepositoryObject is.
+
+=cut
+
+=head1 ACKNOWLEDGEMENTS
+
+ * Author: Stephen Adkins <[email protected]>
+ * License: This is free software. It is licensed under the same terms as Perl
itself.
+
+=head1 SEE ALSO
+
+L<C<App::Context>|App::Context>,
+L<C<App::Repository>|App::Repository>,
+L<C<App::RepositoryObject>|App::RepositoryObject>
+
+=cut
+
+__PACKAGE__->meta->make_immutable;
+
+1;
+
Added: p5ee/trunk/App-Moose/lib/App/Moose/SessionObject.pm
==============================================================================
--- (empty file)
+++ p5ee/trunk/App-Moose/lib/App/Moose/SessionObject.pm Tue Jun 22 20:50:54 2010
@@ -0,0 +1,82 @@
+
+#############################################################################
+## $Id: SessionObject.pm 7868 2006-10-03 14:43:34Z spadkins $
+#############################################################################
+
+package App::Moose::SessionObject;
+$VERSION = (q$Revision: 7868 $ =~ /(\d[\d\.]*)/)[0]; # VERSION numbers
generated by svn
+use Moose;
+use namespace::autoclean;
+
+extends "Moose::Object", "App::SessionObject"; # We need the
Moose::Object::new constructor and the other methods from App::SessionObject
+
+has 'context' => (is => 'ro', isa => 'App::Context');
+has 'name' => (is => 'ro', isa => 'Str');
+has 'stateless' => (is => 'ro', isa => 'Bool', default => 0);
+has 'anonymous' => (is => 'ro', isa => 'Bool', default => 0);
+has 'lang' => (is => 'ro', isa => 'Str', default => "en");
+has 'dict' => (is => 'ro', isa => 'HashRef');
+
+=head1 NAME
+
+App::Moose::SessionObject - Named, Configurable, Cached, Stateless or Stateful
(in the Session) business or application objects (i.e. screens, business
processes, application logic, etc.)
+
+=head1 SYNOPSIS
+
+ [in app.conf]
+ sessionobject_class = App::Moose::SessionObject # the default without
this setting is App::SessionObject
+
+ [in perl code]
+
+ # For these examples, there is presumed to be a table in the database
named "person" with an auto-incrementing
+ # primary key called "person_id" and columns "first_name", "last_name",
and "age".
+
+ use App;
+ my $context = App->context();
+ my $cart = $context->session_object("shopping_cart"):
+ my $tax_calc = $context->session_object("tax_calculator", { stateless =>
1, country_cd => "US" }):
+
+ # # getters and setters (consistent with App::SessionObject)
+ # $age = $person->get("age");
# get a single attribute
+ # ($first_name, $last_name) = $person->get(["first_name", "last_name"]);
# get multiple attributes
+ # $success = $person->set("age",19);
# set a single attribute
+ # $success = $person->set(["first_name", "last_name"],
["Jane","Smith"]); # set multiple attributes
+
+ # # FUTURE: NOT YET IMPLEMENTED
+
+ # # getters and setters (new with App::Moose::SessionObject) (only
available for physical or default columns)
+ # $age = $person->age;
# get a single attribute
+ # $success = $person->age(19);
# set a single attribute
+
+=cut
+
+=head1 DESCRIPTION
+
+The App::Moose::SessionObject class is a reimplementation of the
+App::SessionObject class as a base class written with Moose.
+
+Moose is the next generation of Object-Oriented capabilities implemented
+in Perl 5. Many of these features are from Perl 6.
+
+See the documentation for App::SessionObject for a discussion of
+what a SessionObject is.
+
+=cut
+
+=head1 ACKNOWLEDGEMENTS
+
+ * Author: Stephen Adkins <[email protected]>
+ * License: This is free software. It is licensed under the same terms as Perl
itself.
+
+=head1 SEE ALSO
+
+L<C<App::Context>|App::Context>,
+L<C<App::Repository>|App::Repository>,
+L<C<App::SessionObject>|App::SessionObject>
+
+=cut
+
+__PACKAGE__->meta->make_immutable;
+
+1;
+
Added: p5ee/trunk/App-Moose/t/RepositoryObject.t
==============================================================================
--- (empty file)
+++ p5ee/trunk/App-Moose/t/RepositoryObject.t Tue Jun 22 20:50:54 2010
@@ -0,0 +1,251 @@
+#!/usr/bin/perl -w
+
+use App::Options (
+ options => [qw(dbdriver dbclass dbhost dbname dbuser dbpass)],
+ option => {
+ dbclass => { default => "App::Repository::MySQL", },
+ dbdriver => { default => "mysql", },
+ dbhost => { default => "localhost", },
+ dbname => { default => "test", },
+ dbuser => { default => "", },
+ dbpass => { default => "", },
+ },
+);
+
+use Test::More qw(no_plan);
+use lib "../App-Context/lib";
+use lib "../../App-Context/lib";
+use lib "lib";
+use lib "../lib";
+use lib ".";
+use lib "t";
+
+use App;
+use App::Repository;
+use App::RepositoryObject;
+use RepositoryTestUtils qw(create_table drop_table populate_table);
+
+package App::Moose::RepositoryObject::Man;
+use vars qw($VERSION);
+$VERSION = 0.01;
+use Moose;
+extends "App::Moose::RepositoryObject";
+
+package App::Moose::RepositoryObject::Woman;
+use vars qw($VERSION);
+$VERSION = 0.01;
+use Moose;
+extends "App::Moose::RepositoryObject";
+
+package main;
+
+use strict;
+
+if (!$App::options{dbuser}) {
+ ok(1, "No dbuser given. Tests assumed OK. (add dbuser=xxx and dbpass=yyy
to app.conf in 't' directory)");
+ exit(0);
+}
+
+my $context = App->context(
+ conf_file => "",
+ conf => {
+ Repository => {
+ default => {
+ class => $App::options{dbclass},
+ dbdriver => $App::options{dbdriver},
+ dbhost => $App::options{dbhost},
+ dbname => $App::options{dbname},
+ dbuser => $App::options{dbuser},
+ dbpass => $App::options{dbpass},
+ table => {
+ test_person => {
+ class => [
+ [ "gender", "F",
"App::Moose::RepositoryObject::Woman" ],
+ # [ undef, undef,
"App::Moose::RepositoryObject::Man" ], # otherwise Man
+ ],
+ primary_key => ["person_id"],
+ },
+ },
+ },
+ },
+ },
+ debug_sql => $App::options{debug_sql},
+ trace => $App::options{trace},
+ repositoryobject_class => $App::options{repositoryobject_class},
+);
+
+my $rep = $context->repository();
+
+&drop_table($rep, "test_person");
+&create_table($rep, "test_person");
+&populate_table($rep, "test_person");
+
+&drop_table($rep, "test_visit");
+&create_table($rep, "test_visit");
+&populate_table($rep, "test_visit");
+
+&drop_table($rep, "test_city");
+&create_table($rep, "test_city");
+&populate_table($rep, "test_city");
+
+my $dbtype = $App::options{dbtype} || "mysql";
+
+###########################################################################
+# DATA ACCESS TESTS
+###########################################################################
+my ($person_id, $first_name, $last_name, $address, $city, $state, $zip,
$country);
+my ($home_phone, $work_phone, $email_address, $gender, $birth_dt, $age);
+
+my $columns = [ "person_id", "age", "first_name", "gender", "state" ];
+my $rows = [
+ [ 1, 39, "stephen", "M", "GA", ],
+ [ 2, 37, "susan", "F", "GA", ],
+ [ 3, 6, "maryalice", "F", "GA", ],
+ [ 4, 3, "paul", "M", "GA", ],
+ [ 5, 1, "christine", "F", "GA", ],
+ [ 6, 45, "tim", "M", "GA", ],
+ [ 7, 39, "keith", "M", "GA", ],
+];
+
+my ($row, $nrows);
+
+#####################################################################
+# $value = $rep->get ($table, $key, $col, \%options);
+# $rep->set($table, $key, $col, $value, \%options);
+#####################################################################
+{
+ my $obj = $rep->get_object("test_person", 1);
+ isa_ok($obj, "App::Moose::RepositoryObject", "stephen");
+ $first_name = $obj->get("first_name");
+ is($first_name, "stephen", "get() first_name [$first_name]");
+ is($obj->set("first_name", "steve"),1,"set() first name [steve]");
+}
+{
+ my $obj = $rep->get_object("test_person", 1);
+ $first_name = $obj->get("first_name");
+ is($first_name, "steve", "get() modified first_name [$first_name]");
+ $age = $obj->get("age");
+ is($age, 39, "get() age");
+}
+{
+ my $obj = $rep->get_object("test_person", 1, []);
+ $first_name = $obj->get("first_name");
+ is($first_name, "steve", "get() modified first_name [$first_name] from
uninit object");
+ $age = $obj->get("age");
+ is($age, 39, "get() age from uninit object");
+}
+
+{
+ my $obj = $rep->get_object("test_person", 2, []);
+ isa_ok($obj, "App::Moose::RepositoryObject", "susan");
+ ok($obj->set(["first_name","age"], ["sue",38]), "set() 2 values");
+ ($first_name, $age) = $obj->get(["first_name","age"]);
+ is($first_name, "sue", "get() 2 values (checking 1 of 2)");
+ is($age, 38, "get() 2 values (checking 2 of 2)");
+}
+
+{
+ my $obj = $rep->get_object("test_person", 2);
+ isa_ok($obj, "App::Moose::RepositoryObject::Woman", "susan");
+}
+
+{
+ my $objs = $rep->get_objects("test_person", {}, undef, {order_by =>
"person_id"});
+ is($objs->[0]{_key}, 1, "get_objects() automatically set the _key");
+ isa_ok($objs->[0], "App::Moose::RepositoryObject", "by get_objects(),
stephen");
+ isa_ok($objs->[1], "App::Moose::RepositoryObject::Woman", "by
get_objects(), susan");
+}
+
+{
+ my $obj = $rep->get_object("test_person", {}, undef, {order_by =>
"person_id"});
+ is($obj->{_key}, 1, "get_object() automatically set the _key");
+}
+
+{
+ ok($rep->set_row("test_person", {first_name=>'paul'}, ["age", "state"],
[5, "CA"]),"set_row() 2 values w/ %crit");
+ my $obj = $rep->get_object("test_person", {first_name=>'paul'}, ["age",
"state","person_id"]);
+ is($obj->{age}, 5, "get_object() 3 values w/ %crit (checking 1 of
3)");
+ is($obj->{state}, "CA", "get_object() 3 values w/ %crit (checking 2 of
3)");
+ is($obj->{person_id}, 4, "get_object() 3 values w/ %crit (checking 3 of
3)");
+}
+
+{
+ my $obj = $rep->get_object("test_person", 1);
+ is($obj->{_key}, 1, "get_object() by key");
+
+ my $retval = $obj->delete();
+ ok($retval, "delete() seems to have worked");
+
+ my $obj2 = $rep->get_object("test_person", 1);
+ ok(! defined $obj2, "delete() yep, it's really gone");
+
+ $obj2 = $rep->new_object("test_person", $obj);
+ is($obj2->{first_name},$obj->{first_name}, "new.first_name seems ok");
+ is($obj2->{age},$obj->{age}, "new.age seems ok");
+ is($obj2->{_key},$obj->{_key}, "new._key seems ok");
+
+ my $obj3 = $rep->get_object("test_person", 1);
+ ok(defined $obj2, "new() it's back");
+ is($obj3->{first_name},$obj->{first_name}, "new.first_name seems ok");
+ is($obj3->{age},$obj->{age}, "new.age seems ok");
+ is($obj3->{_key},$obj->{_key}, "new._key seems ok");
+
+ my $obj4 = $rep->new_object("test_person",{first_name => "christine",
gender => "F"});
+ is($obj4->{first_name},"christine", "new.first_name (2) seems ok");
+ is($obj4->{_key},8, "new._key is ok");
+ is($obj4->{person_id},8, "new.person_id is ok");
+ isa_ok($obj4, "App::Moose::RepositoryObject::Woman", "by new_object(),
christine");
+
+ $obj = { city_cd => "BOS", city_nm => "Boston" };
+ $obj2 = $rep->new_object("test_city", $obj);
+ isa_ok($obj2, "App::Moose::RepositoryObject", "new_object(city,{BOS})");
+ is($obj2->{city_cd},$obj->{city_cd}, "new_object(city,{BOS}).city_cd
= [$obj->{city_cd}]");
+ is($obj2->{_repository}{name}, "default",
"new_object(city,{BOS})._repository = [default]");
+ is($obj2->{_table}, "test_city", "new_object(city,{BOS})._table =
[$obj2->{_table}]");
+ is($obj2->{_key}, $obj->{city_cd}, "new_object(city,{BOS})._key =
[$obj2->{_key}]");
+ my $json = "{'_key' : 'BOS', '_repository' : 'default', '_table' :
'test_city', 'arp_nm' : null, 'city_cd' : 'BOS', 'city_nm' : 'Boston',
'country' : null, 'state' : null}";
+ is($obj2->TO_JSON(), $json, "new_object(city,{BOS}).TO_JSON = [{...}]");
+ $nrows = $obj2->set("arp_nm", "Logan Airport");
+ is($nrows, 1, "obj(city)->set(col, value): works");
+ $obj3 = $rep->get_object("test_city", "BOS");
+ is($obj3->{arp_nm},"Logan Airport", "obj(city).arp_nm = [Logan Airport]");
+
+ $obj = { city_cd => "BOS", person_id => undef };
+ eval {
+ $obj2 = $rep->new_object("test_visit", $obj);
+ };
+ ok(($@ ? 1 : 0), "new_object(visit) correctly failed when insufficient
initial values given");
+ $obj = { city_cd => "BOS", person_id => 1, visit_dt => "1980-08-30" };
+ eval {
+ $obj2 = $rep->new_object("test_visit", $obj);
+ };
+ ok(($@ ? 1 : 0), "new_object(visit) correctly failed when primary key
violated");
+ $obj = { city_cd => "BOS", person_id => 1, visit_dt => "1980-08-31",
occasion => "back again" };
+ $obj2 = $rep->new_object("test_visit", $obj);
+ isa_ok($obj2, "App::Moose::RepositoryObject", "new_object(visit)");
+ is($obj2->{city_cd}, $obj->{city_cd}, "new_object(visit).city_cd =
[$obj->{city_cd}]");
+ is($obj2->{person_id}, $obj->{person_id}, "new_object(visit).person_id =
[$obj->{person_id}]");
+ is($obj2->{visit_dt}, $obj->{visit_dt}, "new_object(visit).visit_dt =
[$obj->{visit_dt}]");
+ is($obj2->{occasion}, $obj->{occasion}, "new_object(visit).occasion =
[$obj->{occasion}]");
+ $nrows = $obj2->set(["occasion"], ["woke up in the morning"]);
+ is($nrows, 1, "obj(visit)->set(col, value): works");
+ $obj3 = $rep->get_object("test_visit", "BOS,1,1980-08-31");
+ is($obj3->{occasion},"woke up in the morning", "obj(visit).occasion
successfully changed");
+}
+
+{
+ # This is experimental. It should not be accepted as part of the official
API yet.
+ # In other words... Use the constructors on App::Repository, not the new()
constructor on the class.
+ my $obj = App::Moose::RepositoryObject->new(_table => "test_person", _key
=> 1);
+ isa_ok($obj, "App::Moose::RepositoryObject", "non-factory constructor
works");
+ is($obj->{_key}, 1, "new() sets the _key");
+}
+
+{
+ &drop_table($rep, "test_person");
+ &drop_table($rep, "test_visit");
+ &drop_table($rep, "test_city");
+}
+
+exit 0;
+
Added: p5ee/trunk/App-Moose/t/RepositoryTestUtils.pm
==============================================================================
--- (empty file)
+++ p5ee/trunk/App-Moose/t/RepositoryTestUtils.pm Tue Jun 22 20:50:54 2010
@@ -0,0 +1,477 @@
+
+#############################################################################
+# $Id: HotelUtils.pm 25141 2008-08-19 15:38:16Z asawczyn $
+#############################################################################
+
+package RepositoryTestUtils;
+
+use strict;
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
+
+require Exporter;
+
+...@isa = qw(Exporter);
+
+...@export = qw(
+);
+
+...@export_ok = qw(
+ create_table_test_person
+ drop_table_test_person
+ populate_table_test_person
+ create_table_test_app_cache
+ drop_table_test_app_cache
+ create_table
+ drop_table
+ populate_table
+);
+
+use App;
+use App::Repository;
+
+sub create_table_test_person {
+ &App::sub_entry if ($App::trace);
+ my ($rep) = @_;
+ my $dbh = $rep->{dbh};
+
+ my ($ddl, $rc);
+ my $dbtype = $App::options{dbtype} || "mysql";
+
+ my $autoincrement = "";
+ my $suffix = "";
+ if ($dbtype eq "mysql") {
+ $autoincrement = " auto_increment";
+ $suffix = " ENGINE=InnoDB DEFAULT CHARSET=latin1";
+ }
+
+ my $double_type = ($dbtype eq "mysql") ? 'double' : 'float';
+ my $datetime_type = ($dbtype eq "mysql") ? 'datetime' : 'date';
+
+ $ddl = <<EOF;
+create table test_person (
+ person_id integer not null$autoincrement,
+ first_name varchar(99) null,
+ last_name varchar(99) null,
+ address varchar(99) null,
+ city varchar(99) null,
+ state varchar(99) null,
+ zip varchar(10) null,
+ country char(2) null,
+ city_cd varchar(5) null,
+ home_phone varchar(99) null,
+ work_phone varchar(99) null,
+ email_address varchar(99) null,
+ gender char(1) null,
+ birth_dt date null,
+ age integer null,
+ data blob null,
+ chess_rating float null,
+ modify_dttm timestamp null,
+ change_dttm $datetime_type null,
+ deci_col decimal null,
+ double_col $double_type null,
+ long_col long varchar null,
+ primary key (person_id)
+)$suffix
+EOF
+ print "DEBUG:\n$ddl\n" if ($App::options{debug_sql});
+ $rc = $dbh->do($ddl);
+ print "DEBUG: rc=[$rc] errstr=[$DBI::errstr]\n" if
($App::options{debug_sql});
+
+ $ddl = "create unique index test_person_ak1 on test_person (first_name,
state, gender)";
+ print "DEBUG:\n$ddl\n" if ($App::options{debug_sql});
+ $rc = $dbh->do($ddl);
+ print "DEBUG: rc=[$rc] errstr=[$DBI::errstr]\n" if
($App::options{debug_sql});
+
+ $ddl = "create index test_person_ie1 on test_person (last_name,
first_name)";
+ $dbh->do($ddl);
+ if ($dbtype eq "oracle") {
+ $ddl = <<EOF;
+create sequence test_person_seq start with 1 increment by 1 nomaxvalue nocycle
cache 200
+EOF
+ $dbh->do($ddl);
+ $ddl = <<EOF;
+CREATE OR REPLACE TRIGGER tib_test_person
+BEFORE INSERT ON test_person
+FOR EACH ROW
+WHEN (new.person_id IS NULL or new.person_id = 0)
+BEGIN
+ SELECT test_person_seq.NEXTVAL
+ INTO :new.person_id
+ FROM DUAL;
+END tib_test_person;
+EOF
+ $dbh->do($ddl);
+ }
+
+ &App::sub_exit() if ($App::trace);
+}
+
+sub drop_table_test_person {
+ &App::sub_entry if ($App::trace);
+ my ($rep) = @_;
+ my $dbh = $rep->{dbh};
+
+ my $dbtype = $App::options{dbtype} || "mysql";
+
+ print "DEBUG:\ndrop table test_person\n" if ($App::options{debug_sql});
+ my ($rc);
+ eval { $dbh->do("drop table test_person"); };
+ print "DEBUG: rc=[$rc] errstr=[$DBI::errstr]\n" if
($App::options{debug_sql});
+ #warn $@ if ($@);
+ if ($dbtype eq "oracle") {
+ eval { $dbh->do("drop sequence test_person_seq"); };
+ }
+
+ &App::sub_exit() if ($App::trace);
+}
+
+sub populate_table_test_person {
+ &App::sub_entry if ($App::trace);
+ my ($rep) = @_;
+ my $dbh = $rep->{dbh};
+ $dbh->do("insert into test_person (age,first_name,gender,state) values
(39,'stephen', 'M','GA')");
+ $dbh->do("insert into test_person (age,first_name,gender,state) values
(37,'susan', 'F','GA')");
+ $dbh->do("insert into test_person (age,first_name,gender,state) values (
6,'maryalice','F','GA')");
+ $dbh->do("insert into test_person (age,first_name,gender,state) values (
3,'paul', 'M','GA')");
+ $dbh->do("insert into test_person (age,first_name,gender,state) values (
1,'christine','F','GA')");
+ $dbh->do("insert into test_person (age,first_name,gender,state) values
(45,'tim', 'M','GA')");
+ $dbh->do("insert into test_person (age,first_name,gender,state) values
(39,'keith', 'M','GA')");
+ &App::sub_exit() if ($App::trace);
+}
+
+sub create_table_test_app_cache {
+ my ($rep) = @_;
+ my $dbh = $rep->{dbh};
+ my $dbtype = $App::options{dbtype} || "mysql";
+
+ my $suffix = "";
+ my $CURRENT_TIMESTAMP = "";
+ my $datetime = "date";
+ my $longblob = "blob";
+ if ($dbtype eq "mysql") {
+ $suffix = "ENGINE=InnoDB DEFAULT CHARSET=latin1";
+ $CURRENT_TIMESTAMP = "default CURRENT_TIMESTAMP on update
CURRENT_TIMESTAMP";
+ $datetime = "datetime";
+ $longblob = "longblob";
+ }
+
+ eval { $dbh->do("drop table test_app_cache"); };
+ my $ddl = <<EOF;
+create table test_app_cache (
+ cache_type varchar(16) not null,
+ cache_key varchar(40) not null,
+ generate_dttm $datetime default null,
+ serializer varchar(12) default null,
+ serialization_args varchar(64) default null,
+ data $longblob,
+ modify_dttm timestamp not null $CURRENT_TIMESTAMP,
+ primary key (cache_type,cache_key)
+) $suffix
+EOF
+ $dbh->do($ddl);
+ $ddl = "create index test_app_cache_ie1 on test_app_cache (modify_dttm)";
+ $dbh->do($ddl);
+
+ if ($dbtype eq 'oracle') {
+ $ddl = <<EOF;
+CREATE OR REPLACE TRIGGER tib_test_app_cache
+BEFORE INSERT ON test_app_cache
+FOR EACH ROW
+WHEN (new.modify_dttm IS NULL)
+BEGIN
+ SELECT sysdate
+ INTO :new.modify_dttm
+ FROM DUAL;
+END tib_test_app_cache;
+EOF
+ $dbh->do($ddl);
+ }
+}
+
+sub drop_table_test_app_cache {
+ &App::sub_entry if ($App::trace);
+ my ($rep) = @_;
+ my $dbh = $rep->{dbh};
+ my $dbtype = $App::options{dbtype} || "mysql";
+ eval { $dbh->do("drop table test_app_cache"); };
+ &App::sub_exit() if ($App::trace);
+}
+
+######################################################################################################
+# GENERIC DATABASE TABLE GENERATION
+######################################################################################################
+
+my (%table_schema, %table_index, %table_autoid_column, %table_data);
+
+$table_schema{test_person} = <<EOF;
+create table test_person (
+ person_id integer not null AUTOINCREMENT,
+ first_name varchar(99) null,
+ last_name varchar(99) null,
+ address varchar(99) null,
+ city varchar(99) null,
+ state varchar(99) null,
+ zip varchar(10) null,
+ country char(2) null,
+ city_cd varchar(5) null,
+ home_phone varchar(99) null,
+ work_phone varchar(99) null,
+ email_address varchar(99) null,
+ gender char(1) null,
+ birth_dt date null,
+ age integer null,
+ data blob null,
+ chess_rating float null,
+ modify_dttm timestamp null,
+ change_dttm DATETIME null,
+ deci_col decimal null,
+ double_col DOUBLE null,
+ long_col long varchar null,
+ primary key (person_id)
+)SUFFIX
+EOF
+$table_index{test_person} = [
+ "create unique index test_person_ak1 on test_person (first_name, state,
gender)",
+ "create index test_person_ie1 on test_person (last_name, first_name)",
+];
+$table_autoid_column{test_person} = "person_id";
+$table_data{test_person} = [
+ "insert into test_person (age,first_name,gender,state,country) values
(39,'stephen', 'M','GA','US')",
+ "insert into test_person (age,first_name,gender,state,country) values
(37,'susan', 'F','GA','US')",
+ "insert into test_person (age,first_name,gender,state,country) values (
6,'maryalice','F','GA','US')",
+ "insert into test_person (age,first_name,gender,state,country) values (
3,'paul', 'M','GA','US')",
+ "insert into test_person (age,first_name,gender,state,country) values (
1,'christine','F','GA','US')",
+ "insert into test_person (age,first_name,gender,state,country) values
(45,'tim', 'M','GA','US')",
+ "insert into test_person (age,first_name,gender,state,country) values
(39,'keith', 'M','GA','US')",
+];
+
+$table_schema{test_country} = <<EOF;
+create table test_country (
+ country_id integer not null AUTOINCREMENT,
+ country char(2) not null,
+ country_nm varchar(64) not null,
+ primary key (country_id)
+)SUFFIX
+EOF
+$table_index{test_country} = [
+ "create index test_country_ie1 on test_country (country)",
+ "create index test_country_ie2 on test_country (country_nm)",
+];
+$table_autoid_column{test_country} = "country_id";
+$table_data{test_country} = [
+ "insert into test_country (country, country_nm) values ('AU','AUSTRALIA')",
+ "insert into test_country (country, country_nm) values ('BR','BRAZIL')",
+ "insert into test_country (country, country_nm) values ('CN','CHINA')",
+ "insert into test_country (country, country_nm) values ('DE','GERMANY')",
+ "insert into test_country (country, country_nm) values ('ES','SPAIN')",
+ "insert into test_country (country, country_nm) values ('FR','FRANCE')",
+ "insert into test_country (country, country_nm) values ('GB','UNITED
KINGDOM')",
+ "insert into test_country (country, country_nm) values ('IT','ITALY')",
+ "insert into test_country (country, country_nm) values ('JP','JAPAN')",
+ "insert into test_country (country, country_nm) values ('MX','MEXICO')",
+ "insert into test_country (country, country_nm) values ('RU','RUSSIAN
FEDERATION')",
+ "insert into test_country (country, country_nm) values ('US','UNITED
STATES')",
+ "insert into test_country (country, country_nm) values ('ZA','SOUTH
AFRICA')",
+];
+
+$table_schema{test_city} = <<EOF;
+create table test_city (
+ city_cd char(3) not null,
+ state char(2) null,
+ country char(2) null,
+ city_nm varchar(99) not null,
+ arp_nm varchar(99) null,
+ primary key (city_cd)
+)SUFFIX
+EOF
+$table_index{test_city} = [
+ "create index test_city_ie1 on test_city (city_nm)",
+ "create index test_city_ie2 on test_city (state)",
+ "create index test_city_ie3 on test_city (country)",
+];
+$table_data{test_city} = [
+ "insert into test_city values ('ATL', 'GA', 'US', 'Atlanta',
'William B. Hartsfield International Airport')",
+ "insert into test_city values ('CDG', '', 'FR', 'Paris',
'Roissy Ch. de Gaulle')",
+ "insert into test_city values ('DFW', 'TX', 'US', 'Dallas/Fort Worth',
'Dallas/Fort Worth Int''l')",
+ "insert into test_city values ('EWR', 'NJ', 'US', 'Newark',
'Newark International Airport')",
+ "insert into test_city values ('FCO', '', 'IT', 'Roma',
'Leonardo da Vinci/Fiumicino')",
+ "insert into test_city values ('HKG', '', 'CN', 'Hong Kong',
'Chek Lap Kok International Airport')",
+ "insert into test_city values ('HND', '', 'JP', 'Tokyo',
'Haneda')",
+ "insert into test_city values ('IAD', 'DC', 'US', 'Washington',
'Washington Dulles Int''l Airport')",
+ "insert into test_city values ('JFK', 'NY', 'US', 'New York',
'John F. Kennedy International Airport')",
+ "insert into test_city values ('JNB', '', 'ZA', 'Johannesburg',
'Johannesburg International Airport')",
+ "insert into test_city values ('LAX', 'CA', 'US', 'Los Angeles',
'Los Angeles International Airport')",
+ "insert into test_city values ('LGA', 'NY', 'US', 'New York', 'La
Guardia Airport')",
+ "insert into test_city values ('LGW', '', 'GB', 'London',
'Gatwick Airport')",
+ "insert into test_city values ('MAD', '', 'ES', 'Madrid',
'Barajas')",
+ "insert into test_city values ('MDW', 'IL', 'US', 'Chicago',
'Chicago Midway Airport')",
+ "insert into test_city values ('MEX', '', 'MX', 'Mexico City',
'Benito Juarez International')",
+ "insert into test_city values ('NRT', '', 'JP', 'Tokyo',
'Narita')",
+ "insert into test_city values ('ORD', 'IL', 'US', 'Chicago',
'Chicago-O''Hare International Airport')",
+ "insert into test_city values ('SDU', 'RJ', 'BR', 'Rio de Janeiro',
'Aeroporto Santos Dumont')",
+ "insert into test_city values ('SVO', '', 'RU', 'Moscow',
'Sheremetyevo')",
+ "insert into test_city values ('SXF', '', 'DE', 'Berlin',
'Schoenefeld')",
+ "insert into test_city values ('SYD', '', 'AU', 'Sydney',
'Kingsford Smith')",
+ "insert into test_city values ('THF', '', 'DE', 'Berlin',
'Tempelhof')",
+ "insert into test_city values ('TXL', '', 'DE', 'Berlin',
'Tegel')",
+];
+
+$table_schema{test_visit} = <<EOF;
+create table test_visit (
+ city_cd char(3) not null,
+ person_id integer not null,
+ visit_dt date not null,
+ occasion varchar(99) null,
+ primary key (city_cd, person_id, visit_dt)
+)SUFFIX
+EOF
+$table_data{test_visit} = [
+ "insert into test_visit values ('LAX', 1, '1962-11-09', 'Born')",
+ "insert into test_visit values ('BOS', 1, '1980-08-30', 'College')",
+ "insert into test_visit values ('JNB', 1, '1986-10-20', 'Mission Trip')",
+ "insert into test_visit values ('WAS', 1, '1991-08-20', 'Back to
college')",
+ "insert into test_visit values ('ATL', 1, '1993-06-01', 'Move after
graduation')",
+];
+
+$table_schema{test_hotel_prop} = <<EOF;
+create table test_hotel_prop (
+ prop_id integer not null AUTOINCREMENT,
+ prop_cd char(12) not null,
+ prop_nm varchar(99) not null,
+ address varchar(255) null,
+ chain_cd char(2) null,
+ state char(2) null,
+ country char(2) null,
+ primary key (prop_id)
+)SUFFIX
+EOF
+$table_index{test_hotel_prop} = [
+ "create unique index test_hotel_prop_ak1 on test_hotel_prop (prop_cd)",
+];
+$table_autoid_column{test_hotel_prop} = "prop_id";
+$table_data{test_hotel_prop} = [
+ "insert into test_hotel_prop
(prop_cd,prop_nm,address,chain_cd,state,country) values ('9128' ,'Hilton New
York' ,'1335 Avenue Of The Americas, New York, NY
10019','HH','NY','US')",
+ "insert into test_hotel_prop
(prop_cd,prop_nm,address,chain_cd,state,country) values ('13111','Marriott
Marquis NYC' ,'1535 BROADWAY, New York, NY 10036'
,'MC','NY','US')",
+ "insert into test_hotel_prop
(prop_cd,prop_nm,address,chain_cd,state,country) values ('668' ,'Sheraton New
York Hotel&Towers','811 7th Ave, New York, NY 10019'
,'SI','NY','US')",
+ "insert into test_hotel_prop
(prop_cd,prop_nm,address,chain_cd,state,country) values ('3391' ,'Crowne Plaza
Time Sq Manhattan','1605 Broadway, Manhattan, NY 10019'
,'CP','NY','US')",
+ "insert into test_hotel_prop
(prop_cd,prop_nm,address,chain_cd,state,country) values ('962' ,'Grand Hyatt
New York' ,'Park Ave At Grand Central, New York, NY 10017'
,'HY','NY','US')",
+];
+
+$table_schema{test_hotel_bkg} = <<EOF;
+create table test_hotel_bkg (
+ bkg_id integer not null AUTOINCREMENT,
+ conf_num varchar(24) not null,
+ bkg_dt date not null,
+ person_id integer not null,
+ prop_id integer not null,
+ arv_dt date not null,
+ dpt_dt date not null,
+ cancel_dt date null,
+ rooms integer not null,
+ rev_amt_usd float not null,
+ primary key (bkg_id)
+)SUFFIX
+EOF
+$table_index{test_hotel_bkg} = [
+ "create unique index test_hotel_bkg_ak1 on test_hotel_bkg (conf_num,
bkg_dt)",
+];
+$table_autoid_column{test_hotel_bkg} = "bkg_id";
+$table_data{test_hotel_bkg} = [
+ "insert into test_hotel_bkg values
(null,'AAA001','2008-11-01',1,1,'2008-12-01','2008-12-04',null,1,300)",
+];
+
+sub create_table {
+ &App::sub_entry if ($App::trace);
+ my ($rep, $table) = @_;
+ my $dbh = $rep->{dbh};
+
+ my $ddl = $table_schema{$table} || die "Schema not defined for table
[$table]\n";
+ my $dbtype = $App::options{dbtype} || "mysql";
+
+ my $autoincrement = "";
+ my $suffix = "";
+ if ($dbtype eq "mysql") {
+ $autoincrement = " auto_increment";
+ $suffix = " ENGINE=InnoDB DEFAULT CHARSET=latin1";
+ }
+
+ my $double_type = ($dbtype eq "mysql") ? 'double' : 'float';
+ my $datetime_type = ($dbtype eq "mysql") ? 'datetime' : 'date';
+
+ $ddl =~ s/AUTOINCREMENT/$autoincrement/g;
+ $ddl =~ s/SUFFIX/$suffix/g;
+ $ddl =~ s/DOUBLE/$double_type/g;
+ $ddl =~ s/DATETIME/$datetime_type/g;
+ if ($dbtype eq "oracle") {
+ $ddl =~ s/varchar\(/varchar2\(/ig;
+ }
+ print "DEBUG:\n$ddl\n" if ($App::options{debug_sql});
+ my $rc = $dbh->do($ddl);
+ print "DEBUG: rc=[$rc] errstr=[$DBI::errstr]\n" if
($App::options{debug_sql});
+
+ my $ddls = $table_index{$table};
+ if ($ddls) {
+ foreach $ddl (@$ddls) {
+ $dbh->do($ddl);
+ }
+ }
+
+ my ($autoid_column);
+ if ($dbtype eq "oracle") {
+ $autoid_column = $table_autoid_column{$table};
+ if ($autoid_column) {
+ $ddl = <<EOF;
+create sequence ${table}_seq start with 1 increment by 1 nomaxvalue nocycle
cache 200
+EOF
+ $dbh->do($ddl);
+ $ddl = <<EOF;
+CREATE OR REPLACE TRIGGER tib_$table
+BEFORE INSERT ON $table
+FOR EACH ROW
+WHEN (new.$autoid_column IS NULL or new.$autoid_column = 0)
+BEGIN
+ SELECT ${table}_seq.NEXTVAL
+ INTO :new.$autoid_column
+ FROM DUAL;
+END tib_${table};
+EOF
+ $dbh->do($ddl);
+ }
+ }
+
+ &App::sub_exit() if ($App::trace);
+}
+
+sub drop_table {
+ &App::sub_entry if ($App::trace);
+ my ($rep, $table) = @_;
+ my $dbh = $rep->{dbh};
+
+ my $dbtype = $App::options{dbtype} || "mysql";
+
+ print "DEBUG:\ndrop table $table\n" if ($App::options{debug_sql});
+ my ($rc);
+ eval { $rc = $dbh->do("drop table $table"); };
+ print "DEBUG: rc=[$rc] errstr=[$DBI::errstr]\n" if
($App::options{debug_sql});
+ if ($dbtype eq "oracle") {
+ eval { $dbh->do("drop sequence ${table}_seq"); };
+ }
+
+ &App::sub_exit() if ($App::trace);
+}
+
+sub populate_table {
+ &App::sub_entry if ($App::trace);
+ my ($rep, $table) = @_;
+ my $dbh = $rep->{dbh};
+ my $data = $table_data{$table};
+ if ($data) {
+ foreach my $sql (@$data) {
+ $dbh->do($sql);
+ }
+ }
+ &App::sub_exit() if ($App::trace);
+}
+
+1;
Added: p5ee/trunk/App-Moose/t/SessionObject.t
==============================================================================
--- (empty file)
+++ p5ee/trunk/App-Moose/t/SessionObject.t Tue Jun 22 20:50:54 2010
@@ -0,0 +1,136 @@
+#!/usr/bin/perl -w
+
+use strict;
+
+use App::Options (
+ options => [qw(dbdriver dbclass dbhost dbname dbuser dbpass)],
+ option => {
+ dbclass => { default => "App::Repository::MySQL", },
+ dbdriver => { default => "mysql", },
+ dbhost => { default => "localhost", },
+ dbname => { default => "test", },
+ dbuser => { default => "", },
+ dbpass => { default => "", },
+ },
+);
+
+use Test::More qw(no_plan);
+use lib "../App-Context/lib";
+use lib "../../App-Context/lib";
+use lib "lib";
+use lib "../lib";
+use lib ".";
+use lib "t";
+
+use App;
+
+my ($context);
+
+$context = App->context(
+ conf_file => "",
+ sessionobject_class => $App::options{sessionobject_class},
+);
+
+sub verify_session_object {
+ my ($obj, $name, $stateless, $anonymous, $lang) = @_;
+ my $obj_name = $obj->{name};
+ if (!$obj_name) {
+ ok($obj_name, "object has a name [$obj_name]");
+ }
+ else {
+ is($obj->get("context"), $context, "[$name]->{context}
[$context] is set (accessible with get())");
+ is($obj->context, $context, "[$name]->{context}
[$context] is set (accessible with accessor)");
+ is($obj->{context}, $context, "[$name]->{context}
[$context] is set (accessible directly)");
+ is($obj->get("name"), $name, "[$name]->{name} [$name]
is set (accessible with get())");
+ is($obj->name, $name, "[$name]->{name} [$name]
is set (accessible with accessor)");
+ is($obj->{name}, $name, "[$name]->{name} [$name]
is set (accessible directly)");
+ is($obj->get("stateless"), $stateless, "[$name]->{stateless}
[$stateless] is set (accessible with get())");
+ is($obj->stateless, $stateless, "[$name]->{stateless}
[$stateless] is set (accessible with accessor)");
+ is($obj->{stateless}, $stateless, "[$name]->{stateless}
[$stateless] is set (accessible directly)");
+ is($obj->get("anonymous"), $anonymous, "[$name]->{anonymous}
[$anonymous] is set (accessible with get())");
+ is($obj->anonymous, $anonymous, "[$name]->{anonymous}
[$anonymous] is set (accessible with accessor)");
+ is($obj->{anonymous}, $anonymous, "[$name]->{anonymous}
[$anonymous] is set (accessible directly)");
+ is($obj->get("lang"), $lang, "[$name]->{lang} [$lang]
is set (accessible with get())");
+ is($obj->lang, $lang, "[$name]->{lang} [$lang]
is set (accessible with accessor)");
+ is($obj->{lang}, $lang, "[$name]->{lang} [$lang]
is set (accessible directly)");
+ }
+}
+
+{
+ my $session_object = $context->service("SessionObject");
+
+ my $options = $context->{options};
+ my $session_store = $context->{session}{store};
+ my $session_cache = $context->{session}{cache};
+
+ ok(defined $session_object, "[default] constructor ok");
+ isa_ok($session_object, "App::Moose::SessionObject", "[default] right
class");
+ is($session_object->service_type(), "SessionObject", "[default] right
service type");
+ my $dump = $session_object->dump(1);
+ ok($dump =~ /^\$VAR1 = bless.*App::Moose::SessionObject/s, "dump formatted
ok"); # NOTE: a Moose dump() is a slightly different format from an
App::Service dump()
+ #print STDERR $dump;
+ &verify_session_object($session_object, "default", 0, 0, "en");
+
+ is($session_cache->{SessionObject}{default}, $session_object, "Object is
stored in the session cache [$session_cache->{SessionObject}{default} =
$session_object]");
+ my $so2 = $context->session_object();
+ is($so2, $session_object, "Second attempt gets the same object [$so2 =
$session_object]");
+
+ $so2->set("foo","bar");
+ is($session_object->get("foo"), "bar", "Got value on one object which was
set on another");
+ is($context->so_get("foo"), "bar", "Got same value from the Context");
+ # NOTE: The following two cases are INTERNAL (not part of the published
API)
+ is($session_cache->{SessionObject}{default}{foo}, "bar", "Got same value
from the internal cache of the Context");
+ is($session_store->{SessionObject}{default}{foo}, "bar", "Got same value
from the internal store of the Context");
+
+ my ($foo2);
+ $so2->set("{foo2}{subfoo}","bar");
+ is($session_object->get("{foo2}{subfoo}"), "bar", "Got deep value on one
object which was set on another");
+ $foo2 = $session_object->get("foo2");
+ is($foo2->{subfoo}, "bar", "Got same deep value from the object in two
steps");
+ is($context->so_get("{foo2}{subfoo}"), "bar", "Got same deep value from
the Context");
+ is($context->so_get("default", "{foo2}{subfoo}"), "bar", "Got same deep
value from the Context (using name and attribute)");
+ $foo2 = $context->so_get("foo2");
+ is($foo2->{subfoo}, "bar", "Got same deep value from the Context in two
steps");
+ # NOTE: The following two cases are INTERNAL (not part of the published
API)
+ is($session_cache->{SessionObject}{default}{foo2}{subfoo}, "bar", "Got
same deep value from the internal cache of the Context");
+ is($session_store->{SessionObject}{default}{foo2}{subfoo}, "bar", "Got
same deep value from the internal store of the Context");
+
+ # An anonymous SessionObject for a name that already exists
+ my $so_anon = $context->session_object("default", anonymous => 1, lang =>
"fr");
+ ok($so_anon ne $so2, "Anonymous default SessionObject [$so_anon] differs
from Stateful default SessionObject [$so2]");
+ &verify_session_object($so_anon, "default", 1, 1, "fr");
+ &verify_session_object($session_object, "default", 0, 0, "en");
+
+ # An anonymous SessionObject for a name that does not already exist
+ $so_anon = $context->session_object("anon", anonymous => 1);
+ &verify_session_object($so_anon, "anon", 1, 1, "en");
+ # NOTE: The following two cases are INTERNAL (not part of the published
API)
+ is($session_cache->{SessionObject}{anon}, undef, "Anonymous SessionObject
does not affect the internal cache of the Context");
+ is($session_store->{SessionObject}{anon}, undef, "Anonymous SessionObject
does not affect the internal store of the Context");
+ $so_anon->set("foo", "baz");
+ is($so_anon->{foo}, "baz", "Anonymous SessionObject set() works");
+ is($so_anon->get("foo"), "baz", "Anonymous SessionObject get() works");
+ is($session_cache->{SessionObject}{anon}, undef, "Anonymous SessionObject
still does not affect the internal cache of the Context");
+ is($session_store->{SessionObject}{anon}, undef, "Anonymous SessionObject
still does not affect the internal store of the Context");
+
+ # Another anonymous SessionObject for a name that does not already exist
+ my $so_anon2 = $context->session_object("anon", anonymous => 1);
+ &verify_session_object($so_anon2, "anon", 1, 1, "en");
+ ok($so_anon2 ne $so_anon, "Anonymous SessionObject [$so_anon2] differs
from earlier Anonymous SessionObject [$so_anon]");
+
+ # A stateless SessionObject
+ my $so_stateless = $context->session_object("state_less", stateless => 1,
foo => "bar");
+ &verify_session_object($so_stateless, "state_less", 1, 0, "en");
+ # NOTE: The following two cases are INTERNAL (not part of the published
API)
+ is($session_cache->{SessionObject}{state_less}, $so_stateless, "Stateless
SessionObject does affect the internal cache of the Context");
+ is($session_store->{SessionObject}{state_less}, undef, "Stateless
SessionObject does not affect the internal store of the Context");
+ is($so_stateless->{foo}, "bar", "Stateless SessionObject retains
unexpected initializers");
+ $so_stateless->set("foo", "baz");
+ is($so_stateless->{foo}, "baz", "Stateless SessionObject set() works");
+ is($so_stateless->get("foo"), "baz", "Stateless SessionObject get()
works");
+ is($session_cache->{SessionObject}{state_less}{foo}, "baz", "Stateless
SessionObject still does affect the internal cache of the Context");
+ is($session_store->{SessionObject}{state_less}, undef, "Stateless
SessionObject still does not affect the internal store of the Context");
+}
+
+exit 0;
+
Added: p5ee/trunk/App-Moose/t/app.conf.sample
==============================================================================
--- (empty file)
+++ p5ee/trunk/App-Moose/t/app.conf.sample Tue Jun 22 20:50:54 2010
@@ -0,0 +1,29 @@
+
+dbtype = mysql
+#dbtype = oracle
+
+sessionobject_class = App::Moose::SessionObject
+repositoryobject_class = App::Moose::RepositoryObject
+
+[dbtype=oracle]
+dbclass = App::Repository::Oracle
+dbhost = sampleoraclehost
+dbname = sampledb
+dbuser = scott
+dbpass = tiger
+dbschema = scott
+oracle_home = /usr/app/oracle/product/11.1.0/client
+ENV{ORACLE_HOME} = /usr/app/oracle/product/11.1.0/client
+
+[dbtype=mysql]
+dbclass = App::Repository::MySQL
+dbdriver = mysql
+dbhost = samplemysqlhost
+dbname = test
+dbuser = ralph
+dbpass = ocelot
+
+[ALL]
+flush_imports = 1
+prefix = $ENV{PREFIX}
+
