cvsuser 01/11/16 20:56:11
Modified: P5EEx/Blue MANIFEST
P5EEx/Blue/P5EEx/Blue Config.pm Context.pm P5EE.pm
Added: P5EEx/Blue/examples Config.1 config.pl
Log:
first version demonstrating Config classes
Revision Changes Path
1.2 +1 -4 p5ee/P5EEx/Blue/MANIFEST
Index: MANIFEST
===================================================================
RCS file: /cvs/public/p5ee/P5EEx/Blue/MANIFEST,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -w -r1.1 -r1.2
--- MANIFEST 2001/11/16 23:21:38 1.1
+++ MANIFEST 2001/11/17 04:56:10 1.2
@@ -4,11 +4,8 @@
README
TODO
P5EEx/Blue/styleguide.pod
-P5EEx/Blue/design.pod
-P5EEx/Blue.pm
+P5EEx/Blue/P5EE.pm
P5EEx/Blue/Config.pm
P5EEx/Blue/Context.pm
P5EEx/Blue/Context/CGI.pm
P5EEx/Blue/Config/XML.pm
-P5EEx/Blue/Utils/Date.pm
-P5EEx/Blue/Utils/HTML.pm
1.2 +51 -17 p5ee/P5EEx/Blue/P5EEx/Blue/Config.pm
Index: Config.pm
===================================================================
RCS file: /cvs/public/p5ee/P5EEx/Blue/P5EEx/Blue/Config.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -w -r1.1 -r1.2
--- Config.pm 2001/11/16 23:21:38 1.1
+++ Config.pm 2001/11/17 04:56:10 1.2
@@ -1,10 +1,10 @@
######################################################################
-## $Id: Config.pm,v 1.1 2001/11/16 23:21:38 spadkins Exp $
+## $Id: Config.pm,v 1.2 2001/11/17 04:56:10 spadkins Exp $
######################################################################
package P5EEx::Blue::Config;
-$VERSION = do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf "%d."."%02d"x$#r,@r};
+$VERSION = do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf "%d."."%02d"x$#r,@r};
use strict;
@@ -26,19 +26,40 @@
######################################################################
sub new {
- my ($this) = @_;
- my ($class, $self);
- $class = ref($this) || $this;
+ my $this = shift;
+ my $class = ref($this) || $this;
+ my ($name, $args, $i);
+ if ($#_ == -1) {
+ $args = {};
+ $name = "default";
+ }
+ else {
+ if (ref($_[0]) eq "HASH") {
+ $args = shift;
+ $name = shift if ($#_ % 2 == 0);
+ for ($i = 0; $i < $#_; $i++) {
+ $args->{$_[$i]} = $_[$i+1];
+ }
+ }
+ else {
+ $name = shift if ($#_ % 2 == 0);
+ $args = ($#_ > -1) ? { @_ } : {};
+ }
+ $name = $args->{name} if (!$name);
+ $name = "default" if (!$name);
+ }
+
# bootstrap phase: bless an empty hash
- $self = {};
+ my $self = {};
bless $self, $class;
- # load phase: replace empty hash with loaded hash
- $self = $self->load();
+ # load phase: replace empty hash with loaded hash, bless again
+ $self = $self->load($args);
bless $self, $class;
+
+ $self->init($args); # allows a subclass to override this portion
- $self->init(); # allows a subclass to override this portion
return $self;
}
@@ -48,23 +69,36 @@
}
sub load {
+ my ($self, $args) = @_;
local(*FILE);
my ($file, @perl, $perl, $conf, $open);
+ if (defined $args && $args->{configFile}) {
+ $file = $args->{configFile};
+ $open = open(main::FILE,"< $file");
+ }
+ else {
$file = $0;
$file =~ s!\.[^/]*$!!;
$file .= ".pl";
+ $open = open(main::FILE,"< $file");
+ $open = open(main::FILE,"< config.pl") if (!$open);
+ }
$conf = {};
- $open = open(main::FILE,"< $file");
- $open = open(main::FILE,"< widget.pl") if (!$open);
if ($open) {
@perl = <main::FILE>;
close(main::FILE);
$perl = join("",@perl);
+ if ($perl =~ /^(\$conf = \{.*\};[ \n]*)$/s) {
+ $perl = $1; # untainted now
eval($perl);
print STDERR "CONFIGURATION SYNTAX ERROR: $@\n" if ($@);
}
+ else {
+ print STDERR "CONFIGURATION SYNTAX ERROR: File didn't have \$conf in
it\n";
+ }
+ }
$conf;
}
@@ -76,7 +110,7 @@
sub dump {
my $self = shift;
- my $d = Data::Dumper->new([ $self ], [ "data" ]);
+ my $d = Data::Dumper->new([ $self ], [ "conf" ]);
$d->Indent(1);
return $d->Dump();
}
1.2 +77 -666 p5ee/P5EEx/Blue/P5EEx/Blue/Context.pm
Index: Context.pm
===================================================================
RCS file: /cvs/public/p5ee/P5EEx/Blue/P5EEx/Blue/Context.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -w -r1.1 -r1.2
--- Context.pm 2001/11/16 23:21:38 1.1
+++ Context.pm 2001/11/17 04:56:10 1.2
@@ -1,114 +1,110 @@
-######################################################################
-## $Id: Context.pm,v 1.1 2001/11/16 23:21:38 spadkins Exp $
-######################################################################
+#############################################################################
+## $Id: Context.pm,v 1.2 2001/11/17 04:56:10 spadkins Exp $
+#############################################################################
package P5EEx::Blue::Context;
use strict;
-use Widget;
-use CGI;
+use P5EEx::Blue::P5EE;
=head1 NAME
-P5EEx::Blue::Context - Controller for sets of widgets in a CGI environment
+P5EEx::Blue::Context - context in which we are currently running
=head1 SYNOPSIS
- my ($wc, $widget, @widgets);
+ my ($c);
- # ... official way to get a Controller object ...
- use Widget;
- $wc = Widget->controller(); # make factory which knows the
config info
- $wc->dispatch_events();
+ # ... official way to get a Context object ...
+ use P5EEx::Blue::P5EE;
+ my $ctx = P5EEx::Blue::P5EE->context();
+ $config = $ctx->config(); # get the configuration
- $wc = Widget->controller("P5EEx::Blue::Context"); # use other than the
autodetected controller
- print "wc is of type: ", ref($wc), "\n"; # should be the Controller
class instantiated
-
# ... alternative way (used internally) ...
use P5EEx::Blue::Context;
- $wc = P5EEx::Blue::Context->new();
- print "wc is of type: ", ref($wc), "\n"; # should be the Controller
class instantiated
+ my $ctx = P5EEx::Blue::Context->new();
- # the rest represents what might be done with the resulting widget controller
- $widget = $wc->widget("birth_dt"); # gets a widget
- print $widget->html(), "\n"; # this works for an HTML widget
-
- # or more generally... (maybe one day we will have Widget::Tk, Widget::Curses,
etc.?)
- push(@widgets, $widget); # add widget to a list of widgets
- $wc->display(@widgets); # controller renders list of
widgets on display
+ # any of the following named parameters may be specified
+ my $ctx = P5EEx::Blue::P5EE->context(
+ contextClass => "P5EEx::Blue::Context::CGI",
+ configClass => "P5EEx::Blue::Config::XML", # or any Config args
+ );
=cut
-######################################################################
+#############################################################################
# CONSTANTS
-######################################################################
-
-######################################################################
-# ATTRIBUTES
-######################################################################
-
-# $self->{widget} # {} cache of widgets (by widgetName)
-# $self->{widgetconfig} # {} cache of widget configuration information (by
widgetName)
-# $self->{messages} # "" HTML text (?) derived from the event handling
-#
-# MAJOR SECTIONS OF THE config STRUCTURE
-# $self->{config} # {} global, read-only, config information
-# $self->{config}{repository} # {} accessible repositories for data retrieval
-# $self->{config}{domain} # {} domains of value/label pairs
-# $self->{config}{widgetType} # {} widget configs ready for use in a widget
-# $self->{config}{widget} # {} widget config info
-#
-# MAJOR SECTIONS OF THE state STRUCTURE
-# $self->{state} # {} dynamic state
-# $self->{state}{org} # {} dynamic state (for the user's current org)
-# $self->{state}{user} # {} dynamic state (for the current user)
-# $self->{state}{widget} # {} dynamic state (for the current state for each
widget)
+#############################################################################
-# INPUTS FROM THE ENVIRONMENT
-
=head1 DESCRIPTION
+
+A Context class models the environment in which the current process is
+running. Examples might be
-This is a controller class for widgets running in a CGI environment.
+ P5EEx::Blue::Context::CGI
+ P5EEx::Blue::Context::ModPerl
+ P5EEx::Blue::Context::ModPerlRegistry
+ P5EEx::Blue::Context::PPerl
+ P5EEx::Blue::Context::Cmd
+ P5EEx::Blue::Context::Daemon
+ P5EEx::Blue::Context::Gtk
+ P5EEx::Blue::Context::WxPerl
+
+The role of the Context class is to abstract the details of the
+various runtime environments (or Platforms) so that the basic programming
+model for the developer is uniform.
+
+The main function of the Context class is to load the Config data
+and manage Session data.
+
+The Context object is always a singleton per process (except in rare cases
+like debugging). Conceptually, the Context may be associated with many
+Config's and Sessions in a single process (ModPerl), whereas it frequently
+is associated with only one Config or Session throughout the lifetime of
+the process (CGI, Cmd).
=cut
-######################################################################
+#############################################################################
# CONSTRUCTOR
-######################################################################
+#############################################################################
sub new {
- my ($this, $args) = @_;
+ my $this = shift;
my $class = ref($this) || $this;
my $self = {};
bless $self, $class;
- Widget->dbgprint("$class->new(" . join(", ",%$args) . ")")
- if ($Widget::DEBUG && Widget->dbg(ref($self),"new"));
- $self->{widget} = {}; # initialize empty cache of widgets
- $self->{widgetconfig} = {}; # initialize empty cache of their effective config
-
- my ($config_class, $state_class);
-
- $config_class = $args->{config};
- $config_class = "Widget::Config" if (!defined $config_class || $config_class
eq "");
-
- $state_class = $args->{state};
- $state_class = "Widget::State" if (!defined $state_class || $state_class eq
"");
+ my ($name, $args, $i);
+ if ($#_ == -1) {
+ $args = {};
+ $name = "default";
+ }
+ else {
+ if (ref($_[0]) eq "HASH") {
+ $args = shift;
+ $name = shift if ($#_ % 2 == 0);
+ for ($i = 0; $i < $#_; $i++) {
+ $args->{$_[$i]} = $_[$i+1];
+ }
+ }
+ else {
+ $name = shift if ($#_ % 2 == 0);
+ $args = ($#_ > -1) ? { @_ } : {};
+ }
+ $name = $args->{name} if (!$name);
+ $name = "default" if (!$name);
+ }
- $self->{config} = Widget->create($config_class, $args);
- $self->{state} = Widget->create($state_class, $args);
+ my ($config_class);
- # create the pseudo-widget "global" only as a widgetconfig
- $self->{widgetconfig}{global}{lang} = "en_us";
+ $config_class = $args->{configClass};
+ $config_class = $ENV{P5EE_CONFIG_CLASS} if (! $config_class);
+ $config_class = "P5EEx::Blue::Config" if (! $config_class);
- # create the pseudo-widget "session"
- $self->widget(
- -name => "session",
- -widgetClass => "Widget::Base",
- -container => "global",
- );
+ $self->{config} = P5EEx::Blue::P5EE->create($config_class, $args);
$self->init($args);
@@ -120,608 +116,23 @@
my ($self, $args) = @_;
}
-######################################################################
+#############################################################################
# METHODS
-######################################################################
-
-sub add_message {
- my ($self, $msg) = @_;
- if (defined $self->{messages}) {
- $self->{messages} .= "<br>" . $msg;
- }
- else {
- $self->{messages} = $msg;
- }
-}
-
-# NOTE: This is a key method to override in the driver classes
-sub dispatch_events {
- my ($self, $eventarray) = @_;
- # TODO: implement a default handler here
- # $self->widget($name)->handle_event($ename, $event, @args);
-}
+#############################################################################
-# NOTE: This is a key method to override in the driver classes
-sub display {
+sub log {
my $self = shift;
- my ($widget);
- foreach $widget (@_) {
- $widget->display();
- }
+ print STDERR @_, "\n";
}
sub user {
my $self = shift;
- "guest"; # improve this over time
-}
-
-sub state {
- $_[0]->{state};
-}
-
-sub repository {
- my ($self, $repname) = @_;
- my ($config, $repdef, $instance, $key, $global, $var);
- my ($class, $method, $args, @args, $argidx);
-
- $repname = "db" if (!defined $repname || $repname eq "");
- Widget->dbgprint("P5EEx::Blue::Context->repository($repname)")
- if ($Widget::DEBUG && Widget->dbg(ref($self),"repository"));
-
- $config = $self->{config};
- $repdef = $config->{repository}{$repname};
- return undef if (!defined $repdef);
-
- $instance = $self->{repository}{$repname};
- if (! defined $instance) {
- if ($repdef->{import}) {
- $global = $self->{widgetconfig}{global};
- foreach $key (keys %$repdef) {
- $repdef->{$key} = $global->{$key} if (defined $global->{$key});
- }
- }
- $class = $repdef->{class};
- if (defined $class) {
- $method = $repdef->{newmethod};
- $method = "new" if (!defined $method);
- $args = $repdef->{newmethod_args};
- $args = [] if (!defined $args || ref($args) ne "ARRAY");
- @args = @$args;
- for ($argidx = 0; $argidx <= $#$args; $argidx++) {
- if ($args->[$argidx] =~ /^\{(.+)\}$/) {
- $var = $1;
- if ($var eq "config") {
- $args[$argidx] = $config;
- }
- elsif ($var eq "repconfig") {
- $args[$argidx] = $repdef;
- }
- elsif (defined $repdef->{$var}) {
- $args[$argidx] = $repdef->{$var};
+ "guest";
}
- }
- }
-
- Widget->dbgprint("P5EEx::Blue::Context->repository($repname):
$class->$method(@$args)")
- if ($Widget::DEBUG && Widget->dbg(ref($self),"repository"));
- Widget->use($class);
- $instance = $class->$method(@args);
- $self->{repository}{$repname} = $instance;
- }
- }
- $instance;
-}
-
-sub shutdown {
+sub config {
my $self = shift;
- my ($config, $repdef, $repname, $instance);
- my ($class, $method, $args, $argidx);
-
- Widget->dbgprint("P5EEx::Blue::Context->shutdown()")
- if ($Widget::DEBUG && Widget->dbg(ref($self),"shutdown"));
-
- $config = $self->{config};
- if (defined $self->{repository} && ref($self->{repository}) eq "HASH") {
- foreach $repname (keys %{$self->{repository}}) {
- $instance = $self->{repository}{$repname};
- $repdef = $config->{repository}{$repname};
- $method = $repdef->{finishmethod};
- $method = "disconnect" if (!defined $method);
-
- Widget->dbgprint("P5EEx::Blue::Context->shutdown():
$instance->$method()")
- if ($Widget::DEBUG && Widget->dbg(ref($self),"shutdown"));
-
- $instance->$method();
- delete $self->{repository}{$repname};
- }
- }
-}
-
-sub domain {
- my ($self, $domain) = @_;
- my ($config, $domainref, $repository, $rep);
- my ($values, $labels, $needs_loading, $time_to_live, $time);
- my ($class, $method, $args, $rows, $row);
-
- Widget->dbgprint("P5EEx::Blue::Context->domain($domain)")
- if ($Widget::DEBUG && Widget->dbg(ref($self),"domain"));
-
- $config = $self->{config};
- $domainref = $config->{domain}{$domain};
- if (defined $domainref) {
- $values = $domainref->{values};
- $labels = $domainref->{labels};
-
- $needs_loading = 0;
- $repository = $domainref->{repository};
- if (defined $repository && $repository ne "") {
- if (!defined $values || !defined $labels) {
- $needs_loading = 1;
- }
- else {
- $time_to_live = $domainref->{time_to_live};
- if (defined $time_to_live && $time_to_live ne "" && $time_to_live
>= 0) {
- if ($time_to_live == 0) {
- $needs_loading = 1;
- }
- else {
- if (time() >= $domainref->{time} + $time_to_live) {
- $needs_loading = 1;
- }
- }
- }
- }
- }
-
- Widget->dbgprint("P5EEx::Blue::Context->domain($domain):
needs_loading=$needs_loading")
- if ($Widget::DEBUG && Widget->dbg(ref($self),"domain"));
-
- if ($needs_loading) {
- $rep = $self->repository($repository);
- if (defined $rep) {
- $method = $domainref->{getmethod};
- $method = "get" if (!defined $method);
- $args = $domainref->{getmethod_args};
- $args = [ $domain ] if (!defined $args);
-
- Widget->dbgprint("P5EEx::Blue::Context->domain($domain):
$rep->$method(@$args)")
- if ($Widget::DEBUG && Widget->dbg(ref($self),"domain"));
-
- $rows = ${rep}->${method}(@$args);
- $values = [];
- $labels = {};
- foreach $row (@$rows) {
- push(@$values, $row->[0]);
- $labels->{$row->[0]} = $row->[1];
- }
- $domainref->{values} = $values;
- $domainref->{labels} = $labels;
- $time = time();
- $domainref->{time} = $time;
- }
- }
-
- $values = $domainref->{values};
- $labels = $domainref->{labels};
- }
- $values = [] if (! defined $values);
- $labels = {} if (! defined $labels);
- return ($values, $labels);
-}
-
-# The widget config is a simple hash which is the result of several
-# complementary sources:
-# 1. config of the widget (in Config) (which override widgetType)
-# 2. optional config of the widget's widgetType (in Config)
-# 3. config of container widget
-# 4. args to the widget_config() call, usually coming from the widget constructor
-# some of these are defaults, other are overrides
-# NOTES;
-# * we don't want to copy *all* attributes of container config, so
-# we need a list of "absorbable" attributes
-# * all widget configuration happens before instantiation
-# this allows you to override the widgetClass in time for instantiation
-# * widget_config's are cached in the Controller because the controller
-# needs to know the configuration before it can instantiate the widget.
-# * A reference to this config is kept by the widget for its own convenience.
-
-# Usage: $config = $wc->widget_config("last_name");
-sub widget_config {
- my ($self, $name, $args) = @_;
- my ($confroot, $config, $readonly_config, $state, $widgetType, $attrib,
$override);
- my ($new_config);
-
- Widget->dbgprint("P5EEx::Blue::Context->widget_config($name, " . join(",
",(defined $args)?%$args:"") . ")")
- if ($Widget::DEBUG && Widget->dbg(ref($self),"widget_config",3));
-
- if (defined $self->{widgetconfig}{$name}) {
- $config = $self->{widgetconfig}{$name};
- $new_config = 0;
-
- $state = $self->{state}{widget}{$name};
- $state = {} if (!defined $state);
- }
- else {
- ################################################################
- # set up the {config} and {state} hashrefs
- ################################################################
- $config = {};
- $self->{widgetconfig}{$name} = $config;
- $new_config = 1;
-
- $state = $self->{state}{widget}{$name};
- $state = {} if (!defined $state);
-
- ################################################################
- # start with runtime state for the widget from the state data
- ################################################################
- %$config = %$state;
- $config->{name} = $name;
-
- ################################################################
- # overlay with attributes from the (read-only) config file
- ################################################################
- $confroot = $self->{config};
- $readonly_config = $confroot->{widget}{$name};
- foreach $attrib (keys %$readonly_config) {
- # include config attributes only if not provided in the state
- if (!defined $config->{$attrib}) {
- $config->{$attrib} = $readonly_config->{$attrib};
- }
- }
-
- ################################################################
- # overlay with attributes from the "widgetType"
- ################################################################
- $widgetType = $config->{widgetType};
- if ($widgetType) {
- $readonly_config = $confroot->{widgetType}{$widgetType};
- foreach $attrib (keys %$readonly_config) {
- # include widgetType configs only if not provided in the widget
configs
- if (!defined $config->{$attrib}) {
- $config->{$attrib} = $readonly_config->{$attrib};
- }
- }
- }
- }
-
- my ($lightweight);
- $lightweight = ($name =~ /[\[\]\{\}]/);
-
- ####################################################################
- # include defaults/overrides from args to $wc->widget($name, $args);
- ####################################################################
- if (defined $args && ref($args) eq "HASH") { # ... args were provided
- $override = $args->{override}; # don't override by default
-
- ################################################################
- # take care of attributes associated with widgetType first
- ################################################################
- if ($args->{widgetType} &&
- ($override || !defined $config->{widgetType})) {
- $widgetType = $args->{widgetType};
- if (!$config->{widgetType} || $widgetType ne $config->{widgetType}) {
- $readonly_config = $confroot->{widgetType}{$widgetType};
- foreach $attrib (keys %$readonly_config) {
- if (!defined $config->{$attrib} || $override) {
- $config->{$attrib} = $readonly_config->{$attrib};
- }
- }
- }
- }
-
- ################################################################
- # take care of all %$args attributes next
- ################################################################
- 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 widget
configs already
- if (!defined $config->{$attrib} ||
- ($override && $config->{$attrib} ne $args->{$attrib})) {
- $config->{$attrib} = $args->{$attrib};
- # don't store state for lightweight widgets
- $state->{$attrib} = $args->{$attrib} if (! $lightweight);
- }
- Widget->dbgprint("Controller->widget_config() [arg=$attrib] name=$name
lw=$lightweight ovr=$override",
- " config=", $config->{$attrib},
- " state=", $state->{$attrib},
- " args=", $args->{$attrib})
- if ($Widget::DEBUG && Widget->dbg(ref($self),"widget_config",6));
- }
- }
-
- ####################################################################
- # infer a container (if none supplied, by the dots in the "name")
- ####################################################################
- if (! defined $config->{container}) {
- if ($name =~ /^(.+)\./) {
- $config->{container} = $1;
- }
- elsif ($name eq "session") {
- $config->{container} = "global";
- }
- elsif ($name ne "global") {
- $config->{container} = "session";
- }
- if (defined $config->{widgetClass}) {
- Widget->use($config->{widgetClass}); # load the perl code
- $config->{absorbable_attribs} =
$config->{widgetClass}->absorbable_attribs();
- }
- }
-
- # absorb attributes of the container config if ...
- # TODO: sort out whether we need to absorb attributes more often
- # (i.e. push model rather than a pull model)
- if ($new_config && # ... it is the first time through
- $config->{container} && # ... a container exists
- $config->{absorbable_attribs}) { # ... there are known attributes to
absorb
-
- my ($container, $container_config, $absorbable_attribs);
- $container = $config->{container};
- $container_config = $self->widget_config($container); # notice a recursion
here on containers
- $absorbable_attribs = $config->{absorbable_attribs};
- if (ref($absorbable_attribs) eq "") {
- $absorbable_attribs = [ split(/ *, */,$absorbable_attribs) ];
- }
- if (ref($absorbable_attribs) eq "ARRAY") {
- foreach $attrib (@$absorbable_attribs) {
- if (!defined $config->{$attrib}) { # incorporate only if from no
other source
- $config->{$attrib} = $container_config->{$attrib};
- }
- }
- }
- }
-
- if (!defined $self->{state}{widget}{$name} && !$lightweight && (%$state)) {
- $self->{state}{widget}{$name} = $state;
- }
-
- Widget->dbgprint("P5EEx::Blue::Context->widget_config($name) = [" . join(",
",(defined $config)?%$config:"") . "]")
- if ($Widget::DEBUG && Widget->dbg(ref($self),"widget_config",3));
-
- return $config;
-}
-
-# Usage: $widget = $wc->widget("first_name");
-sub widget {
- my $self = shift;
-
- Widget->dbgprint("P5EEx::Blue::Context->widget(" . join(", ",@_) . ")")
- if ($Widget::DEBUG && Widget->dbg(ref($self),"widget",3));
-
- my ($args);
- my ($name, $widget, $config, $class, $oldclass);
-
- if ($#_ == -1) {
- return undef; # we need at least a name
- }
- elsif (ref($_[0]) eq "HASH") {
- $args = shift;
- $name = $args->{name};
- }
- elsif ($_[0] =~ /^-/) {
- $args = {};
- my ($i, $var);
- for ($i = 0; $i < $#_; $i += 2) {
- $var = $_[$i];
- $var =~ s/^-//;
- $args->{$var} = $_[$i+1];
- }
- $name = $args->{name};
- }
- else {
- $name = $_[0];
- $args = $_[1];
- # no other positional args for this class
- }
-
- Widget->dbgprint("P5EEx::Blue::Context->widget: name=[$name]")
- if ($Widget::DEBUG && Widget->dbg(ref($self),"widget",3));
-
- return undef if (! defined $name); # we need a name!
- $config = $self->widget_config($name, $args);
-
- Widget->dbgprint("P5EEx::Blue::Context->widget: returned from widget_config()")
- if ($Widget::DEBUG && Widget->dbg(ref($self),"widget",3));
-
- $class = $config->{"widgetClass"};
- if (!defined $class || $class eq "") {
- if ($name ne "global") {
- $class = "Widget::HTML::TextField";
- $config->{"widgetClass"} = $class;
- $config->{backgroundColor} = "#ffcccc";
- }
- }
-
- # NOTE: This does not allow widgets to change their class during execution
- # i.e. once the widget is instantiated as a particular class, it is stored
- # in the cache and never instantiated again. I think this is what we want.
- # I could conceivably allow a widget to change its class. Then it would
- # need to get reinstantiated as the new class, but I don't think this is
- # what we want.
-
- $widget = $self->{widget}{$name}; # check the cache
- if (!defined $widget) {
-
- Widget->dbgprint("P5EEx::Blue::Context->widget(): creating new widget (not
in cache)")
- if ($Widget::DEBUG && Widget->dbg(ref($self),"widget",3));
-
- if (defined $class && $class ne "") {
- Widget->use($class);
- $widget = $class->new($name,$self,1);
- }
- else {
- $widget = {};
- $widget->{name} = $name;
- $widget->{controller} = $self;
- }
-
- $self->{widget}{$name} = $widget;
- }
-
- Widget->dbgprint("P5EEx::Blue::Context->widget() = $widget")
- if ($Widget::DEBUG && Widget->dbg(ref($self),"widget",3));
-
- return $widget;
-}
-
-sub get_table_cell {
- my ($self, $table, $rowkey, $colname) = @_;
- my ($tablehash, $rowidx, $colidx);
- $tablehash = $self->{config}{table}{$table};
- return undef if (!defined $tablehash);
- $rowidx = $tablehash->{rowindex}{$rowkey};
- $colidx = $tablehash->{colindex}{$colname};
- return "" if (!defined $rowidx || !defined $colidx);
- return $tablehash->{data}[$rowidx][$colidx];
-}
-
-# $self->set("{arr}[1][2]", 14);
-# $self->set("{arr.totals}[1][2]", 14);
-#sub set {
-# my ($self, $var, $value) = @_;
-# my ($perl);
-#
-# if ($var !~ /[\[\]\{\}]/) { # no special chars, "foo.bar"
-# $self->{$var} = $value;
-# return;
-# } # match {
-# elsif ($var =~ /^\{([^\}]+)\}$/) { # a simple "{foo.bar}"
-# $var = $1;
-# $self->{$var} = $value;
-# return;
-# } # match {
-#
-# $var =~ s/\{([^\}]+)\}/\{"$1"\}/g;
-# $perl = "\$self->$var = \$value;";
-# eval $perl;
-# print STDERR "ERROR: P5EEx::Blue::Context->set($var,$value): eval ($perl):
$@\n" if ($@);
-# return $value;
-#}
-
-sub wget_value {
- my ($self, $name, $default, $setdefault) = @_;
- my ($wname, $var, $value);
- if ($name =~ /^(.+)\.([^\.]+)$/) {
- $wname = $1;
- $var = $2;
- $value = $self->{widgetconfig}{$wname}{$var};
- if (!defined $value && defined $default) {
- $value = $default;
- if ($setdefault) {
- $self->{state}{widget}{$wname}{$var} = $value;
- $self->widget_config($wname) if (!defined
$self->{widgetconfig}{$wname});
- $self->{widgetconfig}{$wname}{$var} = $value;
- }
- }
- }
- else {
- $value = $self->{widgetconfig}{session}{$name};
- if (!defined $value && defined $default) {
- $value = $default;
- if ($setdefault) {
- $self->{state}{widget}{session}{$name} = $value;
- $self->{widgetconfig}{session}{$name} = $value;
- }
- }
- }
- return $value;
-}
-
-sub wset_value {
- my ($self, $name, $value) = @_;
- my ($wname, $var);
-
- if ($name =~ /^(.+)\.([^\.]+)$/) {
- $wname = $1;
- $var = $2;
- $self->{state}{widget}{$wname}{$var} = $value;
- $self->widget_config($wname) if (!defined $self->{widgetconfig}{$wname});
- $self->{widgetconfig}{$wname}{$var} = $value;
- }
- else {
- $self->{state}{widget}{session}{$name} = $value;
- $self->{widgetconfig}{session}{$name} = $value;
- }
-}
-
-# $self->set("{arr}[1][2]", 14);
-# $self->set("{arr.totals}[1][2]", 14);
-sub wset {
- my ($self, $name, $var, $value) = @_;
- my ($perl, $multiple);
-
- Widget->dbgprint("P5EEx::Blue::Context->wget($name,$var,$value)")
- if ($Widget::DEBUG && Widget->dbg(ref($self),"wset",3));
-
- if ($var !~ /[\[\]\{\}]/) { # no special chars, "foo.bar"
- $self->{state}{widget}{$name}{$var} = $value;
- $self->widget_config($name) if (!defined $self->{widgetconfig}{$name});
- $self->{widgetconfig}{$name}{$var} = $value;
- return;
- } # match {
- elsif ($var =~ /^\{([^\}]+)\}$/) { # a simple "{foo.bar}"
- $var = $1;
- $self->{state}{widget}{$name}{$var} = $value;
- $self->widget_config($name) if (!defined $self->{widgetconfig}{$name});
- $self->{widgetconfig}{$name}{$var} = $value;
- return;
- } # match {
-
- $self->widget_config($name) if (!defined $self->{widgetconfig}{$name});
- $var =~ s/\{([^\}]+)\}/\{"$1"\}/g; # put quotes around hash keys
- $perl = "\$self->{state}{widget}{\$name}$var = \$value;
\$self->{widgetconfig}{\$name}$var = \$value;";
- eval $perl;
- print STDERR "ERROR: P5EEx::Blue::Context->wset($name,$var,$value): eval
($perl): $@\n" if ($@);
- return $value;
-}
-
-sub wget {
- my ($self, $name, $var, $default, $setdefault) = @_;
- my ($perl, $value);
-
- if ($var !~ /[\[\]\{\}]/) { # no special chars, "foo.bar"
- $value = $self->{widgetconfig}{$name}{$var};
- if (!defined $value && defined $default) {
- $value = $default;
- if ($setdefault) {
- $self->{state}{widget}{$name}{$var} = $value;
- $self->widget_config($name) if (!defined
$self->{widgetconfig}{$name});
- $self->{widgetconfig}{$name}{$var} = $value;
- }
- }
- Widget->dbgprint("P5EEx::Blue::Context->wget($name,$var) (value) =
[$value]")
- if ($Widget::DEBUG && Widget->dbg(ref($self),"wget",3));
- return $value;
- } # match {
- elsif ($var =~ /^\{([^\}]+)\}$/) { # a simple "{foo.bar}"
- $var = $1;
- $value = $self->{widgetconfig}{$name}{$var};
- if (!defined $value && defined $default) {
- $value = $default;
- if ($setdefault) {
- $self->{state}{widget}{$name}{$var} = $value;
- $self->widget_config($name) if (!defined
$self->{widgetconfig}{$name});
- $self->{widgetconfig}{$name}{$var} = $value;
- }
- }
- Widget->dbgprint("P5EEx::Blue::Context->wget($name,$var) (attrib) =
[$value]")
- if ($Widget::DEBUG && Widget->dbg(ref($self),"wget",3));
- return $value;
- } # match {
-
- $self->widget_config($name) if (!defined $self->{widgetconfig}{$name});
- $var =~ s/\{([^\}]+)\}/\{"$1"\}/g;
- $perl = "\$value = \$self->{widgetconfig}{\$name}$var;";
- eval $perl;
- print STDERR "ERROR: Widget::Base->get($var): eval ($perl): $@\n" if ($@);
-
- Widget->dbgprint("P5EEx::Blue::Context->wget($name,$var) (indexed) = [$value]")
- if ($Widget::DEBUG && Widget->dbg(ref($self),"wget",3));
- return $value;
+ $self->{config};
}
1;
1.2 +63 -49 p5ee/P5EEx/Blue/P5EEx/Blue/P5EE.pm
Index: P5EE.pm
===================================================================
RCS file: /cvs/public/p5ee/P5EEx/Blue/P5EEx/Blue/P5EE.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -w -r1.1 -r1.2
--- P5EE.pm 2001/11/16 23:21:38 1.1
+++ P5EE.pm 2001/11/17 04:56:10 1.2
@@ -1,6 +1,6 @@
#############################################################################
-## $Id: P5EE.pm,v 1.1 2001/11/16 23:21:38 spadkins Exp $
+## $Id: P5EE.pm,v 1.2 2001/11/17 04:56:10 spadkins Exp $
#############################################################################
package P5EEx::Blue::P5EE;
@@ -83,44 +83,44 @@
$self->context(@_);
}
-my ($default_context); # singleton
+my (%context); # singleton classes per name
sub context {
my $self = shift;
- my ($args, $context);
+ my ($name, $args, $i);
if ($#_ == -1) {
$args = {};
+ $name = "default";
}
- elsif (ref($_[0]) eq "HASH") {
+ else {
+ if (ref($_[0]) eq "HASH") {
$args = shift;
- }
- elsif ($_[0] =~ /^-/) {
- $args = {};
- my ($i, $var);
- for ($i = 0; $i < $#_; $i += 2) {
- $var = $_[$i];
- $var =~ s/^-//;
- $args->{$var} = $_[$i+1];
+ $name = shift if ($#_ % 2 == 0);
+ for ($i = 0; $i < $#_; $i++) {
+ $args->{$_[$i]} = $_[$i+1];
}
}
else {
- $args = {};
- # no positional args for this method
+ $name = shift if ($#_ % 2 == 0);
+ $args = ($#_ > -1) ? { @_ } : {};
}
+ $name = $args->{name} if (!$name);
+ $name = "default" if (!$name);
+ }
+ return ($context{$name}) if (defined $context{$name});
- if (! $args->{context}) {
+ if (! $args->{contextClass}) {
if (defined $ENV{"P5EE_CONTEXT_CLASS"}) { # env variable set?
- $args->{context} = $ENV{"P5EE_CONTEXT_CLASS"};
+ $args->{contextClass} = $ENV{"P5EE_CONTEXT_CLASS"};
}
else { # try autodetection ...
my $gateway = $ENV{"GATEWAY_INTERFACE"};
if (defined $gateway && $gateway =~ /CGI-Perl/) { # running under
mod_perl?
- $args->{context} = "P5EEx::Blue::Context::Modperl";
+ $args->{contextClass} = "P5EEx::Blue::Context::Modperl";
}
elsif ($ENV{"HTTP_USER_AGENT"}) { # running as CGI script?
- $args->{context} = "P5EEx::Blue::Context::CGI";
- $args->{state} = "P5EEx::Blue::State::CGI";
+ $args->{contextClass} = "P5EEx::Blue::Context::CGI";
}
# let's be real... these next two are not really critical right now
#elsif ($ENV{"DISPLAY"}) { # running with an X DISPLAY var set?
@@ -130,51 +130,65 @@
# $args->{context} = "P5EEx::Blue::Context::Curses";
#}
else { # fall back to CGI, because it works
OK in command mode
- $args->{context} = "P5EEx::Blue::Context::CGI";
- $args->{state} = "P5EEx::Blue::State::CGI";
+ $args->{contextClass} = "P5EEx::Blue::Context::CGI";
}
}
}
- if (!defined $args->{config} || $args->{config} eq "") {
- if (defined $ENV{"P5EE_CONFIG_CLASS"}) {
- $args->{config} = $ENV{"P5EE_CONFIG_CLASS"};
- }
+ $context{$name} = $self->create($args->{contextClass}, $args);
+ return $context{$name};
}
- $context = $self->create($args->{context}, $args);
- $default_context = $context if (!defined $default_context);
- return $context;
+sub config {
+ my $self = shift;
+
+ my ($name, $args, $i);
+ if ($#_ == -1) {
+ $args = {};
+ $name = "default";
+ }
+ else {
+ if (ref($_[0]) eq "HASH") {
+ $args = shift;
+ $name = shift if ($#_ % 2 == 0);
+ for ($i = 0; $i < $#_; $i++) {
+ $args->{$_[$i]} = $_[$i+1];
}
+ }
+ else {
+ $name = shift if ($#_ % 2 == 0);
+ $args = ($#_ > -1) ? { @_ } : {};
+ }
+ $name = $args->{name} if (!$name);
+ $name = "default" if (!$name);
+ }
-sub default_context {
- my $self = shift;
- return ($default_context) if (defined $default_context);
- return P5EEx::Blue->context(@_);
+ $self->context($args)->config();
}
+my (%used);
+
sub create {
my $self = shift;
my $class = shift;
+ if ($class =~ /^([A-Za-z0-9:_]+)$/) {
+ $class = $1;
+ if (! $used{$class}) {
eval("use $class;");
- return undef if ($@);
+ if ($@) {
+ print STDERR "Error creating object: $@\n";
+ return undef;
+ }
+ $used{$class} = 1;
+ }
return $class->new(@_);
}
+ return undef;
+}
#############################################################################
# METHODS
#############################################################################
-
-sub current_directory {
- eval("use Cwd;");
- cwd();
-}
-
-sub command {
- my $cmd = $0;
- $cmd =~ s!^\.\/!!;
- return $cmd;
-}
#############################################################################
# DEBUG SUPPORT
1.1 p5ee/P5EEx/Blue/examples/Config.1
Index: Config.1
===================================================================
#!/usr/local/bin/perl -wT
use lib "..";
use P5EEx::Blue::P5EE;
$config = P5EEx::Blue::P5EE->config();
print "FROM PERL: ", $config->dump(), "\n";
$config = P5EEx::Blue::P5EE->config(
configClass => "P5EEx::Blue::Config::XML",
);
print "FROM XML: ", $config->dump(), "\n";
$config = P5EEx::Blue::P5EE->config(
configClass => "P5EEx::Blue::Config::Inifiles",
);
print "FROM INI: ", $config->dump(), "\n";
1.1 p5ee/P5EEx/Blue/examples/config.pl
Index: config.pl
===================================================================
$conf = {
Session => {
default => {
sessionClass => "P5EE::Blue::Session::CGI",
},
},
Standard => {
'Log-Dispatch' => {
logdir => '/var/p5ee',
}
},
Authen => {
passwd => '/etc/passwd',
seed => 303292,
},
};
