gecko-dev/webtools/PLIF/PLIF.pm
ian%hixie.ch 86e3bcd2ae * Improved the helpfulness of the extremely verbose debugging information of PLIF.pm by quoting embedded variables
* Implemented MagicCollectingArray, which acts like MagicPipingArray except that the result is collected into one big array instead of multiple arrayrefs
* Added the relevant getCollecting*List methods to the Controller class
* Added DESTROY methods to the magic array to prevent DESTROY method calls from being propagated
* Made the debug.dumpVars string more robust when the data hash includes one of the three magic characters '(', '.' or ')'
* Implemented sanitation in COSES so that any keys in the data hash containing one of the three magic characters '(', '.' or ')' will have them transliterated to '[', ':' and ']' respectively (sanitation is optional and can be bypassed)
* Changed the API of the generic output module's 'output' method to take the optional $session argument last, thus simplifying the call sites a lot
* Implemented the 'dispatcher.output' service in several classes to return strings that must be support in variants (required for a good UI in the COSES editor)
* Renamed the Login module's strings so that they use the dot-notation separating significant parts
2001-06-04 06:13:22 +00:00

288 lines
8.8 KiB
Perl

# -*- Mode: perl; tab-width: 4; indent-tabs-mode: nil; -*-
#
# This file is MPL/GPL dual-licensed under the following terms:
#
# The contents of this file are subject to the Mozilla Public License
# Version 1.1 (the "License"); you may not use this file except in
# compliance with the License. You may obtain a copy of the License at
# http://www.mozilla.org/MPL/
#
# Software distributed under the License is distributed on an "AS IS"
# basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
# the License for the specific language governing rights and
# limitations under the License.
#
# The Original Code is PLIF 1.0.
# The Initial Developer of the Original Code is Ian Hickson.
#
# Alternatively, the contents of this file may be used under the terms
# of the GNU General Public License Version 2 or later (the "GPL"), in
# which case the provisions of the GPL are applicable instead of those
# above. If you wish to allow use of your version of this file only
# under the terms of the GPL and not to allow others to use your
# version of this file under the MPL, indicate your decision by
# deleting the provisions above and replace them with the notice and
# other provisions required by the GPL. If you do not delete the
# provisions above, a recipient may use your version of this file
# under either the MPL or the GPL.
package PLIF;
use strict; # require strict adherence to perl standards
use vars qw($AUTOLOAD); # it's a package global
use Carp qw(cluck confess); # stack trace versions of warn and die
my $DEBUG = 9; # level of warnings and dumps to print to STDERR (none go to user)
my $USER = 3; # level of errors to report to user (all go to STDERR)
my @FATAL = (); # a list of pointers to functions that want to report errors to the user
my $LOCKED = 0; # set to '1' while we are calling the error reporting code
1;
# PLIF = Program Logic Insulation Framework
# Levels are assumed to be something along the following:
# 0 = total failure: e.g. no input or output devices
# 1 = fatal errors: e.g. missing databases, broken connections, out of disk space
# 2 = security: e.g. warnings about repeated cracking attempts
# 3 = non-fatal errors: e.g. propagation of eval() errors as warnings
# 4 = important warnings (e.g. unexpected but possibly legitimate lack of data)
# 5 = important events (e.g. application started)
# 6 =
# 7 = typical checkpoints (e.g. someone tried to do some output)
# 8 =
# 9 = verbose debugging information
# 10 = ridiculously verbose debugging spam
# Note. All of the methods described in this class except for the
# propertyGet, propertySet and propertyExists methods are class
# methods. You can call "$class->notImplemented" without a problem.
# provide a standard virtual constructor
# if already created, merely return $self
sub create {
my $class = shift;
if (ref($class)) {
$class->dump(10, "Tried to call constructor of already existing object $class, so returning same object");
return $class; # already created, return self
} else {
$class->dump(10, "Called constructor of class $class, creating object...");
my $self = $class->bless(@_); # call our real constructor
$self->init(@_);
return $self;
}
}
sub init {} # stub
# provide a constructor that always constructs a new copy of the
# class. This is used by services that implement factories for objects
# implemented in the same class (e.g., session objects do this).
sub objectCreate {
my $class = shift;
if (ref($class)) {
$class = ref($class);
}
$class->dump(10, "Called object constructor of class $class, creating object...");
my $self = $class->bless(@_); # call our real constructor
$self->objectInit(@_);
return $self;
}
sub objectInit {} # stub
# internals of create and objectCreate
sub bless {
my $class = shift;
my $self = {};
CORE::bless($self, $class);
return $self;
}
# provide method-like access for any scalars in $self
sub AUTOLOAD {
my $self = shift;
my $name = $AUTOLOAD;
$name =~ s/^.*://o; # strip fully-qualified portion
if ($self->propertyImpliedAccessAllowed($name)) {
if (scalar(@_) == 1) {
$self->dump(10, "setting implied property '$name' in '$self'");
return $self->propertySet($name, @_);
} elsif (scalar(@_) == 0) {
if ($self->propertyExists($name)) {
$self->dump(10, "getting implied property '$name' in '$self'");
return $self->propertyGet($name);
} else {
$self->dump(10, "not getting non-existent implied property '$name' in '$self'");
return $self->propertyGetUndefined($name);
}
}
$self->dump(10, "neither setting nor getting implied property '$name' in '$self'");
} else {
$self->dump(10, "not treating '$name' in '$self' as an implied property, regardless of its existence");
}
$self->methodMissing($name, @_);
}
sub propertySet {
# this is not a class method
my $self = shift;
my($name, $value) = @_;
return $self->{$name} = $value;
}
sub propertyExists {
# this is not a class method
my $self = shift;
my($name) = @_;
$self->assert($name, 0, 'propertyExists() cannot be called without arguments');
$self->dump(10, "checking for existence of property '$name' in '$self'");
return exists($self->{$name});
}
sub propertyImpliedAccessAllowed {
# this is not (supposed to be) a class method
# my $self = shift;
# my($name) = @_;
# $self->assert($name, 0, 'propertyImpliedAccessAllowed() cannot be called without arguments');
return 1;
}
sub propertyGet {
# this is not a class method
my $self = shift;
my($name) = @_;
return $self->{$name};
}
sub propertyGetUndefined {
return undef;
}
sub methodMissing {
my $self = shift;
my($method) = @_;
$self->error(0, "Internal Error: Tried to access non-existent method '$method' in object '$self'");
}
# DEBUGGING AIDS
sub dump {
my $self = shift;
my($level, @data) = @_;
if ($self->isAtDebugLevel($level)) {
foreach (@data) {
print STDERR "$0: $_\n";
}
}
}
sub warn {
my $self = shift;
my($level, @data) = @_;
if ($self->isAtDebugLevel($level)) {
$self->dump($level, ('-'x12).' Start of Warning Stack Trace '.('-'x12));
cluck(@data); # warn with stack trace
$self->dump($level, ('-'x12). ('-'x30) .('-'x12));
}
}
sub error {
my $self = shift;
my($level, @data) = @_;
$self->dump(9, "error raised: $data[0]");
if ($self->isAtUserLevel($level) and not $LOCKED) {
$LOCKED = 1;
$self->dump(10, 'calling @FATAL error handlers...');
foreach my $entry (@FATAL) {
eval {
&{$entry->[1]}(@data);
};
if ($@) {
$self->warn(3, 'Error occured during \@FATAL callback of object \''.($entry->[0])."': $@");
}
}
$self->dump(10, 'done calling @FATAL error handlers');
$LOCKED = 0;
}
confess(@data); # die with stack trace
}
sub assert {
my $self = shift;
my($condition, $level, @data) = @_;
if (not $condition) {
$self->error($level, @data);
}
}
sub debug {
my $self = shift;
$self->dump(7, @_);
}
sub notImplemented {
my $self = shift;
$self->error(0, 'Internal Error: Method not implemented');
}
# returns true only if the argument is a debug level that is at least
# as important as the local value of $DEBUG.
sub isAtDebugLevel {
my $self = shift;
my($level) = @_;
return ($level <= $DEBUG);
}
# returns true only if the argument is a debug level that is at least
# as important as the local value of $USER.
sub isAtUserLevel {
my $self = shift;
my($level) = @_;
return ($level <= $USER);
}
# returns a reference to the $DEBUG variable for configuration
# purposes
sub getDebugLevel {
return \$DEBUG;
}
# returns a reference to the $USER variable for configuration purposes
sub getUserLevel {
return \$USER;
}
# returns a reference to the @FATAL variable for modules that have
# very exotic needs
sub getFatalHandlerList {
return \@FATAL;
}
# returns a reference to the $LOCKED variable for modules that which
# to block @FATAL reporting
sub getFatalHandlerLock {
return \$LOCKED;
}
# if you call this, make sure that you call the next function too,
# guarenteed, otherwise you will never be freed until the app dies.
# of course, if you _are_ the app then I guess it's ok...
sub enableErrorReporting {
my $self = shift;
push(@FATAL, [$self, sub { $self->fatalError(@_); }]);
}
sub disableErrorReporting {
my $self = shift;
my @OLDFATAL = @FATAL;
@FATAL = ();
foreach my $entry (@OLDFATAL) {
if ($entry->[0] != $self) {
push(@FATAL, $entry);
}
}
}
sub fatalError {} # stub
sub DESTROY {} # stub