Author: spadkins
Date: Tue Sep 14 11:04:42 2010
New Revision: 14400
Modified:
p5ee/trunk/App-Context/lib/App/Context.pm
Log:
sub clear_services, used to clear a service
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 Sep 14 11:04:42 2010
@@ -71,7 +71,7 @@
* manage Session data.
The Context object is always a singleton per process (except in rare cases
-like debugging during development).
+like debugging during development).
Conceptually, the Context may be associated with many
Conf's (one per authenticated user) and
@@ -173,7 +173,7 @@
* Throws: Exception::Class::Context
* Since: 0.01
- Sample Usage:
+ Sample Usage:
$context = App::Context->new();
$context = App::Context->new( {
@@ -405,7 +405,7 @@
The _init() method is called from within the standard Context constructor.
The _init() method in this class does nothing.
It allows subclasses of the Context to customize the behavior of the
-constructor by overriding the _init() method.
+constructor by overriding the _init() method.
* Signature: $context->_init($options)
* Param: $options {} [in]
@@ -413,7 +413,7 @@
* Throws: App::Exception
* Since: 0.01
- Sample Usage:
+ Sample Usage:
$context->_init($options);
@@ -453,7 +453,7 @@
* Throws: App::Exception
* Since: 0.01
- Sample Usage:
+ Sample Usage:
$user = $context->service("SessionObject","db.user.spadkins");
$gobutton = $context->service("SessionObject","gobutton");
@@ -488,7 +488,7 @@
(Parameters *are* taken into account if the "override"
parameter is supplied.)
-If it does not exist, it must be created and stored in the
+If it does not exist, it must be created and stored in the
cache.
The name of a service, if not specified, is assumed to be "default".
@@ -683,7 +683,7 @@
$self->dbgprint("Context->service():
sconf={",join(",",%$service_conf),"}") if ($service_conf);
$self->dbgprint("Context->service():
sstore={",join(",",%$service_store),"}") if ($service_store);
}
-
+
$new_service = 1;
################################################################
@@ -771,7 +771,7 @@
if ($App::DEBUG && $self->dbg(6));
}
}
-
+
if ($new_service) {
$self->dbgprint("Context->service() new service [$name]")
if ($App::DEBUG && $self->dbg(3));
@@ -859,7 +859,7 @@
* Throws: App::Exception
* Since: 0.01
- Sample Usage:
+ Sample Usage:
$serializer = $context->serializer();
$call_dispatcher = $context->call_dispatcher();
@@ -932,14 +932,14 @@
* Throws: <none>
* Since: 0.01
- Sample Usage:
+ Sample Usage:
if ($context->session_object_exists($session_object_name)) {
# do something
}
The session_object_exists() returns whether or not a session_object is already
known to the
-Context. This is true if
+Context. This is true if
* it exists in the Session's session_object cache, or
(i.e. it has already been referenced and instantiated in the cache),
@@ -1041,14 +1041,14 @@
* Throws: <none>
* Since: 0.01
- Sample Usage:
+ Sample Usage:
$script_url_dir = $context->get_option("scriptUrlDir", "/cgi-bin");
The get_option() returns the value of an Option variable
(or the "default" value if not set).
-This is an alternative to
+This is an alternative to
getting the reference of the entire hash of Option
variables with $self->options().
@@ -1075,7 +1075,7 @@
* Throws: <none>
* Since: 0.01
- Sample Usage:
+ Sample Usage:
$theme = $context->get_user_option("theme");
$lang = $context->get_user_option("lang");
@@ -1113,7 +1113,7 @@
* Throws: <none>
* Since: 0.01
- Sample Usage:
+ Sample Usage:
$service_type = "SessionObject";
$service_name = "foo";
@@ -1168,7 +1168,7 @@
* Throws: <none>
* Since: 0.01
- Sample Usage:
+ Sample Usage:
$cname = $context->so_get("default", "cname");
$width = $context->so_get("main.app.toolbar.calc", "width");
@@ -1280,7 +1280,7 @@
* Throws: <none>
* Since: 0.01
- Sample Usage:
+ Sample Usage:
$context->so_set("default", "cname", "main_screen");
$context->so_set("main.app.toolbar.calc", "width", 50);
@@ -1335,13 +1335,13 @@
$retval = 1;
}
elsif ($var =~ /^\{/) { # { i.e. "{columnSelected}{first_name}"
-
+
$var =~ s/\{([^\}]+)\}/\{"$1"\}/g; # put quotes around hash keys
-
+
$perl = "\$self->{session}{store}{SessionObject}{\$name}$var =
\$value;";
$perl .= "\$self->{session}{cache}{SessionObject}{\$name}$var =
\$value;"
if (defined $self->{session}{cache}{SessionObject}{$name});
-
+
eval $perl;
if ($@) {
$self->add_message("eval [$perl]: $@");
@@ -1375,7 +1375,7 @@
* Throws: <none>
* Since: 0.01
- Sample Usage:
+ Sample Usage:
$cname = $context->so_default("default", "cname");
$width = $context->so_default("main.app.toolbar.calc", "width");
@@ -1404,7 +1404,7 @@
* Throws: <none>
* Since: 0.01
- Sample Usage:
+ Sample Usage:
$context->so_delete("default", "cname");
$context->so_delete("main-app-toolbar-calc", "width");
@@ -1480,7 +1480,7 @@
* Throws: <none>
* Since: 0.01
- Sample Usage:
+ Sample Usage:
$context->substitute("default", "cname");
$context->substitute("main.app.toolbar.calc", "width");
@@ -1580,7 +1580,7 @@
* Throws: <none>
* Since: 0.01
- Sample Usage:
+ Sample Usage:
$context->add_message("Data was not saved. Try again.");
@@ -1626,7 +1626,7 @@
* Throws: <none>
* Since: 0.01
- Sample Usage:
+ Sample Usage:
$context->log("oops, a bug happened");
@@ -1700,7 +1700,7 @@
if ($hi_res) {
App->use("Time::HiRes");
my @timestuff = Time::HiRes::gettimeofday();
- $timestamp = time2str("%Y-%m-%d %H:%M:%S.", $timestuff[0]) .
sprintf("%06d", $timestuff[1]);
+ $timestamp = time2str("%Y-%m-%d %H:%M:%S.", $timestuff[0]) .
sprintf("%06d", $timestuff[1]);
if ($elapsed) {
if (!defined($self->{_last_log_elapsed_time})) {
$self->{_last_log_elapsed_time} = \...@timestuff;
@@ -1712,7 +1712,7 @@
}
else {
my $time = time();
- $timestamp = time2str("%Y-%m-%d %H:%M:%S", $time);
+ $timestamp = time2str("%Y-%m-%d %H:%M:%S", $time);
if ($elapsed) {
my $elapsed = $time - $self->{_last_log_elapsed_time};
$timestamp .= " " . $elapsed;
@@ -1774,7 +1774,7 @@
* Throws: <none>
* Since: 0.01
- Sample Usage:
+ Sample Usage:
$username = $context->user();
@@ -1807,7 +1807,7 @@
* Throws: <none>
* Since: 0.01
- Sample Usage:
+ Sample Usage:
$options = $context->options();
@@ -1836,7 +1836,7 @@
* Throws: <none>
* Since: 0.01
- Sample Usage:
+ Sample Usage:
$conf = $context->conf();
@@ -1864,7 +1864,7 @@
* Throws: <none>
* Since: 0.01
- Sample Usage:
+ Sample Usage:
$session = $context->session();
$session = $context->session("some_session_id");
@@ -1993,6 +1993,38 @@
&App::sub_exit() if ($App::trace);
}
+
+sub clear_services {
+ &App::sub_entry if ($App::trace);
+ my ($self, $service_type, $clear_service_names, $preserve_service_names) =
@_;
+
+ my $session = $self->{sessions}{default};
+
+ my ($services);
+
+ $services = $session->{store}{$service_type};
+ if ($services) {
+ foreach my $so_name (keys %$services) {
+ if ((!$clear_service_names || $clear_service_names->{$so_name})
+ && (!$preserve_service_names ||
!$preserve_service_names->{$so_name})) {
+ delete $services->{$so_name};
+ }
+ }
+ }
+
+ $services = $session->{cache}{$service_type};
+ if ($services) {
+ foreach my $so_name (keys %$services) {
+ if ((!$clear_service_names || $clear_service_names->{$so_name})
+ && (!$preserve_service_names ||
!$preserve_service_names->{$so_name})) {
+ delete $services->{$so_name};
+ }
+ }
+ }
+
+ &App::sub_exit() if ($App::trace);
+}
+
#############################################################################
# PUBLIC METHODS
#############################################################################
@@ -2056,7 +2088,7 @@
=head2 dbg()
The dbg() method is used to check whether a given line of debug output
-should be generated.
+should be generated.
It returns true or false (1 or 0).
If all three parameters are specified, this function
@@ -2072,7 +2104,7 @@
* Throws: App::Exception::Context
* Since: 0.01
- Sample Usage:
+ Sample Usage:
$context->dbgprint("this is debug output")
if ($App::DEBUG && $context->dbg(3));
@@ -2125,7 +2157,7 @@
* Throws: App::Exception::Context
* Since: 0.01
- Sample Usage:
+ Sample Usage:
$context->dbgprint("this is debug output")
if ($App::DEBUG && $context->dbg(3));
@@ -2160,7 +2192,7 @@
* Throws: App::Exception::Context
* Since: 0.01
- Sample Usage:
+ Sample Usage:
$context->dbglevel(1); # turn it on
$context->dbglevel(0); # turn it off
@@ -2192,7 +2224,7 @@
* Throws: App::Exception::Context
* Since: 0.01
- Sample Usage:
+ Sample Usage:
$debug_scope = $context->debug_scope();
$debug_scope->{"App::Context::CGI"} = 1;
@@ -2222,7 +2254,7 @@
* Throws: App::Exception
* Since: 0.01
- Sample Usage:
+ Sample Usage:
print $self->dump(), "\n";
@@ -2260,7 +2292,7 @@
* Throws: App::Exception
* Since: 0.01
- Sample Usage:
+ Sample Usage:
$context->dispatch_events();
@@ -2391,7 +2423,7 @@
* Throws: App::Exception
* Since: 0.01
- Sample Usage:
+ Sample Usage:
$context->send_results();
@@ -2635,7 +2667,7 @@
* Throws: App::Exception
* Since: 0.01
- Sample Usage:
+ Sample Usage:
$self->wait_for_event($event_token);
@@ -2668,7 +2700,7 @@
# $messages that start with "SC-" force the server to close the socket
first
# This is to help manage which system has the sockets lingering in
TIME_WAIT state.
# Here is the truth table for $await_return_value, $server_close
-# $await_return_value $server_close = client +
server
+# $await_return_value $server_close = client +
server
# ------------------- ------------- ----------------------
---------------------
# 0 0 write/close
read/close
# 0 1 write/read/close
read/close
@@ -2731,7 +2763,7 @@
* Throws: App::Exception
* Since: 0.01
- Sample Usage:
+ Sample Usage:
$self->fork();
@@ -2741,8 +2773,8 @@
connections to be created if necessary.
Call this after a fork() in the child process.
-It will shut down the resources which cannot be shared between a parent and
-a child process.
+It will shut down the resources which cannot be shared between a parent and
+a child process.
Currently, this is primarily for database connections.
For most databases, the child needs its own connection.
@@ -2782,7 +2814,7 @@
* Throws: App::Exception
* Since: 0.01
- Sample Usage:
+ Sample Usage:
$self->shutdown_unshareable_resources();
@@ -2792,8 +2824,8 @@
connections to be created if necessary.
Call this after a fork() in the child process.
-It will shutdown_unshareable which cannot be shared between a parent and
-a child process.
+It will shutdown_unshareable which cannot be shared between a parent and
+a child process.
Currently, this is primarily for database connections.
For most databases, the child needs its own connection.
@@ -2833,7 +2865,7 @@
* Throws: App::Exception
* Since: 0.01
- Sample Usage:
+ Sample Usage:
$self->shutdown();
@@ -2859,10 +2891,10 @@
if (defined $repcache && ref($repcache) eq "HASH") {
foreach $repname (keys %$repcache) {
$instance = $repcache->{$repname};
-
+
$self->dbgprint("Context->shutdown():
$instance->_disconnect()")
if ($App::DEBUG && $self->dbg(1));
-
+
$instance->_disconnect();
delete $repcache->{$repname};
}
@@ -2888,7 +2920,7 @@
* Throws: App::Exception
* Since: 0.01
- Sample Usage:
+ Sample Usage:
$context->response();
@@ -3433,7 +3465,7 @@
# 31. blocked - The bitmap of blocked signals
# 32. sigignore - The bitmap of ignored signals
# 33. sigcatch - The bitmap of catched signals
-# 34. wchan - The channel in which the process is waiting. The "ps -l"
command gives somewhat of a list.
+# 34. wchan - The channel in which the process is waiting. The "ps -l"
command gives somewhat of a list.
sub get_proc_info2 {
my ($self, @pids) = @_;
