File Coverage

lib/App/Context.pm

Criterion	Covered	Total	%
statement	312	1253	24.9
branch	149	828	18.0
condition	80	326	24.5
subroutine	29	93	31.1
pod	37	77	48.0
total	607	2577	23.5

#############################################################################
## $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;

=head1 NAME

App::Context - An application framework for web applications, command-line programs, server programs, and web services

=head1 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();

=cut

#############################################################################
# CONSTANTS
#############################################################################

=head1 DOCUMENT STATUS

This documentation is out of date and needs review and revision.

Please start with the L document.

=head1 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).

=cut

#############################################################################
# CLASS GROUP
#############################################################################

=head1 Class Group: Context

The following classes might be a part of the Context Class Group.

=over

=item * Class: App::Context

=item * Class: App::Context::CGI

=item * Class: App::Context::FCGI

=item * Class: App::Context::ModPerl

=item * Class: App::Context::ModPerlRegistry

=item * Class: App::Context::PPerl

=item * Class: App::Context::Cmd

=item * Class: App::Context::Daemon

=item * Class: App::Context::POE

=item * Class: App::Context::SOAP (when acting as a SOAP server)

=item * Class: App::Context::Gtk

=item * Class: App::Context::WxPerl

=back

=cut

#############################################################################
# ATTRIBUTES/CONSTANTS/CLASS VARIABLES/GLOBAL VARIABLES
#############################################################################

=head1 Attributes, Constants, Global Variables, Class Variables

=head2 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

=cut

#############################################################################
# CONSTRUCTOR METHODS
#############################################################################

=head1 Constructor Methods:

=cut

#############################################################################
# new()
#############################################################################

=head2 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',
    );

=cut

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
#############################################################################

=head1 Protected Methods:

The following methods are intended to be called by subclasses of the
current class (or environmental, "main" code).

=cut

#############################################################################
# _init()
#############################################################################

=head2 _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);

=cut

sub _init {
    &App::sub_entry if ($App::trace);
    my ($self, $options) = @_;

    $self->init_profiler_log();

    &App::sub_exit() if ($App::trace);
}

#############################################################################
# PUBLIC METHODS
#############################################################################

=head1 Public Methods: Services

=cut

#############################################################################
# service()
#############################################################################

=head2 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

=cut

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
#############################################################################

=head2 serializer()

=head2 call_dispatcher()

=head2 message_dispatcher()

=head2 resource_locker()

=head2 shared_datastore()

=head2 authentication()

=head2 authorization()

=head2 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();

=cut

# 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()
#############################################################################

=head2 session_object_exists()

    * Signature: $exists = $context->session_object_exists($session_object_name);
    * Param:  $session_object_name     string
    * Return: $exists          boolean
    * Throws:
    * 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.

=cut

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
#############################################################################

=head1 Public Methods: Accessors

=cut

#############################################################################
# get_option()
#############################################################################

=head2 get_option()

    * Signature: $value = $context->get_option($var, $default);
    * Param:  $var             string
    * Param:  $attribute       string
    * Return: $value           string
    * Throws:
    * 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().

=cut

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()
#############################################################################

=head2 get_user_option()

    * Signature: $value = $context->get_user_option($var);
    * Param:  $var             string
    * Return: $value           string
    * Throws:
    * 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.

=cut

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()
#############################################################################

=head2 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:
    * 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");

=cut

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()
#############################################################################

=head2 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:
    * Since:  0.01

    Sample Usage:

    $cname = $context->so_get("default", "cname");
    $width = $context->so_get("main.app.toolbar.calc", "width");

=cut

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()
#############################################################################

=head2 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:
    * 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);

=cut

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()
#############################################################################

=head2 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:
    * Since:  0.01

    Sample Usage:

    $cname = $context->so_default("default", "cname");
    $width = $context->so_default("main.app.toolbar.calc", "width");

=cut

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()
#############################################################################

=head2 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:
    * 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}");

=cut

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()
#############################################################################

=head2 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:
    * 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}");

=cut

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
#############################################################################

=head1 Public Methods: Miscellaneous

=cut

#############################################################################
# add_message()
#############################################################################

=head2 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:
    * Since:  0.01

    Sample Usage:

    $context->add_message("Data was not saved. Try again.");

=cut

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()
#############################################################################

=head2 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:
    * 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");

=cut

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()
#############################################################################

=head2 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:
    * Since:  0.01

    Sample Usage:

    $username = $context->user();

=cut

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()
#############################################################################

=head2 options()

    * Signature: $options = $context->options();
    * Param:  void
    * Return: $options    {}
    * Throws:
    * 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.

=cut

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()
#############################################################################

=head2 conf()

    * Signature: $conf = $context->conf();
    * Param:  void
    * Return: $conf    App::Conf
    * Throws:
    * Since:  0.01

    Sample Usage:

    $conf = $context->conf();

The conf() method returns the user's conf data structure.

=cut

sub conf {
    &App::sub_entry if ($App::trace);
    my $self = shift;
    &App::sub_exit($self->{conf}) if ($App::trace);
    $self->{conf};
}

#############################################################################
# session()
#############################################################################

=head2 session()

    * Signature: $session = $context->session();
    * Signature: $session = $context->session($session_id);
    * Param:  $session_id   string
    * Return: $session      App::Session
    * Throws:
    * 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.

=cut

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
#############################################################################

=head1 Public Methods: Debugging

=cut

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()
#############################################################################

=head2 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.

=cut

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()
#############################################################################

=head2 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));

=cut

sub dbgprint {
    my $self = shift;
    if (defined $App::options{debug_file}) {
        print $App::DEBUG_FILE $$, ": ", @_, "\n";
    }
    else {
        print STDERR "Debug: ", @_, "\n";
    }
}

#############################################################################
# dbglevel()
#############################################################################

=head2 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

=cut

sub dbglevel {
    my ($self, $dbglevel) = @_;
    $App::DEBUG = $dbglevel if (defined $dbglevel);
    return $App::DEBUG;
}

#############################################################################
# debug_scope()
#############################################################################

=head2 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;

=cut

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()
#############################################################################

=head2 dump()

    * Signature: $perl = $context->dump();
    * Param:     void
    * Return:    $perl      text
    * Throws:    App::Exception
    * Since:     0.01

    Sample Usage:

    print $self->dump(), "\n";

=cut

use Data::Dumper;

sub dump {
    my ($self) = @_;
    my $d = Data::Dumper->new([ $self ], [ "context" ]);
    $d->Indent(1);
    return $d->Dump();
}

#############################################################################
# PROTECTED METHODS
#############################################################################

=head1 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.

=cut

#############################################################################
# dispatch_events()
#############################################################################

=head2 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.

=cut

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()
#############################################################################

=head2 send_results()

    * Signature: $context->send_results()
    * Param:     void
    * Return:    void
    * Throws:    App::Exception
    * Since:     0.01

    Sample Usage:

    $context->send_results();

=cut

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//\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 <
-----------------------------------------------------------------------------
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);
}

=head2 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.

=cut

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);
}

=head2 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.

=cut

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()
#############################################################################

=head2 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.

=cut

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()
#############################################################################

=head2 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();

=cut

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()
#############################################################################

=head2 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.

=cut

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 () {
            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 () {
            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 () {
                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 = ;
            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;