gecko-dev/webtools/PLIF/PLIF.pm

# -*- 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
use POSIX qw(strftime); # timestamps in debug output
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)) {
        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, ('-'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 wish
# 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...");
}