зеркало из https://github.com/mozilla/gecko-dev.git
272 строки
8.5 KiB
Perl
272 строки
8.5 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 POSIX qw(strftime); # timestamps in debug output
|
|
use PLIF::Exception;
|
|
my $DEBUG = 9; # level of warnings and dumps to print to STDERR (none go to user)
|
|
my %MODULES = ('PLIF' => 1);
|
|
1;
|
|
|
|
# PLIF = Program Logic Insulation Framework
|
|
|
|
# Levels are assumed to be something along the following:
|
|
# 0 = debugging remarks for the section currently under test
|
|
# 1 =
|
|
# 2 = perl warnings
|
|
# 3 =
|
|
# 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 = frequently hit typical checkpoints
|
|
# 9 = verbose debugging information
|
|
# 10 = ridiculously verbose debugging spam
|
|
|
|
# Note. All of the methods described in this class except for
|
|
# propertyGet, propertySet, the init and load methods, and AUTOLOAD
|
|
# 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);
|
|
$self->load($class);
|
|
return $self;
|
|
}
|
|
|
|
sub load {
|
|
my $self = shift;
|
|
my($package) = @_;
|
|
|
|
if (defined $MODULES{$package}) {
|
|
syntaxError "$package->create() called despite failing to load package" if $MODULES{$package} == 0;
|
|
return;
|
|
}
|
|
|
|
$MODULES{$package} = -1;
|
|
foreach (eval "\@$package\::ISA") {
|
|
$self->load($_) unless $_ eq __PACKAGE__ || $_ eq 'Exporter';
|
|
}
|
|
$MODULES{$package} = 1;
|
|
|
|
# bail early if there is no __DATA__ section
|
|
return unless defined fileno("$package\::DATA");
|
|
|
|
local $/ = undef;
|
|
my $data = "package $package;use strict;" . eval "<$package\::DATA>";
|
|
evalString $data, "${package} on-demand section" unless $@;
|
|
if ($@) {
|
|
$self->error(1, "Error while loading '$package': $@");
|
|
$MODULES{$package} = 0;
|
|
}
|
|
}
|
|
|
|
# turn the magic AUTOLOAD into the slightly more useful and less
|
|
# magical implyMethod().
|
|
sub AUTOLOAD {
|
|
my $self = shift;
|
|
my $name = $AUTOLOAD;
|
|
syntaxError "$name() called without object" if not ref($self);
|
|
$name =~ s/^(.*):://os; # strip fully-qualified portion
|
|
my $package = $1;
|
|
if ($package =~ /::SUPER$/os) {
|
|
# handle calling inherited methods
|
|
$package =~ s/::SUPER$//os;
|
|
my @ISA = eval "if (defined(\@$package\::ISA)) { return \@$package\::ISA }";
|
|
if (@ISA == 1) {
|
|
$package = $ISA[0];
|
|
} else {
|
|
syntaxError "$package\::SUPER->$name() called but $package has multiple ancestors";
|
|
}
|
|
}
|
|
if (not exists $MODULES{$package}) {
|
|
syntaxError "$package->$name() called without loading package";
|
|
} elsif ($MODULES{$package} == 1) {
|
|
my $method = $package->can('implyMethod'); # get a function pointer
|
|
@_ = ($self, $name, @_); # set the arguments
|
|
goto &$method; # invoke the method using deep magic
|
|
} elsif ($MODULES{$package} == 0) {
|
|
syntaxError "$package->$name() called despite failing to load package";
|
|
} else {
|
|
syntaxError "$package->$name() called while loading package";
|
|
}
|
|
}
|
|
|
|
sub propertySet {
|
|
# this is not a class method
|
|
my $self = shift;
|
|
my($name, $value) = @_;
|
|
return $self->{$name} = $value;
|
|
}
|
|
|
|
sub propertyGet {
|
|
# this is not a class method
|
|
my $self = shift;
|
|
my($name) = @_;
|
|
return $self->{$name};
|
|
}
|
|
|
|
sub implyMethod {
|
|
my $self = shift;
|
|
my($method) = @_;
|
|
syntaxError "Tried to access non-existent method '$method' in object '$self'";
|
|
}
|
|
|
|
|
|
# DEBUGGING AIDS
|
|
|
|
sub dump {
|
|
my $self = shift;
|
|
my($level, @data) = @_;
|
|
if ($self->isAtDebugLevel($level)) {
|
|
my $time = strftime('%Y-%m-%d %H:%M:%S UTC', gmtime());
|
|
foreach (@data) {
|
|
print STDERR "$0.$$ \@ $time: ($level) $_\n";
|
|
}
|
|
}
|
|
}
|
|
|
|
sub warn {
|
|
my $self = shift;
|
|
my($level, @data) = @_;
|
|
if ($self->isAtDebugLevel($level)) {
|
|
$self->dump($level, ('-'x20).' Start of Warning Stack Trace '.('-'x20));
|
|
report PLIF::Exception ('message' => join("\n", @data));
|
|
$self->dump($level, ('-'x20). ('-'x30) .('-'x20));
|
|
}
|
|
}
|
|
|
|
# raises a generic error with the arguments passed as the message
|
|
# use this for internal errors that don't have their own exception objects
|
|
# this should not be called with the @data containing a trailing dot
|
|
sub error {
|
|
my $self = shift;
|
|
my($level, @data) = @_;
|
|
# the next three lines are a highly magical incantation to remove
|
|
# this call from the stack so that the stack trace looks like the
|
|
# previous function raised the exception itself
|
|
my $raise = PLIF::Exception->can('raise'); # get a function pointer
|
|
@_ = ('PLIF::Exception', 'message', join("\n", @data)); # set the arguments
|
|
goto &$raise; # and invoke the call using deep call stack magic
|
|
}
|
|
|
|
# this should not be called with the @data containing a trailing dot
|
|
sub assert {
|
|
my $self = shift;
|
|
my($condition, $level, @data) = @_;
|
|
if (not $condition) {
|
|
# the next three lines are a highly magical incantation to remove
|
|
# this call from the stack so that the stack trace looks like the
|
|
# previous function raised the exception itself
|
|
my $raise = PLIF::Exception->can('raise');
|
|
@_ = ('PLIF::Exception', 'message', join("\n", @data));
|
|
goto &$raise;
|
|
}
|
|
}
|
|
|
|
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 a reference to the $DEBUG variable for configuration
|
|
# purposes
|
|
sub getDebugLevel {
|
|
return \$DEBUG;
|
|
}
|
|
|
|
sub DESTROY {}
|
|
# my $self = shift;
|
|
# $self->dump(10, "Called destructor of object $self...");
|
|
#}
|