App::Context - An application framework for web applications, command-line programs, server programs, and web services
Index
Code Index:
NAME
App::Context - An application framework for web applications, command-line programs, server programs, and web services
SYNOPSIS
# ... official way to get a Context object ...
use App;
$context = App->context();
$context->dispatch_events(); # dispatch events
$conf = $context->conf(); # get the configuration
# any of the following named parameters may be specified
$context = App->context(
context_class => "App::Context::CGI",
conf_class => "App::Conf::File", # or any Conf args
);
# ... alternative way (used internally) ...
use App::Context;
$context = App::Context->new();
DOCUMENT STATUS
This documentation is out of date and needs review and revision.
Please start with the App::quickstart document.
DESCRIPTION
A Context class models the environment (aka "context")
in which the current process is running.
The role of the Context class is to abstract the details of the
various runtime environments (or Platforms) (including their event loops)
so that the basic programming model for the developer is uniform.
Since the Context objects are the objects that initiate events in the
App-Context universe, they must be sure to wrap those event handlers with
try/catch blocks (i.e. "eval{};if($@){}" blocks).
The main functions of the Context class are to
* load the Conf data,
* dispatch events from the Context event loop, and
* manage Session data.
The Context object is always a singleton per process (except in rare cases
like debugging during development).
Conceptually, the Context may be associated with many
Conf's (one per authenticated user) and
Sessions (one per unique session_id)
in a single process (ModPerl).
However, in practice, it is often
associated with only one Conf or Session throughout the lifetime of
the process (CGI, Cmd).
Class Group: Context
The following classes might be a part of the Context Class Group.
- * Class: App::Context
- * Class: App::Context::CGI
- * Class: App::Context::FCGI
- * Class: App::Context::ModPerl
- * Class: App::Context::ModPerlRegistry
- * Class: App::Context::PPerl
- * Class: App::Context::Cmd
- * Class: App::Context::Daemon
- * Class: App::Context::POE
- * Class: App::Context::SOAP (when acting as a SOAP server)
- * Class: App::Context::Gtk
- * Class: App::Context::WxPerl
Attributes, Constants, Global Variables, Class Variables
Master Data Structure Map
$context
$context->{debug_scope}{$class} Debugging all methods in class
$context->{debug_scope}{$class.$method} Debugging a single method
$context->{options} Args that Context was created with
$context->{used}{$class} Similar to %INC, keeps track of what classes used
$context->{Conf}{$user} Info from conf file
[$context->{conf}]
$conf->{$type}{$name} Read-only service conf
$context->{sessions}{$session_id}
[$context->{session}]
$session->{store}{$type}{$name} Runtime state which is stored
$session->{cache}{$type}{$name} Instances of services
Constructor Methods:
new()
The App::Context->new() method is rarely called directly.
That is because a $context should always be instantiated by calling
App->context(). This allows for caching of the $context
as a singleton and the autodetection of what type of Context subclass
should in fact be instantiated.
* Signature: $context = App->new($named);
* Signature: $context = App->new(%named);
* Param: context_class class [in]
* Param: conf_class class [in]
* Param: conf_file string [in]
* Return: $context App::Context
* Throws: Exception::Class::Context
* Since: 0.01
Sample Usage:
$context = App::Context->new();
$context = App::Context->new( {
conf_class => 'App::Conf::File',
conf_file => 'app.xml',
} );
$context = App::Context->new(
conf_class => 'App::Conf::File',
conf_file => 'app.xml',
);
Protected Methods:
The following methods are intended to be called by subclasses of the
current class (or environmental, "main" code).
_init()
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.
* Signature: $context->_init($options)
* Param: $options {} [in]
* Return: void
* Throws: App::Exception
* Since: 0.01
Sample Usage:
$context->_init($options);
Public Methods: Services
service()
The service() method returns a named object of a certain service type.
* Signature: $service = $context->service($type);
* Signature: $service = $context->service($type,$name);
* Signature: $service = $context->service($type,$name,%named);
* Param: $type string [in]
* Param: $name string [in]
* Return: $service App::Service
* Throws: App::Exception
* Since: 0.01
Sample Usage:
$user = $context->service("SessionObject","db.user.spadkins");
$gobutton = $context->service("SessionObject","gobutton");
There are many services available within an App-Context application.
Each service is identified by two pieces of information:
it's type and its name.
The following service types are standard in App-Context.
Others can be developed by deriving a class from the
App::Service class.
All service types must start with a capital letter.
* Serializer
* CallDispatcher
* MessageDispatcher
* ResourceLocker
* SharedDatastore
* Authentication
* Authorization
* SessionObject
Within each service type, each individual service is
identified by its name.
The name of a service, if not
specified, is assumed to be "default".
Whenever a service is requested from the Context via this
service() method, the service cache in the Session is checked
first. If it exists, it is generally returned immediately
without modification by the named parameters.
(Parameters *are* taken into account if the "override"
parameter is supplied.)
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".
The named parameters (%named or $named),
if supplied, are considered defaults.
They are ignored if the values already exist in the service conf.
However, the additional named parameter, "override", may be supplied.
In that case, all of the values in the named parameters will accepted
into the service conf.
Every service (i.e. $conf->{Repository}{default}) starts as
a simple hash which is populated with attributes from several
complementary sources. If we imagine that a service is requested
with type $type and name $name, we can envision the following
additional derived variables.
$type = "Repository";
$name = "sysdb";
$conf = $context->conf();
$repository_type = $conf->{Repository}{sysdb}{repository_type};
The following sources are consulted to populate the service
attributes.
1. conf of the service (in Conf)
i.e. $conf->{Repository}{sysdb}
2. optional conf of the service's service_type (in Conf)
i.e. $conf->{RepositoryType}{$repository_type}
3. named parameters to the service() call
All service configuration happens before instantiation
this allows you to override the "service_class" in the configuration
in time for instantiation
serializer()
call_dispatcher()
message_dispatcher()
resource_locker()
shared_datastore()
authentication()
authorization()
session_object()
These are all convenience methods, which simply turn around
and call the service() method with the service type as the
first argument.
* Signature: $session = $context->session();
* Signature: $session = $context->session($name);
* Signature: $session = $context->session($name,%named);
* Param: $name string [in]
* Return: $service App::Service
* Throws: App::Exception
* Since: 0.01
Sample Usage:
$serializer = $context->serializer();
$call_dispatcher = $context->call_dispatcher();
$message_dispatcher = $context->message_dispatcher();
$resource_locker = $context->resource_locker();
$shared_datastore = $context->shared_datastore();
$authentication = $context->authentication();
$authorization = $context->authorization();
$session_object = $context->session_object();
$value_domain = $context->value_domain();
session_object_exists()
* Signature: $exists = $context->session_object_exists($session_object_name);
* Param: $session_object_name string
* Return: $exists boolean
* Throws: <none>
* Since: 0.01
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
* it exists in the Session's session_object cache, or
(i.e. it has already been referenced and instantiated in the cache),
* it exists in the Session's store, or
(i.e. it was referenced in an earlier request in this session)
* it exists in the Conf
If this method returns FALSE (undef), then any call to the session_object() method
must specify the session_object_class (at a minimum) and may not simply call it
with the $session_object_name.
This is useful particularly for lightweight session_objects which generate events
(such as image buttons). The $context->dispatch_events() method can check
that the session_object has not yet been defined and automatically passes the
event to the session_object's container (implied by the name) for handling.
Public Methods: Accessors
get_option()
* Signature: $value = $context->get_option($var, $default);
* Param: $var string
* Param: $attribute string
* Return: $value string
* Throws: <none>
* Since: 0.01
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
getting the reference of the entire hash of Option
variables with $self->options().
get_user_option()
* Signature: $value = $context->get_user_option($var);
* Param: $var string
* Return: $value string
* Throws: <none>
* Since: 0.01
Sample Usage:
$theme = $context->get_user_option("theme");
$lang = $context->get_user_option("lang");
The get_user_option() returns the value of a user option variable.
This is simply the $var attribute of the "default" session object
(if it exists) or the $var attribute from the global options file.
get_auth_attrib_value()
The get_auth_attrib_value() consults the "default" Authorization service to determine
the "authorized" value of a service configuration's attribute.
* Signature: $attrib_value = $self->get_auth_attrib_value($service_conf, $service_type, $service_name, $attrib);
* Param: $service_conf HASH
* Param: $service_type string
* Param: $service_name string
* Param: $attrib string
* Return: $attrib_value ANY
* Throws: <none>
* Since: 0.01
Sample Usage:
$service_type = "SessionObject";
$service_name = "foo";
$service_conf = $self->{conf}{$service_type}{$service_name};
$clone_name = $self->get_auth_attrib_value($service_conf, $service_type, $service_name, "clone");
so_get()
The so_get() returns the attribute of a session_object.
* Signature: $value = $context->so_get($session_objectname, $attribute);
* Signature: $value = $context->so_get($session_objectname, $attribute, $default);
* Signature: $value = $context->so_get($session_objectname, $attribute, $default, $setdefault);
* Param: $session_objectname string
* Param: $attribute string
* Param: $default any
* Param: $setdefault boolean
* Return: $value string,ref
* Throws: <none>
* Since: 0.01
Sample Usage:
$cname = $context->so_get("default", "cname");
$width = $context->so_get("main.app.toolbar.calc", "width");
so_set()
The so_set() sets an attribute of a session_object in the Session.
* Signature: $context->so_set($session_objectname, $attribute, $value);
* Param: $session_objectname string
* Param: $attribute string
* Param: $value string,ref
* Return: void
* Throws: <none>
* Since: 0.01
Sample Usage:
$context->so_set("default", "cname", "main_screen");
$context->so_set("main.app.toolbar.calc", "width", 50);
$context->so_set("xyz", "{arr}[1][2]", 14);
$context->so_set("xyz", "{arr.totals}", 14);
so_default()
The so_default() sets the value of a SessionObject's attribute
only if it is currently undefined.
* Signature: $value = $context->so_default($session_objectname, $attribute);
* Param: $session_objectname string
* Param: $attribute string
* Return: $value string,ref
* Throws: <none>
* Since: 0.01
Sample Usage:
$cname = $context->so_default("default", "cname");
$width = $context->so_default("main.app.toolbar.calc", "width");
so_delete()
The so_delete() deletes an attribute of a session_object in the Session.
* Signature: $context->so_delete($session_objectname, $attribute);
* Param: $session_objectname string
* Param: $attribute string
* Return: void
* Throws: <none>
* Since: 0.01
Sample Usage:
$context->so_delete("default", "cname");
$context->so_delete("main-app-toolbar-calc", "width");
$context->so_delete("xyz", "{arr}[1][2]");
$context->so_delete("xyz", "{arr.totals}");
substitute()
The substitute() method substitutes values of SessionObjects into target strings.
* Signature: $context->substitute($session_objectname, $attribute);
* Param: $session_objectname string
* Param: $attribute string
* Return: void
* Throws: <none>
* Since: 0.01
Sample Usage:
$context->substitute("default", "cname");
$context->substitute("main.app.toolbar.calc", "width");
$context->substitute("xyz", "{arr}[1][2]");
$context->substitute("xyz", "{arr.totals}");
Public Methods: Miscellaneous
add_message()
The add_message() method stores a string (the concatenated list of @args) in
the Context until it can be viewed by and acted upon by the user.
* Signature: $context->add_message($msg);
* Param: $msg string [in]
* Return: void
* Throws: <none>
* Since: 0.01
Sample Usage:
$context->add_message("Data was not saved. Try again.");
log()
The log() method writes a string (the concatenated list of @args) to
the default log channel.
* Signature: $context->log(@args);
* Signature: $context->log($options, @args);
* Param: $options HASH [in] (named)
* Param: level integer
* Param: @args string [in]
* Return: void
* Throws: <none>
* Since: 0.01
Sample Usage:
$context->log("oops, a bug happened");
These are the standardized log levels.
0 - Context logs nothing (absolutely silent) [???]
1 - only application events [???]
2 - [default] major system-level events [standard level for operations]
3 - internal system-level events [standard level for development]
4 - internal activities [standard level for debugging internals]
5 - internal activities (inside loops) [extreme level for debugging internals]
$self->log("ERROR: send_async_event_now(): node not assigned\n");
$self->log($@);
$self->log({level=>2},"Starting Cluster Node on $self->{host}:$self->{port}\n");
$self->log({level=>2},"Stopping Cluster Node\n");
$self->log({level=>2},"Starting Server on $self->{host}:$self->{port}\n");
$self->log({level=>2},"Stopping Server.\n");
$self->log({level=>2},"Starting Cluster Controller on $self->{host}:$self->{port}\n");
$self->log({level=>2},"Stopping Cluster Controller\n");
$self->log({level=>3},"Send Event: $service_type($name).$method(@args)\n");
$self->log({level=>3},"Send Event: $method(@args)\n");
$self->log({level=>3},"$service_type $name instantiated [$service]\n");
$self->log({level=>3},"Schedule Event (" . join(",",%event) . ")\n";
$self->log({level=>3},"Caught Signal: @_\n"); };
$self->log({level=>3},"Caught Signal: @_\n"); };
$self->log({level=>3},"Caught Signal: @_\n"); };
$self->log({level=>3},"Caught Signal: @_ (quitting)\n"); $quit = 1; };
$self->log({level=>3},"Caught Signal: @_ (quitting)\n"); $quit = 1; };
$self->log({level=>3},"Caught Signal: @_ (quitting)\n"); $quit = 1; };
$self->log({level=>3},"send_message($host, $port, $message)\n");
$self->log({level=>3},"send_message($host, $port, ...) => [$response]\n");
$self->log({level=>3},"process_msg($msg)\n");
$self->log({level=>3},"process_msg: [$msg]\n");
$self->log({level=>3},"process_msg($msg)\n");
$self->log({level=>4},"Checking for scheduled events.\n");
$self->log({level=>4},"Listening on socket: timeout($sleep_interval)\n");
$self->log({level=>4},"Caught Signal: @_\n"); };
$self->log({level=>4},"Listening on socket: timeout($sleep_interval)\n");
$self->log({level=>4},"Child $pid finished [exitval=$exitval,sig=$sig]\n");
$self->log({level=>5},"Checking event: time=$time [$event->{time}, every $event->{interval}] $event->{method}().\n");
$self->log({level=>5},"Event Rescheduled: time=$time [$event->{time}, every $event->{interval}] $event->{method}().\n");
$self->log({level=>5},"Event Removed: time=$time [$event->{time}, every $event->{interval}] $event->{method}().\n");
user()
The user() method returns the username of the authenticated user.
The special name, "guest", refers to the unauthenticated (anonymous) user.
* Signature: $username = $context->user();
* Param: void
* Return: string
* Throws: <none>
* Since: 0.01
Sample Usage:
$username = $context->user();
options()
* Signature: $options = $context->options();
* Param: void
* Return: $options {}
* Throws: <none>
* Since: 0.01
Sample Usage:
$options = $context->options();
The options() method returns a hashreference to all of the variable/value
pairs used in the initialization of the Context.
conf()
* Signature: $conf = $context->conf();
* Param: void
* Return: $conf App::Conf
* Throws: <none>
* Since: 0.01
Sample Usage:
$conf = $context->conf();
The conf() method returns the user's conf data structure.
session()
* Signature: $session = $context->session();
* Signature: $session = $context->session($session_id);
* Param: $session_id string
* Return: $session App::Session
* Throws: <none>
* Since: 0.01
Sample Usage:
$session = $context->session();
$session = $context->session("some_session_id");
The session() method returns the current session (if no session_id is
supplied). If a session_id is supplied, the requested session is
instantiated if necessary and is returned.
Public Methods: Debugging
dbg()
The dbg() method is used to check whether a given line of debug output
should be generated.
It returns true or false (1 or 0).
If all three parameters are specified, this function
returns true only when the global debug level ($App::Context::DEBUG)
is at least equal to $level and when the debug scope
is set to debug this class and method.
* Signature: $flag = $context->dbg($class,$method,$level);
* Param: $class class [in]
* Param: $method string [in]
* Param: $level integer [in]
* Return: void
* Throws: App::Exception::Context
* Since: 0.01
Sample Usage:
$context->dbgprint("this is debug output")
if ($App::DEBUG && $context->dbg(3));
$context->dbgprint("this is debug output")
if ($context->dbg(3));
The first usage is functionally identical to the second, but the check
of the global debug level explicitly reduces the runtime overhead to
eliminate any method calls when debugging is not turned on.
dbgprint()
The dbgprint() method is used to produce debug output.
The output goes to an output stream which is appropriate for
the runtime context in which it is called.
* Signature: $flag = $context->dbgprint(@args);
* Param: @args string [in]
* Return: void
* Throws: App::Exception::Context
* Since: 0.01
Sample Usage:
$context->dbgprint("this is debug output")
if ($App::DEBUG && $context->dbg(3));
dbglevel()
The dbglevel() method is used to set the debug level.
Setting the dbglevel to 0 turns off debugging output and is suitable
for production use. Setting the dbglevel to 1 or higher turns on
increasingly verbose debug output.
* Signature: $context->dbglevel($dbglevel);
* Signature: $dbglevel = $context->dbglevel();
* Param: $dbglevel integer
* Return: $dbglevel integer
* Throws: App::Exception::Context
* Since: 0.01
Sample Usage:
$context->dbglevel(1); # turn it on
$context->dbglevel(0); # turn it off
$dbglevel = $context->dbglevel(); # get the debug level
debug_scope()
The debug_scope() method is used to get the hash which determines which
debug statements are to be printed out when the debug level is set to a
positive number. It returns a hash reference. If class names or
"class.method" names are defined in the hash, it will cause the
debug statements from those classes or methods to be printed.
* Signature: $debug_scope = $context->debug_scope();
* Param: void
* Return: $debug_scope {}
* Throws: App::Exception::Context
* Since: 0.01
Sample Usage:
$debug_scope = $context->debug_scope();
$debug_scope->{"App::Context::CGI"} = 1;
$debug_scope->{"App::Context::CGI.process_request"} = 1;
dump()
* Signature: $perl = $context->dump();
* Param: void
* Return: $perl text
* Throws: App::Exception
* Since: 0.01
Sample Usage:
print $self->dump(), "\n";
Protected Methods
These methods are considered protected because no class is ever supposed
to call them. They may however be called by the context-specific drivers.
dispatch_events()
* Signature: $context->dispatch_events()
* Param: void
* Return: void
* Throws: App::Exception
* Since: 0.01
Sample Usage:
$context->dispatch_events();
The dispatch_events() method is called by the bootstrap environmental code
in order to get the Context object rolling. It causes the program to block
(wait on I/O), loop, or poll, in order to find events from the environment
and dispatch them to the appropriate places within the App-Context framework.
It is considered "protected" because no classes should be calling it.
send_results()
* Signature: $context->send_results()
* Param: void
* Return: void
* Throws: App::Exception
* Since: 0.01
Sample Usage:
$context->send_results();
wait_for_event()
* Signature: $self->wait_for_event($event_token)
* Param: $event_token string
* Return: void
* Throws: App::Exception
* Since: 0.01
Sample Usage:
$self->wait_for_event($event_token);
The wait_for_event() method is called when an asynchronous event has been
sent and no more processing can be completed before it is done.
fork()
* Signature: $pid = $self->fork()
* Param: void
* Return: $pid integer
* Throws: App::Exception
* Since: 0.01
Sample Usage:
$self->fork();
The fork() method is called in a child process just after
it has been fork()ed.
This causes connections to databases, etc. to be closed gracefully and new
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.
Currently, this is primarily for database connections.
For most databases, the child needs its own connection.
shutdown_unshareable_resources()
* Signature: $self->shutdown_unshareable_resources()
* Param: void
* Return: void
* Throws: App::Exception
* Since: 0.01
Sample Usage:
$self->shutdown_unshareable_resources();
The shutdown_unshareable_resources() method is called in a child process just after
it has been fork()ed.
This causes connections to databases, etc. to be closed gracefully and new
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.
Currently, this is primarily for database connections.
For most databases, the child needs its own connection.
shutdown()
The shutdown() method is called when the Context is preparing to exit.
This allows for connections to databases, etc. to be closed gracefully.
* Signature: $self->shutdown()
* Param: void
* Return: void
* Throws: App::Exception
* Since: 0.01
Sample Usage:
$self->shutdown();
response()
* Signature: $context->response()
* Param: void
* Return: void
* Throws: App::Exception
* Since: 0.01
Sample Usage:
$context->response();
The response() method gets the current Response being handled in the Context.
#############################################################################
## $Id: Context.pm 14127 2010-06-09 21:12:59Z spadkins $
#############################################################################
package App::Context;
$VERSION = (q$Revision: 14127 $ =~ /(\d[\d\.]*)/)[0]; # VERSION numbers generated by svn
use strict;
use App;
use Carp qw(confess shortmess);
use Date::Format;
use Time::HiRes;
use IO::Handle; # for the STDOUT->autoflush() method
use IO::Socket;
use IO::Socket::INET;
#############################################################################
# CONSTANTS
#############################################################################
#############################################################################
# CLASS GROUP
#############################################################################
#############################################################################
# ATTRIBUTES/CONSTANTS/CLASS VARIABLES/GLOBAL VARIABLES
#############################################################################
#############################################################################
# CONSTRUCTOR METHODS
#############################################################################
#############################################################################
# new()
#############################################################################
sub new {
&App::sub_entry if ($App::trace);
my $this = shift;
my $class = ref($this) || $this;
my $self = {};
bless $self, $class;
my ($options, %options, $i);
if ($#_ > -1) {
if (ref($_[0]) eq "HASH") {
$options = shift;
die "Odd number of named args in App::Context->new()"
if ($#_ % 2 == 0);
for ($i = 0; $i < $#_; $i++) {
$options->{$_[$i]} = $_[$i+1];
}
}
else {
$options = ($#_ > -1) ? { @_ } : {};
}
}
%options = %$options;
#################################################################
# DEBUGGING
#################################################################
# Supports the following command-line usage:
# -debug=1 (global debug)
# -debug=1,App::Context (debug class only)
# -debug=3,App::Context,App::Session (multiple classes)
# -debug=6,App::Repository::DBI.select_rows (indiv. methods)
my ($debug, $pkg);
$debug = $options{debug};
if (defined $debug && $debug ne "") {
if ($debug =~ s/^([0-9]+),?//) {
$App::DEBUG = $1;
}
if ($debug) {
foreach $pkg (split(/,/,$debug)) {
$self->{debug_scope}{$pkg} = 1;
}
}
}
my ($conf_class, $session_class);
$self->{options} = \%options;
$options{context} = $self;
$self->{log_level} = $options{log_level};
$self->{log_level} = 2 if (!defined $self->{log_level});
$self->log_file_open();
$conf_class = $options{conf_class};
$conf_class = "App::Conf::File" if (! $conf_class);
if ($App::DEBUG >= 2) {
my (@str, $key);
push(@str,"Context->new(): conf=$conf_class\n");
foreach $key (sort keys %options) {
push(@str, " $key => $options{$key}\n");
}
$self->dbgprint(join("",@str));
}
##############################################################
# initialize conf
##############################################################
my $conf = {};
eval {
# Initialize from "app.pl" or other file/source specified by the class
$conf = App->new($conf_class, "new", \%options);
# Override any values which are supplied in "app.conf" (the "deployment descriptor")
foreach my $var (keys %options) {
if ($var =~ /^app\.(.+)/) {
$conf->set($1, $options{$var});
}
}
};
$self->add_message($@) if ($@);
$self->{conf} = $conf;
##############################################################
# Include and Overlay $conf with additional files
##############################################################
my ($includes);
$includes = $conf->{global}{include} if ($conf->{global});
if ($includes && ref($includes) eq "ARRAY") {
my $options = $self->{options};
my $prefix = $options->{prefix};
my (@include_files, $cond, $include_files, $matches);
for (my $i = 0; $i <= $#$includes; $i += 2) {
$cond = $includes->[$i];
$include_files = $includes->[$i+1];
$matches = $self->cond_matches_options($cond, $options);
if ($matches) {
if (ref($include_files) eq "ARRAY") {
@include_files = @$include_files;
}
elsif (ref($include_files) eq "") {
@include_files = ( $include_files );
}
foreach my $conf_file (@include_files) {
$conf_file = "$prefix/etc/app/$conf_file" if ($conf_file !~ m!^/!);
if ($self->{conf_included}{$conf_file}) {
print STDERR "Conf global include: [$cond][$conf_file] already included\n" if ($options{debug_conf});
next;
}
if (-r $conf_file) {
$options{conf_file} = $conf_file;
my $aux_conf = $conf_class->create({ %options });
$conf->overlay($aux_conf);
print STDERR "Conf global include: [$cond][$conf_file] included (overlayed)\n" if ($options{debug_conf});
}
else {
print STDERR "Conf global include: [$cond][$conf_file] not readable\n" if ($options{debug_conf});
}
$self->{conf_included}{$conf_file} = 1;
}
}
print STDERR "Conf global include: [$cond] did not match options\n" if (!$matches && $options{debug_conf});
}
}
##############################################################
# misc
##############################################################
if (defined $options{debug_conf} && $options{debug_conf} >= 2) {
$self->dbgprint($self->{conf}->dump());
}
$self->{events} = []; # the event queue starts empty
$self->{returntype} = "default"; # assume default return type
$self->{scheduled_events} = [];
$self->{scheduled_event} = {};
$self->{event_loop_extensions} = [];
$self->_init(\%options); # allows the subclass to do initialization
$self->set_current_session("default");
if ($options{authentication_class}) {
$self->authentication("default", class => $options{authentication_class});
}
&App::sub_exit($self) if ($App::trace);
return $self;
}
sub _default_session_class {
&App::sub_entry if ($App::trace);
&App::sub_exit("App::Session") if ($App::trace);
return("App::Session");
}
# NOTE: This is very similar logic to some logic in App::Options to see if sections
# of app.conf are active.
sub cond_matches_options {
&App::sub_entry if ($App::trace);
my ($self, $cond_str, $options) = @_;
my ($var, $value, $regexp, $cond, $cond_value);
my $matches = 1; # assume the condition matches
my @cond = split(/;/,$cond_str); # separate the conditions that must be satisfied
foreach $cond (@cond) { # check each condition
if ($cond =~ /^([^=]+)=(.*)$/) { # i.e. city=ATL or name=/[Ss]tephen/
$var = $1;
$cond_value = $2;
}
else { # i.e. [go] matches the program (app) named "go"
$var = "app";
$cond_value = $cond;
}
if ($cond_value =~ m!^/(.*)/$!) { # variable's value must match the regexp
$regexp = $1;
$value = $options->{$var};
$value = "" if (!defined $value);
$matches = ($value =~ /$regexp/) ? 1 : 0;
}
elsif ($var eq "app" && ($cond_value eq "" || $cond_value eq "ALL")) {
$matches = 1; # "" and "ALL" are special wildcards for the "app" variable
}
else { # a variable's value must match exactly
$value = $options->{$var};
$value = "" if (!defined $value);
$matches = ($value eq $cond_value) ? 1 : 0;
}
last if (!$matches);
}
&App::sub_exit($matches) if ($App::trace);
return($matches);
}
#############################################################################
# PROTECTED METHODS
#############################################################################
#############################################################################
# _init()
#############################################################################
sub _init {
&App::sub_entry if ($App::trace);
my ($self, $options) = @_;
$self->init_profiler_log();
&App::sub_exit() if ($App::trace);
}
#############################################################################
# PUBLIC METHODS
#############################################################################
#############################################################################
# service()
#############################################################################
sub service {
&App::sub_entry if ($App::trace);
my ($self, $type, $name, %named) = @_;
$self->dbgprint("Context->service(" . join(", ",@_) . ")")
if ($App::DEBUG && $self->dbg(3));
my $options = $self->{options};
my ($args, $new_service, $override, $lightweight, $attrib);
my ($service, $conf, $class, $session);
my ($service_store, $service_conf, $service_type, $service_type_conf);
my ($default);
# $type (i.e. SessionObject, Session, etc.) must be supplied
if (!defined $type) {
App::Exception->throw(
error => "cannot create a service of unknown type\n",
);
}
if (%named) {
$args = \%named;
}
else {
$args = {};
}
if (! defined $name || $name eq "") { # we need a name!
$name = "default";
}
$session = $self->{session};
$service = $session->{cache}{$type}{$name}; # 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";
##############################################################
# Load extra conf on demand
##############################################################
if (!$service_initialized && !$service_conf && $name !~ /-/) { # if it's not a contained widget, try the file system
my $prefix = $options->{prefix};
my $conf_type = $options->{conf_type} || "pl";
my $conf_file = "$prefix/etc/app/$type.$name.$conf_type";
if (!$self->{conf_included}{$conf_file} && -r $conf_file) {
$options->{conf_file} = $conf_file;
my $aux_conf = App::Conf::File->create({ %$options });
$conf->overlay($aux_conf);
$service_conf = $conf->{$type}{$name};
}
$self->{conf_included}{$conf_file} = 1;
}
##############################################################
# conf includes
##############################################################
if (!$service_initialized && $service_conf && $service_conf->{include}) {
my $prefix = $options->{prefix};
my (@include_files);
my $include_files = $service_conf->{include};
if (ref($include_files) eq "ARRAY") {
@include_files = @$include_files;
}
elsif (ref($include_files) eq "") {
@include_files = ( $include_files );
}
foreach my $conf_file (@include_files) {
$conf_file = "$prefix/etc/app/$conf_file" if ($conf_file !~ m!^/!);
next if ($self->{conf_included}{$conf_file});
if (-r $conf_file) {
$options->{conf_file} = $conf_file;
my $aux_conf = App::Conf::File->create({ %$options });
$conf->overlay($aux_conf);
}
$self->{conf_included}{$conf_file} = 1;
}
}
##############################################################
# Detect Deprecated Services
##############################################################
if (!$service_initialized && $service_conf) {
if ($service_conf->{deprecated}) {
my $message_suffix = $service_conf->{deprecated};
my $message = "WARNING: $type($name) deprecated";
$message .= ": $message_suffix" if ($message_suffix ne "1");
my $deprecated_action = $options->{"app.Context.deprecated_action"};
if (!$deprecated_action || $deprecated_action eq "none") {
# do nothing
}
elsif ($deprecated_action eq "die") {
confess $message;
}
else {
$self->log(shortmess($message));
}
}
}
##############################################################
# aliases
##############################################################
if (!$service_initialized && $service_conf) {
my $alias = $service_conf->{alias};
if ($alias && $alias ne $name) {
$service = $session->{cache}{$type}{$alias};
$service = $self->service($type, $alias) if (!$service);
$service_conf = $conf->{$type}{$alias};
$name = $alias;
}
elsif ($type ne "Authorization" && ($service_conf->{clone} || $service_conf->{auth_clone})) {
my $clone = $self->get_auth_attrib_value($service_conf, $type, $name, "clone");
if ($clone) {
$service_conf = $conf->{$type}{$clone};
}
}
}
$new_service = 0;
# NEVER DEFINED OR NON-BLESSED HASH (fully defined services are blessed into classes)
if ($temporary || !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) {
$service_store = undef;
$service->{temporary} = 1;
}
if ($App::DEBUG && $self->dbg(6)) {
$self->dbgprint("Context->service(): new service. conf=$conf svc=$service sconf=$service_conf sstore=$service_store");
$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;
################################################################
# start with runtime store for the service from the session
################################################################
if ($service_store) {
foreach $attrib (keys %$service_store) {
if (!defined $service->{$attrib}) {
$service->{$attrib} = $service_store->{$attrib};
}
}
}
################################################################
# overlay with attributes from the conf file
################################################################
if ($service_conf) {
foreach $attrib (keys %$service_conf) {
# include conf attributes only if not set already
if (!defined $service->{$attrib}) {
$service->{$attrib} = $service_conf->{$attrib};
}
}
}
################################################################
# overlay with attributes from the "service_type"
################################################################
$service_type = $service->{type}; # i.e. "session_object_type"
if ($service_type) {
$service_type_conf = $conf->{"${type}Type"}{$service_type};
if ($service_type_conf) {
foreach $attrib (keys %$service_type_conf) {
# include service_type confs only if not set already
if (!defined $service->{$attrib}) {
$service->{$attrib} = $service_type_conf->{$attrib};
}
}
}
}
}
################################################################
# take care of all %$args attributes next
################################################################
# A "lightweight" service is one which never stores its attributes in
# the session store. It assumes that all necessary attributes will
# be supplied by the conf or by the code. As a result, a "lightweight"
# service can usually never handle events.
# 1. its attributes are only ever required when they are all supplied
# 2. its attributes will be OK by combining the %$args with the %$conf
# This all saves space in the Session store, as the attribute values can
# be relied upon to be supplied by the conf file and the code (and
# minimal reliance on the Session store).
# 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
$lightweight = 1;
}
elsif (defined $args->{lightweight}) { # may be specified explicitly
$lightweight = $args->{lightweight};
}
else {
$lightweight = ($name =~ /[\{\}\[\]]/); # or implicitly for indexed variables
}
$override = $args->{override};
if ($new_service || $override) {
foreach $attrib (keys %$args) {
# don't include the entry which says whether we are overriding or not
next if ($attrib eq "override");
# include attrib if overriding OR attrib not provided in the session_object confs already
if (!defined $service->{$attrib} ||
($override && $service->{$attrib} ne $args->{$attrib})) {
$service->{$attrib} = $args->{$attrib};
$session->{store}{$type}{$name}{$attrib} = $args->{$attrib} if (!$lightweight);
}
$self->dbgprint("Context->service() [arg=$attrib] name=$name lw=$lightweight ovr=$override",
" service=", $service->{$attrib},
" service_store=", $service_store->{$attrib},
" args=", $args->{$attrib})
if ($App::DEBUG && $self->dbg(6));
}
}
if ($new_service) {
$self->dbgprint("Context->service() new service [$name]")
if ($App::DEBUG && $self->dbg(3));
if (!$temporary && defined $service->{default}) {
$default = $service->{default};
if ($default =~ /^\{today\}\+?(-?[0-9]+)?$/) {
$default = time2str("%Y-%m-%d",time + 2*3600 + ($1 ? ($1*3600*24) : 0));
}
if (defined $default) {
$self->so_get($name, "", $default, 1);
$self->so_delete($name, "default");
}
}
$class = $service->{class}; # find class of service
if (!defined $class || $class eq "") {
$class = "App::$type"; # assume the "generic" class
$service->{class} = $class;
}
if (! $self->{used}{$class}) { # load the code
App->use($class);
$self->{used}{$class} = 1;
}
$self->dbgprint("Context->service() service class [$class]")
if ($App::DEBUG && $self->dbg(3));
bless $service, $class; # bless the service into the class
if (!$temporary) {
$session->{cache}{$type}{$name} = $service; # save in the cache
}
$service->_init(); # perform additional initializations
}
$self->dbgprint("Context->service() = $service")
if ($App::DEBUG && $self->dbg(3));
&App::sub_exit($service) if ($App::trace);
return $service;
}
#############################################################################
# service convenience methods
#############################################################################
# Standard Services: provided in the App-Context distribution
sub call_dispatcher { my $self = shift; return $self->service("CallDispatcher",@_); }
sub message_dispatcher { my $self = shift; return $self->service("MessageDispatcher",@_); }
sub resource_locker { my $self = shift; return $self->service("ResourceLocker",@_); }
sub shared_datastore { my $self = shift; return $self->service("SharedDatastore",@_); }
sub authentication { my $self = shift; return $self->service("Authentication",@_); }
sub authorization { my $self = shift; return $self->service("Authorization",@_); }
sub session_object { my $self = shift; return $self->service("SessionObject",@_); }
sub value_domain { my $self = shift; return $self->service("ValueDomain",@_); }
sub serializer {
my $self = shift;
my $name = shift;
my (@args);
if ($#_ > -1 || !$name || $self->service_exists("Serializer", $name)) {
@args = @_;
}
else {
my $class_base = ucfirst(lc($name));
$class_base =~ s/_([a-z])/"_" . uc($1)/eg;
my $class = "App::Serializer::" . $class_base;
@args = (class => $class);
}
return $self->service("Serializer", $name, @args);
}
# Extended Services: provided in the App-Widget and App-Repository distributions
# this is kind of cheating for the core to know about the extensions, but OK
sub template_engine { my $self = shift; return $self->service("TemplateEngine",@_); }
sub repository {
my ($self, $name, @opts) = @_;
my $options = $self->{options};
my $key = "$name.dbclass";
if ($options->{$key}) {
$self->{conf}{Repository}{$name}{class} = $options->{$key};
}
return $self->service("Repository", $name, @opts);
}
sub widget {
my $self = shift;
my @args = @_;
if ($#args <= 0) {
push(@args, ("class", "App::Widget"));
}
return $self->service("SessionObject",@args);
}
#############################################################################
# session_object_exists()
#############################################################################
sub session_object_exists {
&App::sub_entry if ($App::trace);
my ($self, $session_object_name) = @_;
my ($exists, $session_object_type, $session_object_class);
$session_object_class =
$self->{session}{cache}{SessionObject}{$session_object_name}{class} ||
$self->{session}{store}{SessionObject}{$session_object_name}{class} ||
$self->{conf}{SessionObject}{$session_object_name}{class};
if (!$session_object_class) {
$session_object_type =
$self->{session}{cache}{SessionObject}{$session_object_name}{type} ||
$self->{session}{store}{SessionObject}{$session_object_name}{type} ||
$self->{conf}{SessionObject}{$session_object_name}{type};
if ($session_object_type) {
$session_object_class = $self->{conf}{SessionObjectType}{$session_object_type}{class};
}
}
$exists = $session_object_class ? 1 : 0;
$self->dbgprint("Context->session_object_exists($session_object_name) = $exists")
if ($App::DEBUG && $self->dbg(2));
&App::sub_exit($exists) if ($App::trace);
return $exists;
}
sub service_exists {
&App::sub_entry if ($App::trace);
my ($self, $service_type, $service_name) = @_;
my ($exists, $service_template, $service_class);
$service_class =
$self->{session}{cache}{$service_type}{$service_name}{class} ||
$self->{session}{store}{$service_type}{$service_name}{class} ||
$self->{conf}{$service_type}{$service_name}{class};
if (!$service_class) {
$service_template =
$self->{session}{cache}{$service_type}{$service_name}{type} ||
$self->{session}{store}{$service_type}{$service_name}{type} ||
$self->{conf}{$service_type}{$service_name}{type};
if ($service_template) {
$service_class = $self->{conf}{"${service_type}Type"}{$service_template}{class};
}
}
$exists = $service_class ? 1 : 0;
$self->dbgprint("Context->service_exists($service_name) = $exists")
if ($App::DEBUG && $self->dbg(2));
&App::sub_exit($exists) if ($App::trace);
return $exists;
}
#############################################################################
# PUBLIC METHODS
#############################################################################
#############################################################################
# get_option()
#############################################################################
sub get_option {
&App::sub_entry if ($App::trace);
my ($self, $var, $default) = @_;
my $value = $self->{options}{$var};
$value = $default if (!defined $value);
&App::sub_exit($value) if ($App::trace);
return($value);
}
#############################################################################
# get_user_option()
#############################################################################
sub get_user_option {
&App::sub_entry if ($App::trace);
my ($self, $var) = @_;
my $value = $self->so_get($var);
$value = $self->{options}{$var} if (!defined $value);
&App::sub_exit($value) if ($App::trace);
return($value);
}
#############################################################################
# get_auth_attrib_value()
#############################################################################
sub get_auth_attrib_value {
my ($self, $service_conf, $service_type, $service_name, $attrib) = @_;
my ($auth_value);
my $auth_value_list = $service_conf->{"auth_$attrib"};
if ($auth_value_list && ref($auth_value_list) eq "ARRAY") {
my ($auth_key, $auth_name);
my $auth = $self->authorization();
for (my $i = 0; $i <= $#$auth_value_list; $i += 2) {
$auth_name = $auth_value_list->[$i];
if ($auth_name =~ m!^/!) {
$auth_key = $auth_name;
}
else {
$auth_key = "/App/$service_type/$service_name/$auth_name";
}
if ($auth->is_authorized($auth_key)) {
$auth_value = $auth_value_list->[$i+1];
last;
}
}
}
if (!$auth_value) {
$auth_value = $service_conf->{$attrib};
}
return($auth_value);
}
#############################################################################
# so_get()
#############################################################################
sub so_get {
&App::sub_entry if ($App::trace);
my ($self, $name, $var, $default, $setdefault) = @_;
my ($perl, $value);
if (!defined $var || $var eq "") {
if ($name =~ /^([a-zA-Z0-9_\.-]+)([\{\}\[\]].*)$/) {
$name = $1;
$var = $2;
}
elsif ($name =~ /^([a-zA-Z0-9_\.-]+)-([a-zA-Z0-9_]+)$/) {
$name = $1;
$var = $2;
}
else {
$var = $name;
$name = "default";
}
}
if ($var !~ /[\[\]\{\}]/) { # no special chars, "foo-bar"
my $cached_service = $self->{session}{cache}{SessionObject}{$name};
if (!defined $cached_service || ref($cached_service) eq "HASH") {
$cached_service = $self->session_object($name);
}
$value = $cached_service->{$var};
if ((!defined $value || $value eq "") && defined $default) {
$value = $default;
if ($setdefault) {
$self->{session}{store}{SessionObject}{$name}{$var} = $value;
$self->{session}{cache}{SessionObject}{$name}{$var} = $value;
}
}
$self->dbgprint("Context->so_get($name,$var) (value) = [$value]")
if ($App::DEBUG && $self->dbg(3));
}
elsif ($var =~ /^\{([^\{\}]+)\}$/) { # a simple "{foo-bar}"
$var = $1;
$value = $self->{session}{cache}{SessionObject}{$name}{$var};
if (!defined $value && defined $default) {
$value = $default;
if ($setdefault) {
$self->{session}{store}{SessionObject}{$name}{$var} = $value;
my $cached_service = $self->{session}{cache}{SessionObject}{$name};
if (!defined $cached_service || ref($cached_service) eq "HASH") {
$self->session_object($name);
}
$self->{session}{cache}{SessionObject}{$name}{$var} = $value;
}
}
$self->dbgprint("Context->so_get($name,$var) (attrib) = [$value]")
if ($App::DEBUG && $self->dbg(3));
}
elsif ($var =~ /^[\{\}\[\]].*$/) {
$self->session_object($name) if (!defined $self->{session}{cache}{SessionObject}{$name});
$var =~ s/\{([^\{\}]+)\}/\{"$1"\}/g;
$perl = "\$value = \$self->{session}{cache}{SessionObject}{\$name}$var;";
eval $perl;
$self->add_message("eval [$perl]: $@") if ($@);
#print STDERR "ERROR: Context->get($var): eval ($perl): $@\n" if ($@);
$self->dbgprint("Context->so_get($name,$var) (indexed) = [$value]")
if ($App::DEBUG && $self->dbg(3));
}
&App::sub_exit($value) if ($App::trace);
return $value;
}
# This is a very low-level _so_get() suitable for use within the App-Context
# framework. It requires you to separate $name and $var yourself.
sub _so_get {
&App::sub_entry if ($App::trace);
my ($self, $name, $var, $default) = @_;
my $value = $self->{session}{cache}{SessionObject}{$name}{$var};
if (! defined $value) {
$value = $self->{session}{store}{SessionObject}{$name}{$var};
if (! defined $value) {
$value = $self->{conf}{SessionObject}{$name}{$var};
}
}
&App::sub_exit($value) if ($App::trace);
return $value;
}
#############################################################################
# so_set()
#############################################################################
sub so_set {
&App::sub_entry if ($App::trace);
my ($self, $name, $var, $value) = @_;
my ($perl, $retval);
if ($value eq "{:delete:}") {
$retval = $self->so_delete($name,$var);
}
else {
$self->dbgprint("Context->so_set($name,$var,$value)")
if ($App::DEBUG && $self->dbg(3));
if (!defined $var || $var eq "") {
if ($name =~ /^([a-zA-Z0-9_\.-]+)([\{\}\[\]].*)$/) {
$name = $1;
$var = $2;
}
elsif ($name =~ /^([a-zA-Z0-9_\.-]+)-([a-zA-Z0-9_]+)$/) {
$name = $1;
$var = $2;
}
else {
$var = $name;
$name = "default";
}
}
if ($var !~ /[\[\]\{\}]/) { # no special chars, "foo-bar"
$self->{session}{store}{SessionObject}{$name}{$var} = $value;
$self->{session}{cache}{SessionObject}{$name}{$var} = $value;
# ... we used to only set the cache attribute when the
# object was already in the cache.
# if (defined $self->{session}{cache}{SessionObject}{$name});
$retval = 1;
} # match {
elsif ($var =~ /^\{([^\}]+)\}$/) { # a simple "{foo-bar}"
$var = $1;
$self->{session}{store}{SessionObject}{$name}{$var} = $value;
$self->{session}{cache}{SessionObject}{$name}{$var} = $value;
# ... we used to only set the cache attribute when the
# object was already in the cache.
# if (defined $self->{session}{cache}{SessionObject}{$name});
$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]: $@");
$retval = 0;
}
else {
$retval = 1;
}
#die "ERROR: Context->so_set($name,$var,$value): eval ($perl): $@" if ($@);
}
# } else we do nothing with it!
}
&App::sub_exit($retval) if ($App::trace);
return $retval;
}
#############################################################################
# so_default()
#############################################################################
sub so_default {
&App::sub_entry if ($App::trace);
my ($self, $name, $var, $default) = @_;
$self->so_get($name, $var, $default, 1);
&App::sub_exit() if ($App::trace);
}
#############################################################################
# so_delete()
#############################################################################
sub so_delete {
&App::sub_entry if ($App::trace);
my ($self, $name, $var) = @_;
my ($perl);
$self->dbgprint("Context->so_delete($name,$var)")
if ($App::DEBUG && $self->dbg(3));
if (!defined $var || $var eq "") {
if ($name =~ /^([a-zA-Z0-9_\.-]+)([\{\}\[\]].*)$/) {
$name = $1;
$var = $2;
}
elsif ($name =~ /^([a-zA-Z0-9_\.-]+)-([a-zA-Z0-9_]+)$/) {
$name = $1;
$var = $2;
}
else {
$var = $name;
$name = "default";
}
}
if ($var !~ /[\[\]\{\}]/) { # no special chars, "foo-bar"
delete $self->{session}{store}{SessionObject}{$name}{$var};
delete $self->{session}{cache}{SessionObject}{$name}{$var}
if (defined $self->{session}{cache}{SessionObject}{$name});
} # match {
elsif ($var =~ /^\{([^\}]+)\}$/) { # a simple "{foo-bar}"
$var = $1;
delete $self->{session}{store}{SessionObject}{$name}{$var};
delete $self->{session}{cache}{SessionObject}{$name}{$var}
if (defined $self->{session}{cache}{SessionObject}{$name});
}
elsif ($var =~ /^\{/) { # { i.e. "{columnSelected}{first_name}"
$var =~ s/\{([^\}]+)\}/\{"$1"\}/g; # put quotes around hash keys
#$self->session_object($name) if (!defined $self->{session}{cache}{SessionObject}{$name});
$perl = "delete \$self->{session}{store}{SessionObject}{\$name}$var;";
$perl .= "delete \$self->{session}{cache}{SessionObject}{\$name}$var;"
if (defined $self->{session}{cache}{SessionObject}{$name});
eval $perl;
$self->add_message("eval [$perl]: $@") if ($@);
#die "ERROR: Context->so_delete($name,$var): eval ($perl): $@" if ($@);
}
# } else we do nothing with it!
&App::sub_exit() if ($App::trace);
}
#############################################################################
# substitute()
#############################################################################
sub substitute {
&App::sub_entry if ($App::trace);
my ($self, $text, $values) = @_;
$self->dbgprint("Context->substitute()")
if ($App::DEBUG && $self->dbg(1));
my ($phrase, $var, $value);
$values = {} if (! defined $values);
if (ref($text) eq "HASH") {
my ($hash, $newhash);
$hash = $text; # oops, not text, but a hash of text values
$newhash = {}; # prepare a new hash for the substituted values
foreach $var (keys %$hash) {
$newhash->{$var} = $self->substitute($hash->{$var}, $values);
}
return($newhash); # short-circuit this whole process
}
while ( $text =~ /\[([^\[\]]+)\]/ ) {
$phrase = $1;
while ( $phrase =~ /\{([^\{\}]+)\}/ ) {
$var = $1;
if (defined $values->{$var}) {
$value = $values->{$var};
$phrase =~ s/\{$var\}/$value/g;
}
else {
if ($var =~ /^(.+)\.([^.]+)$/) {
$value = $self->so_get($1, $2);
if (defined $value) {
$phrase =~ s/\{$var\}/$value/g;
}
else {
$phrase = "";
}
}
else {
$phrase = "";
}
}
}
if ($phrase eq "") {
$text =~ s/\[[^\[\]]+\]\n?//; # zap it including (optional) ending newline
}
else {
$text =~ s/\[[^\[\]]+\]/$phrase/;
}
}
while ( $text =~ /\{([^\{\}]+)\}/ ) { # vars of the form {var}
$var = $1;
if (defined $values->{$var}) {
$value = $values->{$var};
$text =~ s/\{$var\}/$value/g;
}
else {
$value = "";
if ($var =~ /^(.+)\.([^.]+)$/) {
$value = $self->so_get($1, $2);
}
}
$value = "" if (!defined $value);
$text =~ s/\{$var\}/$value/g;
}
&App::sub_exit($text) if ($App::trace);
$text;
}
#############################################################################
# PUBLIC METHODS
#############################################################################
#############################################################################
# add_message()
#############################################################################
sub add_message {
&App::sub_entry if ($App::trace);
my ($self, $msg) = @_;
if (defined $self->{messages}) {
$self->{messages} .= "\n" . $msg;
}
else {
$self->{messages} = $msg;
}
&App::sub_exit() if ($App::trace);
}
sub get_messages {
&App::sub_entry if ($App::trace);
my ($self) = @_;
my $msgs = $self->{messages};
delete $self->{messages} if ($msgs);
&App::sub_exit($msgs) if ($App::trace);
return($msgs);
}
#############################################################################
# log()
#############################################################################
sub log {
&App::sub_entry if ($App::trace);
my $self = shift;
my ($msg_options);
$msg_options = shift if ($#_ > -1 && ref($_[0]) eq "HASH");
my $msg_level = $msg_options->{level} || 1;
my $log_level = $self->{options}{log_level};
$log_level = 2 if (!defined $log_level);
if (!defined $log_level || $msg_level <= $log_level) {
$self->_log(@_);
}
&App::sub_exit() if ($App::trace);
}
sub _log {
&App::sub_entry if ($App::trace);
my $self = shift;
my $hi_res = $self->{options}{log_hi_res};
my $elapsed = $self->{options}{log_elapsed};
my $timestamp;
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]);
if ($elapsed) {
if (!defined($self->{_last_log_elapsed_time})) {
$self->{_last_log_elapsed_time} = \@timestuff;
}
my $elapsed = Time::HiRes::tv_interval($self->{_last_log_elapsed_time}, \@timestuff);
$timestamp .= " " . sprintf("%.6f", $elapsed);
$self->{_last_log_elapsed_time} = \@timestuff;
}
}
else {
my $time = time();
$timestamp = time2str("%Y-%m-%d %H:%M:%S", $time);
if ($elapsed) {
my $elapsed = $time - $self->{_last_log_elapsed_time};
$timestamp .= " " . $elapsed;
$self->{_last_log_elapsed_time} = $time;
}
}
if ($#_ > 0) {
my $fmt = "[$$] $timestamp " . shift;
printf STDERR $fmt, @_;
}
elsif ($#_ == 0) {
print STDERR "[$$] $timestamp ", @_;
}
&App::sub_exit() if ($App::trace);
}
# NOTE: log rotation always passes an $overwrite = 0, thus implementing the rule
# that log rotation should never overwrite a log file, but only append to it.
sub log_file_open {
&App::sub_entry if ($App::trace);
my ($self, $overwrite) = @_;
my $log_file = $self->{options}{log_file};
if ($log_file) {
if ($self->{log_fh}) {
close($self->{log_fh});
delete $self->{log_fh};
}
if ($log_file =~ /%/) {
$log_file = time2str($log_file, time());
}
if ((defined $overwrite && $overwrite) || (!defined $overwrite && $self->{options}{log_overwrite})) {
open(LOG, "> $log_file") || die "Unable to open $log_file log file: $!";
}
else {
open(LOG, ">> $log_file") || die "Unable to open $log_file log file: $!";
}
open(STDOUT, ">&LOG");
open(STDERR, ">&LOG");
LOG->autoflush(1);
STDOUT->autoflush(1);
STDERR->autoflush(1);
$self->{log_fh} = \*App::Context::LOG;
}
&App::sub_exit() if ($App::trace);
}
#############################################################################
# user()
#############################################################################
sub user {
&App::sub_entry if ($App::trace);
my $self = shift;
my $user = $self->{user} || "guest";
&App::sub_exit($user) if ($App::trace);
$user;
}
sub set_user {
&App::sub_entry if ($App::trace);
my ($self, $user) = @_;
$self->{user} = $user;
&App::sub_exit() if ($App::trace);
}
#############################################################################
# options()
#############################################################################
sub options {
&App::sub_entry if ($App::trace);
my $self = shift;
my $options = ($self->{options} || {});
&App::sub_exit($options) if ($App::trace);
return($options);
}
#############################################################################
# conf()
#############################################################################
sub conf {
&App::sub_entry if ($App::trace);
my $self = shift;
&App::sub_exit($self->{conf}) if ($App::trace);
$self->{conf};
}
#############################################################################
# session()
#############################################################################
sub session {
&App::sub_entry if ($App::trace);
my ($self, $session_id, $args) = @_;
my ($session_class, $session, $options);
$session_id = "default" if (! defined $session_id || $session_id eq "");
$session = $self->{sessions}{$session_id};
if (!$session) {
$options = $self->{options};
$session_class = $options->{session_class} || $self->_default_session_class();
eval {
$self->dbgprint("Context->new(): session_class=$session_class (", join(",",%$options), ")")
if ($App::DEBUG && $self->dbg(1));
if (defined $args) {
$args = { %$args };
}
else {
$args = {};
}
$args->{context} = $self;
$args->{name} = $session_id;
$session = App->new($session_class, "new", $args);
$self->{sessions}{$session_id} = $session;
};
$self->add_message($@) if ($@);
}
&App::sub_exit($session) if ($App::trace);
return($session);
}
#sub new_session_id {
# &App::sub_entry if ($App::trace);
# my ($self) = @_;
# my $session_id = "user";
# &App::sub_exit($session_id) if ($App::trace);
# return($session_id);
#}
sub set_current_session {
&App::sub_entry if ($App::trace);
my ($self, $session_id) = @_;
$session_id = "default" if (!defined $session_id || $session_id ne "");
$self->{session} = $self->session($session_id);
&App::sub_exit() if ($App::trace);
}
sub restore_default_session {
&App::sub_entry if ($App::trace);
my ($self) = @_;
$self->{session} = $self->{sessions}{default};
&App::sub_exit() if ($App::trace);
}
sub clear_session {
&App::sub_entry if ($App::trace);
my ($self, $session_id, @service_types) = @_;
$session_id = "default" if (!defined $session_id || $session_id ne "");
my $session = $self->{sessions}{$session_id};
if ($#service_types == -1) {
my %service_type_seen;
foreach my $service_type (keys %{$session->{store}}) {
$service_type_seen{$service_type} = 1;
push (@service_types, $service_type);
}
foreach my $service_type (keys %{$session->{cache}}) {
if (!$service_type_seen{$service_type}) {
push (@service_types, $service_type);
}
}
}
foreach my $service_type (@service_types) {
if ($service_type ne "SessionObject") {
delete $session->{store}{$service_type};
delete $session->{cache}{$service_type};
}
else {
my $special_attrib = "ctype|cname|u|p|eu|theme";
my ($services, $default_session_object);
$services = $session->{store}{SessionObject};
if ($services) {
foreach my $so_name (keys %$services) {
delete $services->{$so_name} if ($so_name ne "default");
}
}
$services = $session->{cache}{SessionObject};
if ($services) {
foreach my $so_name (keys %$services) {
delete $services->{$so_name} if ($so_name ne "default");
}
}
$default_session_object = $session->{store}{SessionObject}{default};
if ($default_session_object) {
foreach my $attrib (keys %$default_session_object) {
delete $default_session_object->{$attrib} if ($attrib !~ /^$special_attrib$/);
}
}
$default_session_object = $session->{cache}{SessionObject}{default};
if ($default_session_object) {
foreach my $attrib (keys %$default_session_object) {
delete $default_session_object->{$attrib} if ($attrib !~ /^$special_attrib$/);
}
}
}
}
#else {
# delete $self->{sessions}{$session_id};
# if ($session eq $self->{session}) {
# delete $self->{session};
# $self->{session} = $self->session($session_id);
# }
#}
&App::sub_exit() if ($App::trace);
}
#############################################################################
# PUBLIC METHODS
#############################################################################
sub state {
&App::sub_entry if ($App::trace);
my ($self) = @_;
my $datetime = time2str("%Y-%m-%d %H:%M:%S", time());
my $class = ref($self);
my $state = "Context: [$class]\n[$datetime]\n";
$state .= "\n";
$state .= $self->_state();
&App::sub_exit($state) if ($App::trace);
return($state);
}
sub _state {
&App::sub_entry if ($App::trace);
my ($self) = @_;
my $state = "";
my ($event, @args, $args_str);
$state .= "Scheduled Events:\n";
foreach $event (@{$self->{scheduled_events}}) {
@args = ();
@args = @{$event->{args}} if ($event->{args});
$args_str = join(",",@args);
$state .= sprintf(" %19s %5s %-32s %s\n",
time2str("%Y-%m-%d %H:%M:%S",$event->{time}),
$event->{interval},
$event->{tag},
"$event->{name}.$event->{method}($args_str)");
}
$state .= "\n";
$state .= "Event Loop Extensions:\n";
my ($obj, $method, $args);
foreach my $event_loop_extension (@{$self->{event_loop_extensions}}) {
($obj, $method, $args) = @$event_loop_extension;
@args = ();
@args = @$args if ($args);
$args_str = join(",",@args);
$state .= sprintf(" %s\n", "$obj->{name}.$method($args_str)");
}
&App::sub_exit($state) if ($App::trace);
return($state);
}
#############################################################################
# dbg()
#############################################################################
my %debug_scope;
sub dbg {
my ($self, $level) = @_;
return 0 if (! $App::DEBUG);
$level = 1 if (!defined $level);
return 0 if (defined $level && $App::DEBUG < $level);
my ($debug_scope, $stacklevel);
my ($package, $file, $line, $subroutine, $hasargs, $wantarray);
$debug_scope = (ref($self) eq "") ? \%debug_scope : $self->{debug_scope};
$stacklevel = 1;
($package, $file, $line, $subroutine, $hasargs, $wantarray) = caller($stacklevel);
while (defined $subroutine && $subroutine eq "(eval)") {
$stacklevel++;
($package, $file, $line, $subroutine, $hasargs, $wantarray) = caller($stacklevel);
}
return 1 if (! defined $debug_scope);
return 1 if (! %$debug_scope);
return 1 if (defined $debug_scope->{$package});
return 1 if (defined $debug_scope->{$subroutine});
return 0;
}
#############################################################################
# dbgprint()
#############################################################################
sub dbgprint {
my $self = shift;
if (defined $App::options{debug_file}) {
print $App::DEBUG_FILE $$, ": ", @_, "\n";
}
else {
print STDERR "Debug: ", @_, "\n";
}
}
#############################################################################
# dbglevel()
#############################################################################
sub dbglevel {
my ($self, $dbglevel) = @_;
$App::DEBUG = $dbglevel if (defined $dbglevel);
return $App::DEBUG;
}
#############################################################################
# debug_scope()
#############################################################################
sub debug_scope {
my $self = shift;
my $debug_scope = $self->{debug_scope};
if (!defined $debug_scope) {
$debug_scope = {};
$self->{debug_scope} = $debug_scope;
}
$debug_scope;
}
#############################################################################
# dump()
#############################################################################
use Data::Dumper;
sub dump {
my ($self) = @_;
my $d = Data::Dumper->new([ $self ], [ "context" ]);
$d->Indent(1);
return $d->Dump();
}
#############################################################################
# PROTECTED METHODS
#############################################################################
#############################################################################
# dispatch_events()
#############################################################################
sub dispatch_events {
&App::sub_entry if ($App::trace);
my ($self, $max_events_occurred) = @_;
$self->dispatch_events_begin();
my $events = $self->{events};
my ($event, $service, $name, $method, $args);
my $results = "";
my $show_current_session_object = 1;
eval {
while ($#$events > -1) {
$event = shift(@$events);
($service, $name, $method, $args) = @$event;
$results = $self->call($service, $name, $method, $args);
$show_current_session_object = 0;
}
my ($type, $name);
if ($show_current_session_object) {
$type = $self->so_get("default","ctype","SessionObject");
$name = $self->so_get("default","cname","default");
}
if ($show_current_session_object && $type && $name) {
$results = $self->service($type, $name);
}
$self->send_results($results);
};
if ($@) {
$self->send_error($@);
}
if ($self->{options}{debug_context}) {
print STDERR $self->dump();
}
$self->dispatch_events_finish();
&App::sub_exit() if ($App::trace);
}
sub dispatch_events_begin {
&App::sub_entry if ($App::trace);
my ($self) = @_;
&App::sub_exit() if ($App::trace);
}
sub dispatch_events_finish {
&App::sub_entry if ($App::trace);
my ($self) = @_;
$self->shutdown(); # assume we won't be doing anything else (this can be overridden)
&App::sub_exit() if ($App::trace);
}
sub extend_event_loop {
&App::sub_entry if ($App::trace);
my ($self, $obj, $method, $args) = @_;
$args = [] if (!$args);
push(@{$self->{event_loop_extensions}}, [ $obj, $method, $args ]);
&App::sub_exit() if ($App::trace);
}
sub call {
&App::sub_entry if ($App::trace);
my ($self, $service_type, $name, $method, $args) = @_;
my ($contents, $result, $service);
if ($service_type eq "Context") {
$service = $self;
}
else {
$service = $self->service($service_type, $name);
}
if (!$service) {
$result = "Service not defined: $service_type($name)\n";
}
elsif (!$service->isa("App::Widget") && $method && $service->can($method)) {
my @args = (ref($args) eq "ARRAY") ? (@$args) : $args;
my @results = $service->$method(@args);
if ($#results == -1) {
$result = $service->internals();
}
elsif ($#results == 0) {
$result = $results[0];
}
else {
$result = \@results;
}
}
elsif ($service->can("handle_event")) {
my @args = (ref($args) eq "ARRAY") ? (@$args) : $args;
$result = $service->handle_event($name, $method, @args);
}
else {
if ($method eq "contents") {
$result = $service;
}
else {
$result = "Method not defined on Service: $service($name).$method($args)\n";
}
}
&App::sub_exit($result) if ($App::trace);
return($result);
}
#############################################################################
# send_results()
#############################################################################
sub send_results {
&App::sub_entry if ($App::trace);
my ($self, $results) = @_;
my ($serializer, $returntype);
if (ref($results)) {
$returntype = $self->{returntype};
$serializer = $self->serializer($returntype);
$results = $serializer->serialize($results);
}
if ($self->{messages}) {
my $msg = $self->{messages};
$self->{messages} = "";
$msg =~ s/<br>/\n/g;
print $msg, "\n";
}
else {
print $results, "\n";
}
&App::sub_exit() if ($App::trace);
}
sub send_error {
&App::sub_entry if ($App::trace);
my ($self, $errmsg) = @_;
print <<EOF;
-----------------------------------------------------------------------------
AN ERROR OCCURRED in App::Context->dispatch_events()
-----------------------------------------------------------------------------
$errmsg
-----------------------------------------------------------------------------
Additional messages from earlier stages may be relevant if they exist below.
-----------------------------------------------------------------------------
$self->{messages}
EOF
&App::sub_exit() if ($App::trace);
}
#############################################################################
# SCHEDULED EVENTS
#############################################################################
# valid attributes:
# REQD: method => "do_it",
# OPT: tag => "tag01", (identifies an event.)
# OPT: service_type => "SessionObject", (method is on a SessionObject rather than on the Context)
# OPT: name => "prog_controller",
# OPT: time => time() + 600,
# OPT: interval => 600,
# OPT: args => [ 1, 2, 3 ],
# OPT: scheduled => 0,
sub schedule_event {
&App::sub_entry if ($App::trace);
my $self = shift;
my %event = @_;
my $scheduled_event = $self->{scheduled_event};
my $scheduled_events = $self->{scheduled_events};
if (! defined $event{time}) {
$event{time} = time();
$event{time} += $event{interval} if ($event{interval});
}
my $unschedule = 0;
if (defined $event{scheduled}) {
$unschedule = ! $event{scheduled};
delete $event{scheduled};
}
die "schedule_event(): (tag or method) is a required attribute of an event" if (!$event{tag} && !$event{method});
$self->log({level=>3},"Schedule Event (" . join(",",%event) . ")\n");
my $event;
if ($event{tag}) {
$event = $scheduled_event->{$event{tag}};
}
if ($event) {
foreach my $key (keys %event) {
$event->{$key} = $event{$key};
}
}
else {
$scheduled_event->{$event{tag}} = \%event if ($event{tag});
$event = \%event;
}
if ($event->{scheduled}) {
if ($unschedule && $event->{tag}) {
# remove from list of scheduled events
for (my $i = $#$scheduled_events; $i >= 0; $i--) {
if ($scheduled_events->[$i]{tag} eq $event->{tag}) {
splice(@$scheduled_events, $i, 1); # remove the event
$event->{scheduled} = 0;
last;
}
}
}
}
else {
if (!$unschedule) {
push(@$scheduled_events, $event);
$event->{scheduled} = 1;
}
}
&App::sub_exit() if ($App::trace);
}
sub get_current_events {
&App::sub_entry if ($App::trace);
my ($self, $events, $time) = @_;
$time = time() if (!$time);
my $time_of_next_event = 0;
@$events = ();
my $scheduled_event = $self->{scheduled_event};
my $scheduled_events = $self->{scheduled_events};
my $verbose = $self->{verbose};
my ($event);
# note: go in reverse order so that the splice() doesn't throw our indexes off
# we do unshift() to keep events executing in FIFO order for a particular time
for (my $i = $#$scheduled_events; $i >= 0; $i--) {
$event = $scheduled_events->[$i];
$self->log({level=>5},"Checking event: time=$time [$event->{time}, every $event->{interval}] $event->{method}().\n");
if ($event->{time} <= $time) {
unshift(@$events, $event);
if ($event->{time} && $event->{interval}) {
$event->{time} += $event->{interval}; # reschedule the event
$self->log({level=>5},"Event Rescheduled: time=$time [$event->{time}, every $event->{interval}] $event->{method}().\n");
if ($time_of_next_event == 0 || $event->{time} < $time_of_next_event) {
$time_of_next_event = $event->{time};
}
}
else {
$self->log({level=>5},"Event Removed: time=$time [$event->{time}, every $event->{interval}] $event->{method}().\n");
splice(@$scheduled_events, $i, 1); # remove the (one-time) event
$event->{scheduled} = 0;
}
}
else {
if ($time_of_next_event == 0 || $event->{time} < $time_of_next_event) {
$time_of_next_event = $event->{time};
}
}
}
&App::sub_exit($time_of_next_event) if ($App::trace);
return($time_of_next_event);
}
# NOTE: send_event() is similar to call(). I ought to resolve this.
sub send_event {
&App::sub_entry if ($App::trace);
my ($self, $event) = @_;
my $method = $event->{method};
my @args = $event->{args} ? @{$event->{args}} : ();
my $name = $event->{name};
my $service_type = $event->{service_type};
$service_type = "SessionObject" if (!$service_type && $name);
my (@results);
if ($name) {
my $service = $self->service($service_type, $name);
$self->log({level=>3},"Send Event: $service_type($name).$method(@args)\n");
@results = $service->$method(@args);
}
else {
$self->log({level=>3},"Send Event: $method(@args)\n");
@results = $self->$method(@args);
}
&App::sub_exit(@results) if ($App::trace);
if (wantarray()) {
return(@results);
}
else {
if ($#results == -1) {
return(undef);
}
elsif ($#results == 0) {
return($results[0]);
}
else {
return(\@results);
}
}
}
# NOTE: The baseline context implements the API for asynchronous events
# in a simplistic, sequential way.
# It merely sends the event, then sends the callback event.
# See App::Context::Server for a context that spawns processes which
# execute the event. When the process exits, the callback_event is fired.
# See App::Context::Cluster for a context that sends a message to an
# available cluster node for executing. When the node reports back that
# it has completed the task, the callback_event is fired.
sub send_async_event {
&App::sub_entry if ($App::trace);
my ($self, $event, $callback_event) = @_;
my $event_token = $self->send_async_event_in_process($event, $callback_event);
&App::sub_exit($event_token) if ($App::trace);
return($event_token);
}
sub send_async_event_in_process {
&App::sub_entry if ($App::trace);
my ($self, $event, $callback_event) = @_;
my $errnum = 0;
my $errmsg = "";
my $event_token = "local-$$";
my ($returnval);
eval {
$returnval = $self->send_event($event);
};
if ($@) {
$errmsg = $@;
$errnum = 1;
$self->log("ERROR: send_async_event_now() $event->{name}.$event->{method} : $errmsg\n");
}
if ($callback_event) {
$callback_event->{args} = [] if (! $callback_event->{args});
push(@{$callback_event->{args}}, {event_token => $event_token, returnval => $returnval, errnum => $errnum, errmsg => $errmsg});
$self->send_event($callback_event);
}
&App::sub_exit($event_token) if ($App::trace);
return($event_token);
}
sub wait_for_event {
&App::sub_entry if ($App::trace);
my ($self, $event_token) = @_;
&App::sub_exit() if ($App::trace);
}
# NOTE: This send_message() and send_async_message() can be on the App::Context
# class to allow a program in any context to send this kind of message.
# (The only downside is a dependency on IO::Socket::INET.)
sub send_async_message {
&App::sub_entry if ($App::trace);
my ($self, $host, $port, $message, $await_return_value, $timeout, $server_close) = @_;
my $pid = $self->fork();
if (!$pid) { # running in child
$self->send_message($host, $port, $message, $await_return_value, $timeout, $server_close);
$self->exit(0);
}
&App::sub_exit() if ($App::trace);
}
# NOTE: $messages that start with "RV-" wait for a return value.
# $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
# ------------------- ------------- ---------------------- ---------------------
# 0 0 write/close read/close
# 0 1 write/read/close read/close
# 1 0 write/read/write/close read/write/read/close
# 1 1 write/read/close read/write/close
sub send_message {
&App::sub_entry if ($App::trace);
my ($self, $host, $port, $message, $await_return_value, $timeout, $server_close) = @_;
my $verbose = $self->{verbose};
if (!$port && $host =~ /^([^:]+):([0-9]+)$/) {
$host = $1;
$port = $2;
}
my $send_socket = IO::Socket::INET->new(
PeerAddr => $host,
PeerPort => $port,
Proto => "tcp",
Type => SOCK_STREAM,
ReuseAddr => 1,
);
my ($send_fd);
$send_fd = fileno($send_socket) if ($send_socket);
$self->log({level=>3},"($send_fd) send_message($host, $port, $message)\n");
my $response = "";
my $rv = $await_return_value ? "RV-" : "";
my $sc = $server_close ? "SC-" : "";
if ($send_socket) {
eval {
$send_socket->autoflush(1) if ($await_return_value || $server_close);
$send_socket->print("$rv$sc$message\n");
if ($await_return_value || $server_close) {
# $send_socket->timeout($timeout) if ($timeout); # doesn't seem to work
$response = $send_socket->getline();
$response =~ s/[\r\n]+$//;
$send_socket->print("EOF\n") if ($await_return_value && !$server_close);
}
close($send_socket);
};
if ($@) {
$response = "SEND ERROR: $@";
}
}
else {
$response = "CONNECT ERROR: $!";
}
$self->log({level=>3},"send_message($host, $port, ...) => [$response]\n");
&App::sub_exit($response) if ($App::trace);
return($response);
}
sub fork {
&App::sub_entry if ($App::trace);
my ($self) = @_;
my $pid = fork();
if (!$pid) { # in the child process
# $self->{is_child} = 1; # I might need to add this sometime, but not now
$self->shutdown_unshareable_resources();
}
else {
$self->log({level=>4},"Child $pid started.\n");
}
&App::sub_exit($pid) if ($App::trace);
return($pid);
}
sub exit {
my ($self, $exitval) = @_;
$self->shutdown();
exit($exitval);
}
#############################################################################
# shutdown_unshareable_resources()
#############################################################################
sub shutdown_unshareable_resources {
my $self = shift;
my ($conf, $repdef, $repname, $instance);
my ($class, $method, $args, $argidx, $repcache);
$self->dbgprint("Context->shutdown_unshareable_resources()")
if ($App::DEBUG && $self->dbg(1));
$repcache = $self->{session}{cache}{Repository};
if (defined $repcache && ref($repcache) eq "HASH") {
foreach $repname (keys %$repcache) {
$instance = $repcache->{$repname};
$instance->_shutdown_unshareable_resources();
delete $repcache->{$repname};
}
}
}
#############################################################################
# shutdown()
#############################################################################
sub shutdown {
my ($self, $end_cd) = @_;
my ($conf, $repdef, $repname, $instance);
my ($class, $method, $args, $argidx, $repcache);
if (!$self->{shutdown_complete}) {
my $options = $self->{options};
my $profiler = $options->{"app.Context.profiler"};
if ($profiler) {
$self->profile_stop("main");
$self->finish_profiler_log($end_cd);
}
$self->dbgprint("Context->shutdown()")
if ($App::DEBUG && $self->dbg(1));
$repcache = $self->{session}{cache}{Repository};
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};
}
}
$self->{shutdown_complete} = 1;
}
}
sub DESTROY {
my ($self) = @_;
$self->shutdown("D");
}
#############################################################################
# response()
#############################################################################
sub response {
&App::sub_entry if ($App::trace);
my $self = shift;
my $response = $self->{response};
if (!defined $response) {
#################################################################
# RESPONSE
#################################################################
my $response_class = $self->get_option("response_class", "App::Response");
eval {
$response = App->new($response_class, "new", $self, $self->{options});
};
$self->{response} = $response;
$self->add_message("Context::response(): $@") if ($@);
}
&App::sub_exit($response) if ($App::trace);
return($response);
}
#############################################################################
# CONTROLLING THE profiler_log
#############################################################################
sub init_profiler_log {
&App::sub_entry if ($App::trace);
my ($self) = @_;
my $options = $self->{options};
my $profiler = $options->{"app.Context.profiler"};
if ($profiler) {
$self->profile_start("main");
$self->start_profiler_log();
}
&App::sub_exit() if ($App::trace);
}
sub start_profiler_log {
&App::sub_entry if ($App::trace);
my ($self) = @_;
my $profile_state = $self->{profile_state};
if (!$profile_state) {
$self->profile_start("main");
$profile_state = $self->{profile_state};
}
my $options = $self->{options};
my $app = $options->{app} || "app";
my $context_abbr = ref($self);
$context_abbr =~ s/^App::Context:://;
my $host = $options->{host} || "localhost";
my $username = $self->user();
my $events = $self->{events};
my $events_str = "";
if ($events && $#$events > -1) {
$events_str .= ($#$events + 1);
foreach my $event (@$events) {
$events_str .= ":$event->[1].$event->[2]";
if ($event->[3] && $#{$event->[3]} > -1) {
$events_str .= "(" . join(",",@{$event->[3]}) . ")";
}
}
}
my $time = $profile_state->{last_timeofday}[0] || time();
my $start_dttm = time2str("%Y-%m-%d %H:%M:%S", $time);
my $info = $self->get_proc_info2();
my $pinfo = $info->{$$};
my $start_mem_mb = $pinfo->{vsize}/1048576;
my $repname = $options->{"app.Context.profiler_repository"};
my $rep = $repname ? $self->repository($repname) : undef;
if ($rep) {
eval {
if (!$profile_state->{profiler_log_id}) {
$rep->insert("app_profiler_log",
["context", "host", "username", "app", "start_dttm", "start_mem_mb", "events"],
[$context_abbr, $host, $username, $app, $start_dttm, $start_mem_mb, $events_str],
{ last_inserted_id => 1 });
$profile_state->{profiler_log_id} = $rep->last_inserted_id();
}
};
}
else {
$self->log("Start : (Mem %.1f MB) %s [%s\@%s:%s]\n", $start_mem_mb, $context_abbr, $username, $host, $app);
}
&App::sub_exit() if ($App::trace);
}
sub update_profiler_log {
&App::sub_entry if ($App::trace);
my ($self, $app_scope, $content_name, $app_scope_id_type, $app_scope_id) = @_;
my $options = $self->{options};
my $repname = $options->{"app.Context.profiler_repository"};
my $rep = $repname ? $self->repository($repname) : undef;
my $profile_state = $self->{profile_state};
my $profiler_log_id = $profile_state->{profiler_log_id};
if (defined $app_scope) {
$profile_state->{app_scope} = $app_scope;
}
elsif (defined $profile_state->{app_scope}) {
$app_scope = $profile_state->{app_scope};
}
if (defined $app_scope_id) {
$profile_state->{app_scope_id} = $app_scope_id;
$profile_state->{app_scope_id_type} = $app_scope_id_type;
}
elsif (defined $profile_state->{app_scope_id}) {
$app_scope_id = $profile_state->{app_scope_id};
$app_scope_id_type = $profile_state->{app_scope_id_type};
}
if (defined $content_name) {
$profile_state->{content_name} = $content_name;
}
elsif (defined $profile_state->{content_name}) {
$content_name = $profile_state->{content_name};
}
if ($rep) {
if ($profiler_log_id) {
eval {
$rep->update("app_profiler_log", { "profiler_log_id.eq" => $profiler_log_id },
["app_scope", "content_name", "app_scope_id_type", "app_scope_id"],
[$app_scope, $content_name, $app_scope_id_type, $app_scope_id]);
};
}
}
else {
$self->log("Update: %s [%s] (%s:%s)\n", $app_scope, $content_name, $app_scope_id_type, $app_scope_id);
}
&App::sub_exit() if ($App::trace);
}
sub finish_profiler_log {
&App::sub_entry if ($App::trace);
my ($self, $end_cd) = @_;
$end_cd ||= "F"; # assume we finish using normal processing
my $profile_state = $self->{profile_state};
my $profile_stats = $self->profile_stats();
my $profiler_log_id = $profile_state->{profiler_log_id};
my $app_scope = $profile_state->{app_scope};
my $content_name = $profile_state->{content_name};
my $app_scope_id_type = $profile_state->{app_scope_id_type};
my $app_scope_id = $profile_state->{app_scope_id};
my $content_length = $profile_state->{content_length} || 0;
my $time = $profile_state->{last_timeofday}[0] || time();
my $end_dttm = time2str("%Y-%m-%d %H:%M:%S", $time);
my $run_main_time = $profile_stats->{main}{cumul_time} || 0; # DONE
my $run_event_time = $profile_stats->{event}{cumul_time} || 0; # DONE:HTTP, TBD:Context
my $run_db_time = $profile_stats->{db}{cumul_time} || 0; # DONE
my $run_file_time = $profile_stats->{file}{cumul_time} || 0; # TBD (application)
my $run_net_time = $profile_stats->{net}{cumul_time} || 0; # TBD (application)
my $run_aux1_label = $profile_state->{aux1_label};
my $run_aux2_label = $profile_state->{aux2_label};
my ($run_aux1_time, $run_aux2_time);
$run_aux1_time = $run_aux1_label ? ($profile_stats->{$run_aux1_label}{cumul_time} || 0) : 0;
$run_aux2_time = $run_aux2_label ? ($profile_stats->{$run_aux2_label}{cumul_time} || 0) : 0;
my $run_xfer_time = $profile_stats->{xfer}{cumul_time} || 0; # DONE
my $num_net_calls = $profile_stats->{net}{count} || 0; # DONE
my $num_db_calls = $profile_stats->{db}{count} || 0; # DONE
my $num_db_rows_read = $profile_stats->{db}{nrows_read} || 0; # DONE
my $num_db_rows_write = $profile_stats->{db}{nrows_write} || 0; # DONE
my $info = $self->get_proc_info2();
my $pinfo = $info->{$$};
my $end_mem_mb = $pinfo->{vsize}/1048576;
my $cpu_time = ($pinfo->{cutime} + $pinfo->{cstime}) || 0;
my $run_time = $self->profile_run_time();
my $run_other_time = $run_time - ($run_event_time + $run_main_time + $run_db_time + $run_file_time + $run_net_time + $run_xfer_time + $run_aux1_time + $run_aux2_time);
$run_other_time = 0 if ($run_other_time < 1e-6);
my $options = $self->{options};
my $repname = $options->{"app.Context.profiler_repository"};
my $rep = $repname ? $self->repository($repname) : undef;
if ($rep) {
if ($profiler_log_id) {
eval {
$rep->update("app_profiler_log", { "profiler_log_id.eq" => $profiler_log_id },
["app_scope", "content_name", "app_scope_id_type", "app_scope_id",
"end_cd", "end_dttm", "end_mem_mb", "cpu_time",
"run_time", "run_main_time", "run_event_time",
"run_db_time", "run_file_time", "run_net_time",
"run_aux1_label", "run_aux2_label",
"run_aux1_time", "run_aux2_time", "run_other_time",
"run_xfer_time", "content_length", "num_net_calls",
"num_db_calls", "num_db_rows_read", "num_db_rows_write"],
[$app_scope, $content_name, $app_scope_id_type, $app_scope_id,
$end_cd, $end_dttm, $end_mem_mb, $cpu_time,
$run_time, $run_main_time, $run_event_time,
$run_db_time, $run_file_time, $run_net_time,
$run_aux1_label, $run_aux2_label,
$run_aux1_time, $run_aux2_time, $run_other_time,
$run_xfer_time, $content_length, $num_net_calls,
$num_db_calls, $num_db_rows_read, $num_db_rows_write]);
};
delete $profile_state->{profiler_log_id};
}
}
else {
my $aux_fmt = "";
my (@aux_values);
if ($run_aux1_label) {
$aux_fmt .= " $run_aux1_label=%.2f";
push(@aux_values, $run_aux1_time);
}
if ($run_aux2_label) {
$aux_fmt .= " $run_aux2_label=%.2f";
push(@aux_values, $run_aux2_time);
}
$self->log("Finish: (Mem %.1f MB) cpu=%.2f run=%.2f run[main=%.2f event=%.2f db=%.2f/%d(r%d:w%d) file=%.2f net=%.2f/%d${aux_fmt} other=%.2f xfer=%.2f] (Content %s bytes)\n",
$end_mem_mb, $cpu_time, $run_time, $run_main_time, $run_event_time,
$run_db_time, $num_db_calls, $num_db_rows_read, $num_db_rows_write, $run_file_time, $run_net_time, $num_net_calls,
@aux_values, $run_other_time, $run_xfer_time, $content_length);
}
&App::sub_exit() if ($App::trace);
}
#############################################################################
# PROFILING
# $context->profile_start($key, $replace);
# $context->profile_stop($key);
# $context->profile_run_time();
# $context->profile_stats();
# $context->profile_clear();
# $context->profile_log();
# $context->set_profile_state_value($state_var, $state_value);
# $context->_profile_accumulate($profile_stats, $key, $time_elapsed, $key_started);
#############################################################################
sub profile_start {
my ($self, $key, $replace) = @_;
my $timeofday = [ Time::HiRes::gettimeofday() ];
my $profile_state = $self->{profile_state};
if (!$profile_state) {
$profile_state = {
first_timeofday => $timeofday,
last_timeofday => $timeofday,
key_stack => [],
key_started => 1,
};
$self->{profile_state} = $profile_state;
}
my $profile_stats = $self->{profile_stats};
if (!$profile_stats) {
$profile_stats = { db => { nrows_read => 0, nrows_write => 0 }, };
$self->{profile_stats} = $profile_stats;
}
my $last_timeofday = $profile_state->{last_timeofday};
my $key_stack = $profile_state->{key_stack};
my $key_started = $profile_state->{key_started};
my $last_key = ($#$key_stack > -1) ? $key_stack->[$#$key_stack] : "";
if ($last_key) {
my $time_elapsed = Time::HiRes::tv_interval($last_timeofday, $timeofday);
$self->_profile_accumulate($profile_stats, $last_key, $time_elapsed, $key_started);
}
if ($#$key_stack > 100) {
splice(@$key_stack, 0, 50);
}
if (!$replace || $#$key_stack == -1) {
push(@$key_stack, $key);
}
else {
$key_stack->[$#$key_stack] = $key;
}
$profile_state->{key_started} = 1;
$profile_state->{last_timeofday} = $timeofday;
}
sub profile_stop {
my ($self, $key) = @_;
my $profile_state = $self->{profile_state};
my $profile_stats = $self->{profile_stats};
if ($profile_state && $profile_stats) {
my $last_timeofday = $profile_state->{last_timeofday};
my $key_stack = $profile_state->{key_stack};
my $key_started = $profile_state->{key_started};
my $last_key = ($#$key_stack > -1) ? $key_stack->[$#$key_stack] : "";
my $timeofday = [ Time::HiRes::gettimeofday() ];
my $time_elapsed = Time::HiRes::tv_interval($last_timeofday, $timeofday);
$profile_state->{last_timeofday} = $timeofday;
$self->_profile_accumulate($profile_stats, $last_key, $time_elapsed, $key_started);
while ($#$key_stack > -1) {
my $last_key = pop(@$key_stack);
last if ($last_key eq $key);
}
$profile_state->{key_started} = 0;
}
}
sub _profile_accumulate {
my ($self, $profile_stats, $key, $time_elapsed, $key_started) = @_;
my $stats = $profile_stats->{$key};
if (!defined $stats) {
$stats = {
count => 1,
cumul_time => $time_elapsed,
min_time => $time_elapsed,
max_time => $time_elapsed,
sample_time => $time_elapsed,
};
$profile_stats->{$key} = $stats;
}
else {
$stats->{cumul_time} += $time_elapsed;
if ($key_started) {
$stats->{count}++;
my $sample_time = $stats->{sample_time};
if ($sample_time > 0) {
$stats->{min_time} = $sample_time if ($sample_time < $stats->{min_time});
$stats->{max_time} = $sample_time if ($sample_time > $stats->{max_time});
}
$stats->{sample_time} = $time_elapsed;
}
else {
$stats->{sample_time} += $time_elapsed;
}
}
}
sub profile_run_time {
my ($self) = @_;
my $profile_state = $self->{profile_state};
my $time_elapsed = 0;
if ($profile_state) {
my $first_timeofday = $profile_state->{first_timeofday};
my $last_timeofday = $profile_state->{last_timeofday};
$time_elapsed = Time::HiRes::tv_interval($first_timeofday, $last_timeofday);
}
return($time_elapsed);
}
sub profile_stats {
my ($self) = @_;
return($self->{profile_stats} || {});
}
sub profile_clear {
my ($self) = @_;
delete $self->{profile_stats};
delete $self->{profile_state};
}
sub set_profile_state_value {
my ($self, $state_var, $state_value) = @_;
$self->{profile_state}{$state_var} = $state_value;
}
sub profile_log {
my ($self) = @_;
my $profile_stats = $self->profile_stats();
$self->log("PROFILE: cumultime count avgtime mintime maxtime key\n");
my ($stats);
foreach my $key (sort { $profile_stats->{$b}{cumul_time} <=> $profile_stats->{$a}{cumul_time} } keys %$profile_stats) {
$stats = $profile_stats->{$key};
if ($stats->{count}) {
$self->log("PROFILE: %10.4f %10d %8.4f %8.4f %8.4f %s\n",
$stats->{cumul_time},
$stats->{count},
$stats->{cumul_time}/$stats->{count},
$stats->{min_time},
$stats->{max_time},
$key);
}
}
}
#############################################################################
# SYSTEM AND PROCESS INFORMATION
#############################################################################
# /proc/meminfo
# total: used: free: shared: buffers: cached:
# Mem: 525942784 468914176 57028608 0 69124096 51593216
# Swap: 1069268992 56954880 1012314112
# MemTotal: 513616 kB
# MemFree: 55692 kB
# MemShared: 0 kB
# Buffers: 67504 kB
# Cached: 42328 kB
# SwapCached: 8056 kB
# Active: 171720 kB
# ActiveAnon: 88224 kB
# ActiveCache: 83496 kB
# Inact_dirty: 22032 kB
# Inact_laundry: 3120 kB
# Inact_clean: 5572 kB
# Inact_target: 40488 kB
# HighTotal: 0 kB
# HighFree: 0 kB
# LowTotal: 513616 kB
# LowFree: 55692 kB
# SwapTotal: 1044208 kB
# SwapFree: 988588 kB
# /proc/loadavg
# 0.02 0.12 0.15 1/138 30412
# This only works on Linux (as far as I know)
sub get_sys_info {
my ($self) = @_;
my $info = {};
# print "FILE: /proc/meminfo\n";
if (open(App::Context::FILE, "/proc/meminfo")) {
while (<App::Context::FILE>) {
if (/^([A-Za-z]+):\s*([0-9]+)/) {
$info->{lc($1)} = $2;
# print ">>> $1 = $2\n";
}
}
close(App::Context::FILE);
}
# print "FILE: /proc/loadavg\n";
if (open(App::Context::FILE, "/proc/loadavg")) {
while (<App::Context::FILE>) {
if (/^([0-9.]+)\s+([0-9.]+)\s+([0-9.]+)\s+([0-9]+)\/([0-9]+)\s+([0-9]+)/) {
$info->{load} = $1;
$info->{load5} = $2;
$info->{load15} = $3;
$info->{runprocs} = $4;
$info->{nprocs} = $5;
$info->{unknown} = $6;
# print ">>> [$1][$2][$3][$4][$5][$6]\n";
}
}
close(App::Context::FILE);
}
return($info);
}
# /proc/$$/status
# Name: ksh
# State: S (sleeping)
# Tgid: 29147
# Pid: 29147
# PPid: 29146
# TracerPid: 0
# Uid: 102 102 102 102
# Gid: 205 205 205 205
# FDSize: 32
# Groups: 205 201 202 214 3000 203 217
# VmSize: 1624 kB
# VmLck: 0 kB
# VmRSS: 608 kB
# VmData: 124 kB
# VmStk: 12 kB
# VmExe: 176 kB
# VmLib: 1292 kB
# SigPnd: 0000000000000000
# SigBlk: 0000000000000000
# SigIgn: 8000000000380000
# SigCgt: 0000000000016007
# CapInh: 0000000000000000
# CapPrm: 0000000000000000
# CapEff: 0000000000000000
sub get_proc_info {
my ($self, @pids) = @_;
@pids = ($$) if ($#pids == -1);
my ($pid, $proc);
my $procs = {};
foreach $pid (@pids) {
$proc = {};
$procs->{$pid} = $proc;
# print "FILE: /proc/$$/status\n";
if (open(App::Context::FILE, "/proc/$$/status")) {
while (<App::Context::FILE>) {
if (/^Vm([A-Za-z]+):\s*([0-9]+)/) {
$proc->{lc($1)} = $2;
}
}
close(App::Context::FILE);
$proc->{text} = $proc->{exe} + $proc->{lib};
}
else {
$self->log("ERROR: Can't open /proc/$$/status: $!");
}
}
return($procs);
}
# http://www.comptechdoc.org/os/linux/howlinuxworks/linux_hlproc.html
#stat - Status information about the process used by the ps(1) command. Fields are:
# 31137 (bash) S 19885 31137 31137 34841 651 0 1450
# 185030 316 14024 1 3 687 715 14 0 0
# 0 1792102651 4403200 361 4294967295 134512640 135217536 3221217344 3221216648 1074425592
# 0 65536 3686404 1266761467 3222400107 0 0 17 2
# 1. pid - Process id
# 2. comm - The executable filename
# 3. state - R (running), S(sleeping interruptable), D(sleeping), Z(zombie), or T(stopped on a signal).
# 4. ppid - Parent process ID
# 5. pgrp - Process group ID
# 6. session - The process session ID.
# 7. tty - The tty the process is using
# 8. tpgid - The process group ID of the owning process of the tty the current process is connected to.
# 9. flags - Process flags, currently with bugs
# 10. minflt - Minor faults the process has made
# 11. cminflt - Minor faults the process and its children have made.
# 12. majflt
# 13. cmajflt
# 14. utime - The number of jiffies (processor time) that this process has been scheduled in user mode
# 15. stime - in kernel mode
# 16. cutime - This process and its children in user mode
# 17. cstime - in kernel mode
# 18. counter - The maximum time of this processes next time slice.
# 19. priority - The priority of the nice(1) (process priority) value plus fifteen.
# 20. timeout - The time in jiffies of the process's next timeout.
# 21. itrealvalue - The time in jiffies before the next SIGALRM is sent to the process because of an internal timer.
# 22. starttime - Time the process started after system boot
# 23. vsize - Virtual memory size
# 24. rlim - Current limit in bytes of the rss of the process.
# 25. startcode - The address above which program text can run.
# 26. endcode - The address below which program text can run.
# 27. startstack - The address of the start of the stack
# 28. kstkesp - The current value of esp for the process as found in the kernel stack page.
# 29. kstkeip - The current 32 bit instruction pointer, EIP.
# 30. signal - The bitmap of pending signals
# 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.
sub get_proc_info2 {
my ($self, @pids) = @_;
@pids = ($$) if ($#pids == -1);
my ($pid, $proc);
my $procs = {};
foreach $pid (@pids) {
$proc = {};
$procs->{$pid} = $proc;
# print "FILE: /proc/$$/status\n";
if (open(App::Context::FILE, "/proc/$$/stat")) {
my $line = <App::Context::FILE>;
my @f = split(/ +/, $line);
close(App::Context::FILE);
$proc->{cutime} = $f[15];
$proc->{cstime} = $f[16];
$proc->{vsize} = $f[22];
}
else {
$self->log("ERROR: Can't open /proc/$$/stat: $!");
}
}
return($procs);
}
1;