pjs/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 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__;
    }
    local $/ = undef;
    my $data = "package $package;use strict;" . eval "<$package\::DATA>";
    evalString $data, "${package} on-demand section";
    if ($@) {
        $self->error(1, "Error while loading '$package': $@");
        $MODULES{$package} = 0;
    } else {
        $MODULES{$package} = 1;
    }
}

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