App-Context
view release on metacpan or search on metacpan
lib/App/Context.pm view on Meta::CPAN
#############################################################################
## $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<App::quickstart> 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).
lib/App/Context.pm view on Meta::CPAN
$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: <none>
* Since: 0.01
Sample Usage:
$context->so_set("default", "cname", "main_screen");
$context->so_set("main.app.toolbar.calc", "width", 50);
$context->so_set("xyz", "{arr}[1][2]", 14);
$context->so_set("xyz", "{arr.totals}", 14);
=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;
}
lib/App/Context.pm view on Meta::CPAN
$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 {
( run in 1.219 second using v1.01-cache-2.11-cpan-e1769b4cff6 )