cvsuser 03/12/03 08:14:46
Modified: App-Context/lib App.pm
Log:
convert to use App::Options
Revision Changes Path
1.7 +94 -235 p5ee/App-Context/lib/App.pm
Index: App.pm
===================================================================
RCS file: /cvs/public/p5ee/App-Context/lib/App.pm,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -w -r1.6 -r1.7
--- App.pm 19 May 2003 17:41:11 -0000 1.6
+++ App.pm 3 Dec 2003 16:14:46 -0000 1.7
@@ -1,6 +1,6 @@
#############################################################################
-## $Id: App.pm,v 1.6 2003/05/19 17:41:11 spadkins Exp $
+## $Id: App.pm,v 1.7 2003/12/03 16:14:46 spadkins Exp $
#############################################################################
package App;
@@ -250,14 +250,14 @@
* Global Variable: $App::DEBUG integer
* Global Variable: $App::DEBUGFILE file for debug output
- * Global Variable: $App::dbgscope scope for debug output
+ * Global Variable: %App::dbgscope scope for debug output
=cut
if (!defined $App::DEBUG) {
$App::DEBUG = 0;
$App::DEBUGFILE = "";
- $App::dbgscope = ();
+ %App::dbgscope = ();
}
#################################################################
@@ -271,7 +271,7 @@
# -debug=6,App::Repository::DBI.select_rows (indiv. methods)
{
my ($debug, $pkg);
- $debug = $App::conf{debug};
+ $debug = $App::options{debug};
if (defined $debug && $debug ne "") {
if ($debug =~ s/^([0-9]+),?//) {
$App::DEBUG = $1;
@@ -283,7 +283,7 @@
}
}
- my $debugfile = $App::conf{debugfile};
+ my $debugfile = $App::options{debugfile};
if ($debugfile) {
if ($debugfile !~ /^[>|]/) {
$debugfile = ">> $debugfile";
@@ -292,7 +292,7 @@
}
$App::trace_subs = 0;
- if ($App::conf{trace}) {
+ if ($App::options{trace}) {
$App::trace_subs = 1;
}
}
@@ -434,7 +434,7 @@
=head2 new()
The App->new() method is not a constructor for
-a App class. However, it is a constructor, returning
+an App class. Rather, it is a Factory-style constructor, returning
an object of the class given as the first parameter.
If no parameters are given,
@@ -454,7 +454,7 @@
Sample Usage:
$context = App->new();
- $dbh = App->new("DBI", "new", "dbi:mysql:db", "dbuser", "dbpasswd2");
+ $dbh = App->new("DBI", "new", "dbi:mysql:db", "dbuser", "xyzzy");
$cgi = App->new("CGI", "new");
=cut
@@ -492,9 +492,14 @@
=head2 context()
- * Signature: $context = App->context()
+ * Signature: $context = App->context(); # most common, used in "app"
+ * Signature: $context = App->context(%named); # also used
+ * Signature: $context = App->context($named, %named); # variation
+ * Signature: $context = App->context($name, %named); # rare
+ * Signature: $context = App->context($named, $name, %named); # rare
* Param: context_class class [in]
- * Param: conf_file string [in]
+ * Param: config_file string [in]
+ * Param: prefix string [in]
* Return: $context App::Context
* Throws: App::Exception::Context
* Since: 0.01
@@ -504,7 +509,7 @@
$context = App->context();
$context = App->context(
context_class => "App::Context::HTTP",
- conf_file => "app.xml",
+ config_file => "app.xml",
);
This static (class) method returns the $context object
@@ -523,6 +528,19 @@
configured at deployment-time, and the proper physical class
is instantiated at run-time.
+The new() method of the configured Context class is called to
+instantiate the proper Context object. The $named args are
+combined with the %named args and passed as a single hash
+reference to the new() method.
+
+Environment variables:
+
+ PREFIX - set the $conf->{prefix} variable if not set to set app root dir
+ APP_CONTEXT_CLASS - set the Perl module to instantiate for the Context
+ GATEWAY_INTERFACE - assume mod_perl, use App::Context::ModPerl
+ HTTP_USER_AGENT - assume CGI, use App::Context::HTTP
+ (otherwise, use App::Context::Cmd, assuming it is from command line)
+
=cut
my (%context); # usually a singleton per process (under "default" name)
@@ -532,63 +550,66 @@
&App::sub_entry if ($App::trace_subs);
my $self = shift;
- my ($name, $args, $i);
- if ($#_ == -1) {
- $args = (%App::conf) ? \%App::conf : {};
- $name = "default";
+ my ($name, $conf, $i);
+ if ($#_ == -1) { # if no conf supplied (the normal case)
+ $conf = (%App::options) ? \%App::options : {}; # refer to conf hash
+ $name = "default"; # name of the singleton is default
}
- else {
- if (ref($_[0]) eq "HASH") {
- $args = shift;
- $name = shift if ($#_ % 2 == 0);
- for ($i = 0; $i < $#_; $i++) {
- $args->{$_[$i]} = $_[$i+1];
+ else { # named args were supplied ...
+ if (ref($_[0]) eq "HASH") { # ... as a hash reference
+ $conf = shift; # note that a copy is *not* made
+ $name = shift if ($#_ % 2 == 0); # get name if it exists (odd#)
+ for ($i = 0; $i < $#_; $i++) { # copy other named args
+ $conf->{$_[$i]} = $_[$i+1]; # into the conf hash
}
}
- else {
- $name = shift if ($#_ % 2 == 0);
- $args = ($#_ > -1) ? { @_ } : {};
+ else { # ... as a list of var/values
+ $name = shift if ($#_ % 2 == 0); # if odd #, first is the name
+ $conf = ($#_ > -1) ? { @_ } : {}; # the rest are named args
}
- $name = $args->{name} if (!$name);
- $name = "default" if (!$name);
+ $name = $conf->{name} if (!$name); # if name not given, look in conf
+ $name = "default" if (!$name); # use "default" as name
}
- return ($context{$name}) if (defined $context{$name});
+ return ($context{$name}) if (defined $context{$name}); # return context
- if (! $args->{context_class}) {
+ if (! $conf->{context_class}) {
if (defined $ENV{APP_CONTEXT_CLASS}) { # env variable set?
- $args->{context_class} = $ENV{APP_CONTEXT_CLASS};
+ $conf->{context_class} = $ENV{APP_CONTEXT_CLASS};
}
else { # try autodetection ...
my $gateway = $ENV{GATEWAY_INTERFACE};
if (defined $gateway && $gateway =~ /CGI-Perl/) { # mod_perl?
- $args->{context_class} = "App::Context::ModPerl";
+ $conf->{context_class} = "App::Context::ModPerl";
}
elsif ($ENV{HTTP_USER_AGENT}) { # running as CGI script?
- $args->{context_class} = "App::Context::HTTP";
+ $conf->{context_class} = "App::Context::HTTP";
}
- # let's be real... these next two are not critical right now
- #elsif ($ENV{DISPLAY}) { # running with an X DISPLAY var set?
- # $args->{context_class} = "App::Context::Gtk";
- #}
- #elsif ($ENV{TERM}) { # running with a TERM var for Curses?
- # $args->{context_class} = "App::Context::Curses";
- #}
- else { # fall back to CGI, because it works OK in command mode
- $args->{context_class} = "App::Context::Cmd";
+ else { # assume it is from the command line
+ $conf->{context_class} = "App::Context::Cmd";
}
}
}
- if (!$args->{prefix}) {
- if ($ENV{PREFIX}) {
- $args->{prefix} = $ENV{PREFIX};
+ if (!$conf->{prefix}) { # if this isn't already set
+ if ($ENV{PREFIX}) { # but it's set in the environment
+ $conf->{prefix} = $ENV{PREFIX}; # then set it
}
}
- $context{$name} = $self->new($args->{context_class}, "new", $args);
+ # instantiate Context and cache it (it's reference) for future use
+ $context{$name} = $self->new($conf->{context_class}, "new", $conf);
+
&App::sub_exit($context{$name}) if ($App::trace_subs);
return($context{$name});
}
+sub reset {
+ &App::sub_entry if ($App::trace_subs);
+ my ($self, $name) = @_;
+ $name = "default" if (!defined $name);
+ delete $context{$name};
+ &App::sub_exit() if ($App::trace_subs);
+}
+
#############################################################################
# conf()
#############################################################################
@@ -597,39 +618,27 @@
* Signature: $conf = App->conf(%named);
* Param: conf_class class [in]
- * Param: conf_file string [in]
+ * Param: config_file string [in]
* Return: $conf App::Conf
* Throws: App::Exception::Conf
* Since: 0.01
+This gets the Conf object from the Context.
+
+If args are passed in, they are only effective in affecting the Context
+if the Context has not been instantiated before.
+
+After the Context is instantiated by either the App->context() call or the
+App->conf() call, then subsequent calls to either method may or may not
+include arguments. It will not have any further effect because the
+Context object instantiated earlier will be used.
+
=cut
sub conf {
&App::sub_entry if ($App::trace_subs);
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 += 2) {
- $args->{$_[$i]} = $_[$i+1];
- }
- }
- else {
- $name = shift if ($#_ % 2 == 0);
- $args = ($#_ > -1) ? { @_ } : {};
- }
- $name = $args->{name} if (!$name);
- $name = "default" if (!$name);
- }
-
- my $retval = $self->context($args)->conf();
+ my $retval = $self->context(@_)->conf();
&App::sub_exit($retval) if ($App::trace_subs);
}
@@ -645,6 +654,8 @@
* Throws: App::Exception
* Since: 0.01
+Gets version info about the framework.
+
=cut
sub info {
@@ -658,6 +669,11 @@
#############################################################################
# Aspect-oriented programming support
#############################################################################
+# NOTE: This can be done much more elegantly at the Perl language level,
+# but it requires version-specific code. I created these subroutines so that
+# any method that is instrumented with them will enable aspect-oriented
+# programming in Perl versions from 5.5.3 to the present.
+#############################################################################
my $calldepth = 0;
@@ -674,6 +690,9 @@
* Throws: none
* Since: 0.01
+This is called at the beginning of a subroutine or method (even before $self
+may be shifted off).
+
=cut
sub sub_entry {
@@ -769,6 +788,7 @@
* Throws: none
* Since: 0.01
+This subroutine is called just before you return from a subroutine or method.
=cut
sub sub_exit {
@@ -811,167 +831,6 @@
}
return(@_);
}
-
-##############################################################################
-## 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 %debugscope;
-#
-#sub dbg {
-# my ($self, $level) = @_;
-# return 0 if (! $App::DEBUG);
-# $level = 1 if (!defined $level);
-# return 0 if (defined $level && $App::DEBUG < $level);
-# my ($debugscope, $stacklevel);
-# my ($calling_package, $file, $line, $subroutine, $hasargs, $wantarray);
-# $debugscope = (ref($self) eq "") ? \%debugscope : $self->{debugscope};
-# $stacklevel = 1;
-# ($calling_package, $file, $line, $subroutine, $hasargs, $wantarray) =
caller($stacklevel);
-# while (defined $subroutine && $subroutine eq "(eval)") {
-# $stacklevel++;
-# ($calling_package, $file, $line, $subroutine, $hasargs, $wantarray) =
caller($stacklevel);
-# }
-# return 1 if (! defined $debugscope);
-# return 1 if (! %$debugscope);
-# return 1 if (defined $debugscope->{$calling_package});
-# return 1 if (defined $debugscope->{$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::conf{debugfile}) {
-# print App::DEBUGFILE $$, ": ", @_, "\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;
-#}
-#
-##############################################################################
-## dbgscope()
-##############################################################################
-#
-#=head2 dbgscope()
-#
-#The dbgscope() 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: $dbgscope = $context->dbgscope();
-# * Param: void
-# * Return: $dbgscope {}
-# * Throws: App::Exception::Context
-# * Since: 0.01
-#
-# Sample Usage:
-#
-# $dbgscope = $context->dbgscope();
-# $dbgscope->{"App::Context::CGI"} = 1;
-# $dbgscope->{"App::Context::CGI.process_request"} = 1;
-#
-#=cut
-#
-#sub dbgscope {
-# my $self = shift;
-# my $dbgscope = $self->{dbgscope};
-# if (!defined $dbgscope) {
-# $dbgscope = {};
-# $self->{dbgscope} = $dbgscope;
-# }
-# $dbgscope;
-#}
=head1 ACKNOWLEDGEMENTS
