Author: spadkins
Date: Tue Jun 22 20:48:49 2010
New Revision: 14183
Modified:
p5ee/trunk/App-Context/CHANGES
p5ee/trunk/App-Context/MANIFEST
p5ee/trunk/App-Context/Makefile.PL
p5ee/trunk/App-Context/lib/App/Context.pm
p5ee/trunk/App-Context/lib/App/Serializer/Json.pm
p5ee/trunk/App-Context/lib/App/SessionObject.pm
p5ee/trunk/App-Repository/Makefile.PL
p5ee/trunk/App-Repository/lib/App/Repository.pm
p5ee/trunk/App-Repository/lib/App/RepositoryShell.pm
p5ee/trunk/App-Repository/t/DBI-getset-cache.t
p5ee/trunk/App-Repository/t/DBI-getset.t
p5ee/trunk/App-Repository/t/DBI-repobjects.t
p5ee/trunk/App-Repository/t/RepositoryTestUtils.pm
Log:
add Moose support
Modified: p5ee/trunk/App-Context/CHANGES
==============================================================================
--- p5ee/trunk/App-Context/CHANGES (original)
+++ p5ee/trunk/App-Context/CHANGES Tue Jun 22 20:48:49 2010
@@ -2,6 +2,11 @@
# CHANGE LOG
#########################################
+VERSION 0.968
+ x Did initial work to make App::Context::ModPerl work (full tested version
should come soon)
+ x introduced deprecated flag for services in the service() method
+ x keep the app.Request.keep_url_params on the form tag url
+
VERSION 0.967
x App::Request::CGI - added the url() method to support putting the URL
into the form tag in App::Widget
x App::Service - added get_sym_label() method for various uses in
turning a symbol into a label
Modified: p5ee/trunk/App-Context/MANIFEST
==============================================================================
--- p5ee/trunk/App-Context/MANIFEST (original)
+++ p5ee/trunk/App-Context/MANIFEST Tue Jun 22 20:48:49 2010
@@ -17,19 +17,25 @@
lib/App/Conf/File.pm
lib/App/Conf/File.pod
lib/App/Context.pm
+lib/App/Context/ClusterController.pm
+lib/App/Context/ClusterNode.pm
lib/App/Context/Cmd.pm
lib/App/Context/HTTP.pm
+lib/App/Context/ModPerl.pm
+lib/App/Context/NetServer.pm
lib/App/Context/POE.pm
-lib/App/Context/POE/Server.pm
lib/App/Context/POE/ClusterController.pm
lib/App/Context/POE/ClusterNode.pm
+lib/App/Context/POE/Server.pm
lib/App/Context/Server.pm
lib/App/datetime.pod
lib/App/devguide.pod
+lib/App/Documentation.pm
lib/App/Exceptions.pm
lib/App/exceptions.pod
lib/App/faq.pod
lib/App/installguide.pod
+lib/App/installguide.pod.ota
lib/App/installguide/hosted.pod
lib/App/installguide/win32.pod
lib/App/MessageDispatcher.pm
@@ -38,12 +44,18 @@
lib/App/Reference.pm
lib/App/Request.pm
lib/App/Request/CGI.pm
+lib/App/ResourceLocker.pm
+lib/App/ResourceLocker/IPCLocker.pm
+lib/App/ResourceLocker/IPCSemaphore.pm
lib/App/Response.pm
lib/App/Serializer.pm
+lib/App/Serializer/Html.pm
lib/App/Serializer/Ini.pm
+lib/App/Serializer/Json.pm
lib/App/Serializer/OneLine.pm
lib/App/Serializer/Perl.pm
lib/App/Serializer/Properties.pm
+lib/App/Serializer/Scalar.pm
lib/App/Serializer/Storable.pm
lib/App/Serializer/TextArray.pm
lib/App/Serializer/Xml.pm
@@ -58,7 +70,6 @@
lib/App/ValueDomain.pm
Makefile.PL
MANIFEST
-META.yml Module meta-data (added by MakeMaker)
README
t/app.ini
t/app.pl
Modified: p5ee/trunk/App-Context/Makefile.PL
==============================================================================
--- p5ee/trunk/App-Context/Makefile.PL (original)
+++ p5ee/trunk/App-Context/Makefile.PL Tue Jun 22 20:48:49 2010
@@ -16,7 +16,7 @@
%opts = (
"NAME" => "App-Context",
"DISTNAME" => "App-Context",
- "VERSION" => "0.967",
+ "VERSION" => "0.969",
"EXE_FILES" => [ @programs ],
"PREREQ_PM" => {
# "Apache" => "0.01", # used for mod_perl
integration
Modified: p5ee/trunk/App-Context/lib/App/Context.pm
==============================================================================
--- p5ee/trunk/App-Context/lib/App/Context.pm (original)
+++ p5ee/trunk/App-Context/lib/App/Context.pm Tue Jun 22 20:48:49 2010
@@ -558,11 +558,28 @@
$name = "default";
}
+ # A SessionObject can have three types:
+ # stateful - The object is named and its state is stored in the session.
This is the default.
+ # stateless - The object state is *NOT* stored in the session. The object
is named, so it is cached for the duration of the current process.
+ # anonymous - The object is not cached, so unless a reference to it is
maintained, its internal state is lost.
+ # Any SessionObject which is anonymous is effectively
stateless.
+ # Note: "anonymous" is a synonym for the older, deprecated
"temporary".
+
+ my $anonymous = 0;
+ my $stateless = 0;
+ if ($name eq "anonymous" || $args->{anonymous} || $name eq "temporary" ||
$args->{temporary}) {
+ $anonymous = 1;
+ $args->{anonymous} = 1;
+ $args->{stateless} = 1 if (!$args->{stateless});
+ }
+ elsif ($args->{stateless}) {
+ $stateless = 1;
+ }
+
$session = $self->{session};
- $service = $session->{cache}{$type}{$name}; # check the cache
+ $service = $session->{cache}{$type}{$name} if (!$anonymous); # check the
cache
$conf = $self->{conf};
$service_conf = $conf->{$type}{$name};
- my $temporary = ($name eq "temporary") || $args->{temporary};
my $service_initialized = ($service && ref($service) ne "HASH");
#print "$type($name): SERVICE=$service INIT=$service_initialized\n";
@@ -649,16 +666,16 @@
$new_service = 0;
- # NEVER DEFINED OR NON-BLESSED HASH (fully defined services are
blessed into classes)
- if ($temporary || !defined $service || ref($service) eq "HASH") {
+ # NEVER DEFINED OR NON-BLESSED HASH (fully defined services are blessed
into classes)
+ if ($anonymous || !defined $service || ref($service) eq "HASH") {
$service = {} if (!defined $service); # start with new hash ref
$service->{name} = $name;
$service->{context} = $self;
$service_store = $session->{store}{$type}{$name};
- if ($temporary) {
+ if ($anonymous) {
$service_store = undef;
- $service->{temporary} = 1;
+ $service->{anonymous} = 1;
}
if ($App::DEBUG && $self->dbg(6)) {
@@ -725,7 +742,7 @@
# This is really handy when you have something like a huge spreadsheet
# of text entry cells (usually an indexed variable).
- if ($temporary) { # may be specified implicitly
+ if ($stateless || $anonymous) { # may be
specified implicitly
$lightweight = 1;
}
elsif (defined $args->{lightweight}) { # may be specified explicitly
@@ -759,7 +776,7 @@
$self->dbgprint("Context->service() new service [$name]")
if ($App::DEBUG && $self->dbg(3));
- if (!$temporary && defined $service->{default}) {
+ if (!$stateless && !$anonymous && defined $service->{default}) {
$default = $service->{default};
if ($default =~ /^\{today\}\+?(-?[0-9]+)?$/) {
$default = time2str("%Y-%m-%d",time + 2*3600 + ($1 ?
($1*3600*24) : 0));
@@ -771,11 +788,12 @@
}
$class = $service->{class}; # find class of service
-
if (!defined $class || $class eq "") {
- $class = "App::$type"; # assume the "generic" class
+ my $default_class_option_var = lc($type) . "_class";
+ $class = $options->{$default_class_option_var} || "App::$type";
# assume the "generic" class
$service->{class} = $class;
}
+ my $constructor = ($class =~ /Moose/) ? "new" : undef; # TODO: I might
want to make this more general/configurable
if (! $self->{used}{$class}) { # load the code
App->use($class);
@@ -784,8 +802,19 @@
$self->dbgprint("Context->service() service class [$class]")
if ($App::DEBUG && $self->dbg(3));
- bless $service, $class; # bless the service into the class
- if (!$temporary) {
+ if ($constructor) {
+ my $constructed_service = $class->$constructor($service);
+ foreach my $attrib (keys %$service) {
+ if (! exists $constructed_service->{$attrib}) {
+ $constructed_service->{$attrib} = $service->{$attrib};
+ }
+ }
+ $service = $constructed_service;
+ }
+ else {
+ bless $service, $class; # bless the service into the class
+ }
+ if (!$anonymous) {
$session->{cache}{$type}{$name} = $service; # save in the cache
}
$service->_init(); # perform additional initializations
Modified: p5ee/trunk/App-Context/lib/App/Serializer/Json.pm
==============================================================================
--- p5ee/trunk/App-Context/lib/App/Serializer/Json.pm (original)
+++ p5ee/trunk/App-Context/lib/App/Serializer/Json.pm Tue Jun 22 20:48:49 2010
@@ -48,9 +48,9 @@
use JSON;
-use constant true => JSON::true;
+use constant true => JSON::true;
use constant false => JSON::false;
-use constant null => JSON::null;
+use constant null => JSON::null;
sub serialize {
&App::sub_entry if ($App::trace);
Modified: p5ee/trunk/App-Context/lib/App/SessionObject.pm
==============================================================================
--- p5ee/trunk/App-Context/lib/App/SessionObject.pm (original)
+++ p5ee/trunk/App-Context/lib/App/SessionObject.pm Tue Jun 22 20:48:49 2010
@@ -358,11 +358,16 @@
&App::sub_entry if ($App::trace);
my ($self, $value) = @_;
my $name = $self->{name};
- if ($name =~ /^(.+)\.([a-zA-Z][a-zA-Z0-9_]*)$/) {
- $self->{context}->so_set($1, $2, $value);
+ if ($self->{stateless}) {
+ $self->{_value} = $value;
}
else {
- $self->{context}->so_set("default", $name, $value);
+ if ($name =~ /^(.+)\.([a-zA-Z][a-zA-Z0-9_]*)$/) {
+ $self->{context}->so_set($1, $2, $value);
+ }
+ else {
+ $self->{context}->so_set("default", $name, $value);
+ }
}
&App::sub_exit() if ($App::trace);
}
@@ -386,7 +391,13 @@
sub get_value {
&App::sub_entry if ($App::trace);
my ($self, $default, $setdefault) = @_;
- my $value = $self->{context}->so_get($self->{name}, "", $default,
$setdefault);
+ my ($value);
+ if ($self->{stateless}) {
+ $value = $self->{_value};
+ }
+ else {
+ $value = $self->{context}->so_get($self->{name}, "", $default,
$setdefault);
+ }
&App::sub_exit($value) if ($App::trace);
return $value;
}
@@ -485,7 +496,12 @@
sub set {
&App::sub_entry if ($App::trace);
my ($self, $var, $value) = @_;
- $self->{context}->so_set($self->{name}, $var, $value);
+ if ($self->{stateless}) {
+ $self->{$var} = $value;
+ }
+ else {
+ $self->{context}->so_set($self->{name}, $var, $value);
+ }
&App::sub_exit() if ($App::trace);
}
@@ -514,7 +530,13 @@
sub get {
&App::sub_entry if ($App::trace);
my ($self, $var, $default, $setdefault) = @_;
- my $value = $self->{context}->so_get($self->{name}, $var, $default,
$setdefault);
+ my ($value);
+ if ($self->{stateless}) {
+ $value = $self->{$var};
+ }
+ else {
+ $value = $self->{context}->so_get($self->{name}, $var, $default,
$setdefault);
+ }
&App::sub_exit($value) if ($App::trace);
$value;
}
@@ -538,7 +560,14 @@
sub delete {
&App::sub_entry if ($App::trace);
my ($self, $var) = @_;
- my $result = $self->{context}->so_delete($self->{name}, $var);
+ my ($result);
+ if ($self->{stateless}) {
+ delete $self->{$var};
+ $result = 1;
+ }
+ else {
+ $result = $self->{context}->so_delete($self->{name}, $var);
+ }
&App::sub_exit($result) if ($App::trace);
$result;
}
@@ -563,7 +592,19 @@
sub set_default {
&App::sub_entry if ($App::trace);
my ($self, $var, $default) = @_;
- my $value = $self->{context}->so_get($self->{name}, $var, $default, 1);
+ my ($value);
+ if ($self->{stateless}) {
+ if (defined $self->{$var}) {
+ $value = $self->{$var};
+ }
+ else {
+ $self->{$var} = $default;
+ $value = $default;
+ }
+ }
+ else {
+ $value = $self->{context}->so_get($self->{name}, $var, $default, 1);
+ }
&App::sub_exit($value) if ($App::trace);
$value;
}
Modified: p5ee/trunk/App-Repository/Makefile.PL
==============================================================================
--- p5ee/trunk/App-Repository/Makefile.PL (original)
+++ p5ee/trunk/App-Repository/Makefile.PL Tue Jun 22 20:48:49 2010
@@ -16,13 +16,12 @@
%opts = (
'NAME' => 'App-Repository',
'DISTNAME' => 'App-Repository',
- 'VERSION' => '0.966',
+ 'VERSION' => '0.969',
'EXE_FILES' => [ @programs ],
'PREREQ_PM' => {
- 'App::Options' => 0, # core services
- 'App::Context' => 0, # core services
+ 'App::Options' => "0.01", # core services
+ 'App::Context' => "0.01", # core services
'DBI' => "0.01", # database access
- 'DBIx::Compat' => 0, # database compatibility
},
);
Modified: p5ee/trunk/App-Repository/lib/App/Repository.pm
==============================================================================
--- p5ee/trunk/App-Repository/lib/App/Repository.pm (original)
+++ p5ee/trunk/App-Repository/lib/App/Repository.pm Tue Jun 22 20:48:49 2010
@@ -662,7 +662,7 @@
$hash_options = undef if (! %$hash_options);
}
$hashkey = $sds->hashkey([$table, $params, $cols, $hash_options,
"row"]);
- $context->log("Cache Check: $table $hashkey (get_row)\n") if
($log_cache);
+ $context->log("Cache Check: $table $hashkey (get_row) :
cache_exception_on_miss=[$cache_exception_on_miss]\n") if ($log_cache);
if (!$cache_refresh) {
my $ref = $sds->get_ref($hashkey);
if (defined $ref) {
@@ -678,6 +678,7 @@
}
else { # missed the cache (no cache entry exists)
if ($cache_exception_on_miss) {
+ $context->log("Cache Miss: $table $hashkey (get_row)
: THROWING EXCEPTION\n") if ($log_cache);
die "CACHE-MISS:get_row($table)";
}
else {
@@ -981,7 +982,7 @@
$hash_options = undef if (! %$hash_options);
}
$hashkey = $sds->hashkey([$table, $params, $cols, $hash_options,
"rows"]);
- $context->log("Cache Check: $table $hashkey (get_rows)\n") if
($log_cache);
+ $context->log("Cache Check: $table $hashkey (get_rows) :
cache_exception_on_miss=[$cache_exception_on_miss]\n") if ($log_cache);
if (!$cache_refresh) {
my $ref = $sds->get_ref($hashkey);
if (defined $ref) {
@@ -997,6 +998,7 @@
}
else { # missed the cache (no cache entry exists)
if ($cache_exception_on_miss) {
+ $context->log("Cache Miss: $table $hashkey (get_rows)
: THROWING EXCEPTION\n") if ($log_cache);
die "CACHE-MISS:get_rows($table)";
}
else {
@@ -1036,8 +1038,35 @@
}
$cols = $new_cols; # then point to the new columns
regardless
}
+
+ my ($summary_table, $summary_column_defs,
$summary_repository_name);
+ #my $summary_tables = $table_def->{summary_tables};
+ #if ($summary_tables) {
+ # foreach my $summary_table_spec (@$summary_tables) {
+ # ($summary_table, $summary_column_defs,
$summary_repository_name) = @$summary_table_spec; # assume this summary will
work
+ # foreach $col (@$cols) {
+ # if (!$column_defs->{$col}{expr} &&
!$summary_columns_defs->{$col}) { # the column doesn't exist on the summary
table
+ # $summary_table = undef;
# so the summary won't work
+ # last;
+ # }
+ # }
+ # last if ($summary_table);
+ # }
+ #}
- $rows = $self->_get_rows($table, $params, $cols, $options);
+ if ($summary_table) {
+ if ($summary_repository_name) {
+ my $rep = $context->repository($summary_repository_name);
+ $rows = $rep->get_rows($summary_table, $params, $cols,
$options);
+ }
+ else {
+ $rows = $self->get_rows($summary_table, $params, $cols,
$options);
+ }
+ $summary_table = undef if ($#$rows == -1); # got no rows
+ }
+ if (!$summary_table) {
+ $rows = $self->_get_rows($table, $params, $cols, $options);
+ }
if ($contains_expr) {
$self->evaluate_expressions($table, $params, $cols, $rows,
$options);
@@ -1048,6 +1077,7 @@
$context->log("Cache Save: $table $hashkey (get_rows)\n") if
($log_cache);
}
}
+
if ($sds && $tabledef->{cache_minimum_columns}) {
my $requested_rows = [];
foreach my $row (@$rows) {
@@ -1374,14 +1404,18 @@
$object = $self->get_hash($table, $params, $cols, $options);
if ($object) {
- my $class = $table_def->{class} || "App::RepositoryObject";
+ my $context = $self->{context};
+ my $context_options = $context->{options};
+
+ my $class = $table_def->{class} ||
$context_options->{repositoryobject_class} || "App::RepositoryObject";
# if $class is an ARRAY ref, we need to examine the qualifier(s) to
determine the class
$class = $self->_get_qualified_class($class, $object) if (ref($class));
+ my $constructor = ($class =~ /Moose/) ? "new" : undef; # TODO: I might
want to make this more general/configurable
+
App->use($class);
$object->{_repository} = $self;
$object->{_table} = $table;
- bless $object, $class;
if (!ref($params)) {
$object->{_key} = $params;
}
@@ -1408,6 +1442,19 @@
$object->{_key} = $key if (defined $key);
}
}
+ if ($constructor) {
+ # Use what was going to be the object as a set of initializers to
the true constructor
+ my $constructed_object = $class->$constructor($object);
+ foreach my $attrib (keys %$object) {
+ if (! exists $constructed_object->{$attrib}) {
+ $constructed_object->{$attrib} = $object->{$attrib};
+ }
+ }
+ $object = $constructed_object;
+ }
+ else {
+ bless $object, $class;
+ }
}
&App::sub_exit($object) if ($App::trace);
return($object);
@@ -1449,17 +1496,22 @@
my $primary_key = $table_def->{primary_key};
$primary_key = [$primary_key] if (ref($primary_key) eq "");
my ($key, $class, %used);
- foreach my $object (@$objects) {
+ my ($object, $constructor, $constructed_object);
+ my $context_options = $self->{context}{options};
+ for (my $i = 0; $i <= $#$objects; $i++) {
+ $object = $objects->[$i];
$object->{_repository} = $self;
$object->{_table} = $table;
- $class = $table_def->{class} || "App::RepositoryObject";
+ $class = $table_def->{class} ||
$context_options->{repositoryobject_class} || "App::RepositoryObject";
# if $class is an ARRAY ref, we need to examine the qualifier(s) to
determine the class
$class = $self->_get_qualified_class($class, $object) if (ref($class));
+ $constructor = ($class =~ /Moose/) ? "new" : undef; # TODO: I might
want to make this more general/configurable
+
if (!$used{$class}) {
App->use($class);
$used{$class} = 1;
}
- bless $object, $class;
+
if ($primary_key) {
$key = undef;
foreach my $column (@$primary_key) {
@@ -1478,6 +1530,21 @@
}
$object->{_key} = $key if (defined $key);
}
+
+ if ($constructor) {
+ # Use what was going to be the object as a set of initializers to
the true constructor
+ $constructed_object = $class->$constructor($object);
+ # Then make sure that every attribute that was not set by the
constructor gets set
+ foreach my $attrib (keys %$object) {
+ if (! exists $constructed_object->{$attrib}) {
+ $constructed_object->{$attrib} = $object->{$attrib};
+ }
+ }
+ $objects->[$i] = $constructed_object;
+ }
+ else {
+ bless $object, $class;
+ }
}
&App::sub_exit($objects) if ($App::trace);
return($objects);
@@ -1500,7 +1567,10 @@
}
}
}
- $class ||= "App::RepositoryObject";
+ if (!$class) {
+ my $context_options = $self->{context}{options};
+ $class = $context_options->{repositoryobject_class} ||
"App::RepositoryObject";
+ }
&App::sub_exit($class) if ($App::trace);
return($class);
}
@@ -2164,17 +2234,33 @@
$object = {};
}
- my $class = $table_def->{class} || "App::RepositoryObject";
+ my $context_options = $self->{context}{options};
+ my $class = $table_def->{class} ||
$context_options->{repositoryobject_class} || "App::RepositoryObject";
# if $class is an ARRAY ref, we need to examine the qualifier(s) to
determine the class
$class = $self->_get_qualified_class($class, $object) if (ref($class));
+
App->use($class);
+
bless $object, $class;
$object->_init();
$self->_check_default_and_required_fields($object);
$options = $options ? { %$options } : {};
$options->{last_inserted_id} = 1;
- if (!$options->{temp}) {
+ if ($options->{temp}) {
+ my $constructor = ($class =~ /Moose/) ? "new" : undef; # TODO: I might
want to make this more general/configurable
+ if ($constructor) {
+ # Use what was going to be the object as a set of initializers to
the true constructor
+ my $constructed_object = $class->$constructor($object);
+ foreach my $attrib (keys %$object) {
+ if (! exists $constructed_object->{$attrib}) {
+ $constructed_object->{$attrib} = $object->{$attrib};
+ }
+ }
+ $object = $constructed_object;
+ }
+ }
+ else {
my $retval = $self->insert_row($table, $object, undef, $options);
die "new($table) unable to create a new row" if (!$retval);
my $params = $self->last_inserted_id($table);
Modified: p5ee/trunk/App-Repository/lib/App/RepositoryShell.pm
==============================================================================
--- p5ee/trunk/App-Repository/lib/App/RepositoryShell.pm (original)
+++ p5ee/trunk/App-Repository/lib/App/RepositoryShell.pm Tue Jun 22
20:48:49 2010
@@ -232,9 +232,18 @@
&App::sub_entry if ($App::trace);
my ($self, $command_entry) = @_;
my ($command);
+ my %command_alias = (
+ desc => "describe",
+ descr => "describe",
+ descri => "describe",
+ describ => "describe",
+ );
if ($command_entry =~ /^([a-zA-Z_\?]+)/) {
$command = lc($1);
}
+ if ($command_alias{$command}) {
+ $command = $command_alias{$command};
+ }
&App::sub_exit($command) if ($App::trace);
return($command);
}
@@ -294,14 +303,16 @@
elsif ($command eq "repository") {
$self->execute_repository_command($command_entry, $options);
}
+ elsif ($command eq "show") {
+ $self->execute_show_command($command_entry, $options);
+ }
+ elsif ($command eq "describe") {
+ $self->execute_describe_command($command_entry, $options);
+ }
elsif ($command eq "select") {
$self->execute_select_command($command_entry, $options);
$self->save_sql($command_entry);
}
- elsif ($direct_command{$command}) {
- $self->execute_direct_command($command_entry, $options);
- $self->save_sql($command_entry);
- }
elsif ($command eq "edit") {
$self->execute_edit_command($command_entry, $options);
$self->execute_run_command("run", $options);
@@ -321,6 +332,10 @@
elsif ($command eq "exit" || $command eq "quit" || $command eq "bye") {
$done = 1;
}
+ elsif ($command) {
+ $self->execute_direct_command($command_entry, $options);
+ $self->save_sql($command_entry);
+ }
else {
print "I don't know the '$command' command.\n";
print "Please try 'help' for help on the available commands and their
use\n";
@@ -506,15 +521,10 @@
if ($@) {
# [23480] 2009-03-10 23:48:55 DBI Exception (fail) in _do():
DBD::Oracle::db prepare failed: ORA-00942: table or view does not exist (DBD
ERROR: error possibly near <*> indicator at char 16 in 'select foo from
<*>boo') [for Statement "select foo from boo"] at
/usr/rubicon/spadkins/src/p5ee/App-Repository/lib/App/Repository/DBI.pm line
2556. select foo from booDBD::Oracle::db prepare failed: ORA-00942: table or
view does not exist (DBD ERROR: error possibly near <*> indicator at char 16 in
'select foo from <*>boo') [for Statement "select foo from boo"] at
/usr/rubicon/spadkins/src/p5ee/App-Repository/lib/App/Repository/DBI.pm line
2556.
my $e = $@;
- #print "EXCEPTION: [$e]\n";
$e =~ s/ at (\S+) line .*//;
- #print "EXCEPTION: (remove at*) [$e]\n";
$e =~ s/.* _do\(\): //;
- #print "EXCEPTION: (remove _do()*) [$e]\n";
$e =~ s/(\(DBD ERROR:)/\n$1/;
- #print "EXCEPTION: (newline before DBD ERROR) [$e]\n";
$e =~ s/(\[for Statement)/\n$1/;
- #print "EXCEPTION: (newline before for Statement) [$e]\n";
print $e;
}
else {
@@ -534,6 +544,64 @@
&App::sub_exit() if ($App::trace);
}
+sub execute_direct_command {
+ &App::sub_entry if ($App::trace);
+ my ($self, $command_entry, $options) = @_;
+ my $sql = $self->get_multiline_command_entry("sql", $command_entry, ";",
$options);
+ my $context = $self->{context};
+ my $db = $context->repository($self->{repository});
+ my $columns = [];
+ my $command = $self->get_command_from_command_entry($command_entry);
+ my $retval_str = ($command =~ /^(insert|update|delete)$/) ? "Rows
affected" : "Return Value";
+ my ($retval);
+ eval {
+ $retval = $db->_do($sql);
+ };
+ if ($@) {
+ # [23480] 2009-03-10 23:48:55 DBI Exception (fail) in _do():
DBD::Oracle::db prepare failed: ORA-00942: table or view does not exist (DBD
ERROR: error possibly near <*> indicator at char 16 in 'select foo from
<*>boo') [for Statement "select foo from boo"] at
/usr/rubicon/spadkins/src/p5ee/App-Repository/lib/App/Repository/DBI.pm line
2556. select foo from booDBD::Oracle::db prepare failed: ORA-00942: table or
view does not exist (DBD ERROR: error possibly near <*> indicator at char 16 in
'select foo from <*>boo') [for Statement "select foo from boo"] at
/usr/rubicon/spadkins/src/p5ee/App-Repository/lib/App/Repository/DBI.pm line
2556.
+ my $e = $@;
+ $e =~ s/ at (\S+) line .*//;
+ $e =~ s/.* _do\(\): //;
+ $e =~ s/(\(DBD ERROR:)/\n$1/;
+ $e =~ s/(\[for Statement)/\n$1/;
+ print $e;
+ }
+ else {
+ print "$retval_str: [$retval]\n";
+ }
+ $self->{last_command_entry} = $command_entry;
+ &App::sub_exit() if ($App::trace);
+}
+
+sub execute_show_command {
+ &App::sub_entry if ($App::trace);
+ my ($self, $command_entry, $options) = @_;
+ &App::sub_exit() if ($App::trace);
+}
+
+sub execute_describe_command {
+ &App::sub_entry if ($App::trace);
+ my ($self, $command_entry, $options) = @_;
+ if ($command_entry =~ /^\s*\S+\s+([a-zA-Z_][a-zA-Z_0-9\.]*)/s) {
+ my $table = lc($1);
+ my $context = $self->{context};
+ my $db = $context->repository($self->{repository});
+print "REPOSITORY: name=[$db->{name}] dbh=[$db->{dbh}] rep=[$db]\n";
+ my $table_def = $db->get_table_def($table);
+print "TABLEDEF[$table]: ", join("|", %$table_def), "\n";
+ my $column_defs = $table_def->{column};
+ my ($column_def);
+ foreach my $column (keys %$column_defs) {
+ $column_def = $column_defs->{$column};
+ print "$column: ", join("|", %$column_def), "\n";
+ }
+ }
+ else {
+ print "ERROR: I could not find the table name in that command
[$command_entry]\n";
+ }
+ &App::sub_exit() if ($App::trace);
+}
+
sub edit {
&App::sub_entry if ($App::trace);
my ($self, $command_entry) = @_;
Modified: p5ee/trunk/App-Repository/t/DBI-getset-cache.t
==============================================================================
--- p5ee/trunk/App-Repository/t/DBI-getset-cache.t (original)
+++ p5ee/trunk/App-Repository/t/DBI-getset-cache.t Tue Jun 22 20:48:49 2010
@@ -97,7 +97,7 @@
[ 7, 39, "keith", "M", "GA", ],
];
-my ($row, $data_rows, $data_rows2, $nrows);
+my ($row, $data_rows, $data_rows2, $nrows, $e);
#####################################################################
# $value = $rep->get ($table, $key, $col, \%options);
@@ -159,8 +159,47 @@
$first_name = $rep->get("test_person", 1, "first_name", { cache_skip => 1 });
is($first_name, "steve", "get() modified first_name [$first_name] by skipping
the cache");
-$data_rows = $rep->get_rows("test_person", {}, [ "person_id", "age",
"first_name", "gender", "state" ], {order_by=>["person_id"], cache_refresh =>
1});
+#####################################################################################################
+# Test cache_exception_on_miss logic
+#####################################################################################################
+$data_rows = undef;
+eval {
+ $data_rows = $rep->get_rows("test_person", {}, ["state"],
{order_by=>["person_id"], cache_exception_on_miss => 1, foo => 1});
+};
+$e = $@;
+chomp($e);
+ok($e && $e =~ /^CACHE-MISS:/, "get_rows() with cache_exception_on_miss (on
MISS): exception=[$e]" . ($data_rows ? " rows=[$data_rows]
maxidx=[$#$data_rows]" : ""));
+
+$data_rows = undef;
+eval {
+ $data_rows = $rep->get_rows("test_person", {}, ["state"],
{order_by=>["person_id"], cache_exception_on_miss => 1});
+};
+$e = $@;
+chomp($e);
+ok(!$e && $#$data_rows == 6, "get_rows() with cache_exception_on_miss (on HIT)
: exception=[$e]" . ($data_rows ? " rows=[$data_rows] maxidx=[$#$data_rows]" :
""));
+
+$first_name = undef;
+eval {
+ $first_name = $rep->get("test_person", {person_id => 1}, "first_name",
{cache_exception_on_miss => 1, foo => 1});
+};
+$e = $@;
+chomp($e);
+ok($e && $e =~ /^CACHE-MISS:/, "get_row() with cache_exception_on_miss (on
MISS): exception=[$e] first_name=[$first_name]");
+
+$first_name = undef;
+eval {
+ $first_name = $rep->get("test_person", {person_id => 1}, "first_name",
{cache_exception_on_miss => 1});
+};
+$e = $@;
+chomp($e);
+ok(!$e && $first_name eq "steve", "get_row() with cache_exception_on_miss (on
HIT) : exception=[$e] first_name=[$first_name]");
+
+#####################################################################################################
+# END OF TESTS
+#####################################################################################################
exit;
+
+$data_rows = $rep->get_rows("test_person", {}, [ "person_id", "age",
"first_name", "gender", "state" ], {order_by=>["person_id"], cache_refresh =>
1});
is_deeply($data_rows, $data_rows2, "get_rows() refreshed cached data thanks to
cache_refresh");
$first_name = $rep->get("test_person", 1, "first_name", { cache_refresh => 1
});
Modified: p5ee/trunk/App-Repository/t/DBI-getset.t
==============================================================================
--- p5ee/trunk/App-Repository/t/DBI-getset.t (original)
+++ p5ee/trunk/App-Repository/t/DBI-getset.t Tue Jun 22 20:48:49 2010
@@ -217,6 +217,16 @@
is($years_older, 21, "get() years_older [$years_older] base_age = 20");
#####################################################################
+# params with weird characters that need quoting
+#####################################################################
+$last_name = $rep->get("test_person", {first_name => "step'hen"}, "last_name");
+is($last_name, undef, "get() step'hen is undef");
+$last_name = $rep->get("test_person", {"first_name.contains" => "step'hen"},
"last_name");
+is($last_name, undef, "get() %step'hen% is undef");
+$last_name = $rep->get("test_person", {"first_name.matches" => "step'hen*"},
"last_name");
+is($last_name, undef, "get() step'hen* is undef");
+
+#####################################################################
# $rep->set_rows($table, undef, \...@cols, $rows, \%options);
#####################################################################
# eval {
Modified: p5ee/trunk/App-Repository/t/DBI-repobjects.t
==============================================================================
--- p5ee/trunk/App-Repository/t/DBI-repobjects.t (original)
+++ p5ee/trunk/App-Repository/t/DBI-repobjects.t Tue Jun 22 20:48:49 2010
@@ -23,7 +23,7 @@
use App;
use App::Repository;
use App::RepositoryObject;
-use RepositoryTestUtils qw(create_table_test_person drop_table_test_person
populate_table_test_person);
+use RepositoryTestUtils qw(create_table drop_table populate_table);
package App::RepositoryObject::Man;
@ISA = ("App::RepositoryObject");
@@ -70,9 +70,18 @@
);
my $rep = $context->repository();
-&drop_table_test_person($rep);
-&create_table_test_person($rep);
-&populate_table_test_person($rep);
+
+&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";
@@ -181,11 +190,52 @@
is($obj4->{_key},8, "new._key is ok");
is($obj4->{person_id},8, "new.person_id is ok");
isa_ok($obj4, "App::RepositoryObject::Woman", "by new_object(),
christine");
-}
-{
- my $dbh = $rep->{dbh};
- $dbh->do("drop table test_person");
+ $obj = { city_cd => "BOS", city_nm => "Boston" };
+ $obj2 = $rep->new_object("test_city", $obj);
+ isa_ok($obj2, "App::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::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");
+
+ # 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)
+
+ # &drop_table($rep, "test_person");
+ # &drop_table($rep, "test_visit");
+ # &drop_table($rep, "test_city");
}
exit 0;
Modified: p5ee/trunk/App-Repository/t/RepositoryTestUtils.pm
==============================================================================
--- p5ee/trunk/App-Repository/t/RepositoryTestUtils.pm (original)
+++ p5ee/trunk/App-Repository/t/RepositoryTestUtils.pm Tue Jun 22 20:48:49 2010
@@ -29,13 +29,14 @@
use App;
use App::Repository;
+my $dbtype = $App::options{dbtype} || "mysql";
+
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 = "";
@@ -112,8 +113,6 @@
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"); };
@@ -143,7 +142,6 @@
sub create_table_test_app_cache {
my ($rep) = @_;
my $dbh = $rep->{dbh};
- my $dbtype = $App::options{dbtype} || "mysql";
my $suffix = "";
my $CURRENT_TIMESTAMP = "";
@@ -193,7 +191,6 @@
&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);
}
@@ -317,6 +314,35 @@
"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
+
+if ($dbtype eq "oracle") {
+ $table_data{test_visit} = [
+ "insert into test_visit values ('LAX', 1,
to_date('1962-11-09','YYYY-MM-DD'), 'Born')",
+ "insert into test_visit values ('BOS', 1,
to_date('1980-08-30','YYYY-MM-DD'), 'College')",
+ "insert into test_visit values ('JNB', 1,
to_date('1986-10-20','YYYY-MM-DD'), 'Mission Trip')",
+ "insert into test_visit values ('WAS', 1,
to_date('1991-08-20','YYYY-MM-DD'), 'Back to college')",
+ "insert into test_visit values ('ATL', 1,
to_date('1993-06-01','YYYY-MM-DD'), 'Move after graduation')",
+ ];
+}
+else {
+ $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,
@@ -370,7 +396,6 @@
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 = "";
@@ -431,8 +456,6 @@
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"); };
