gecko-dev/webtools/PLIF/PLIF.pm

272 lines
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...");
#}