gecko-dev/webtools/PLIF/PLIF.pm

316 строки
9.1 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 = 1; # 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:
# Things that should never come up during normal operation:
# 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)
#
# Useful debugging information:
# 5 = important events (e.g. application started)
# 6 = debugging remarks for the section currently under test
# 7 = typical checkpoints (e.g. someone tried to do some output)
# 8 = frequently hit typical checkpoints
# 9 = verbose debugging information
# 10 = ridiculously verbose debugging spam
#
# No code in CVS should do anything at level 6, it is reserved for
# personal debugging.
# 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)) {
return $class; # already created, return self
} else {
my $self = $class->bless(@_); # call our real constructor
$self->serviceInit(@_);
return $self;
}
}
# provide a constructor that always constructs a new copy of the
# class. This is used to create service instances.
sub serviceCreate {
my $class = shift;
if (ref($class)) {
$class = ref($class);
}
my $self = $class->bless(@_); # call our real constructor
$self->serviceInstanceInit(@_);
return $self;
}
sub init {} # stub for services
sub serviceInit {
my $self = shift;
$self->init(@_);
}
sub serviceInstanceInit {
my $self = shift;
$self->init(@_);
}
# 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);
}
my $self = $class->bless(@_); # call our real constructor
$self->objectInit(@_);
return $self;
}
sub objectInit {} # stub for objects
# 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) {
return $self->propertySet($name, @_);
} elsif (scalar(@_) == 0) {
if ($self->propertyExists($name)) {
return $self->propertyGet($name);
} else {
return $self->propertyGetUndefined($name);
}
}
}
$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');
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: ($level) $_\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) {
# XXX this gets called even in eval{} blocks
$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;
}
$self->dump(9, 'Environment dump:');
foreach my $key (sort keys %ENV) {
$self->dump(9, "$key = $ENV{$key}");
}
$self->dump(9, 'Stack trace:');
confess(@data); # die with stack trace
}
# this should not be called with the @data containing a trailing dot
sub assert {
my $self = shift;
my($condition, $level, @data) = @_;
if (not $condition) {
$self->error($level, @data);
}
}
sub debug {
my $self = shift;
$self->dump(6, @_);
}
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 {
my $self = shift;
$self->dump(10, "Called destructor of object $self...");
}