view release on metacpan or  search on metacpan

DB.IN  view on Meta::CPAN

# ------------------------------------------------------*-perl-*-
# GHOSTWHEEL DIMENSION MULTIPLEXER
#
use strict;
package Envy::DB;
use integer;
use Carp;
use Symbol;
use Fcntl;
use vars qw(@ISA @EXPORT_OK $VERSION $EVERSION @DefaultPath
	    $MAX_VAR_LENGTH
	    $LOGIN $Context $NestLevel $Loop $Path @FORCEPATH %PASSWD);
$VERSION = '#VERSION#';
$NestLevel = 0;

umask 0;  # Figure out how to run setuid 'envy'? XXX

$MAX_VAR_LENGTH = 969;  # configure time parameter?

$EVERSION = 4;  # environment variable protocol version

sub EVERSION()    { 'ENVY_VERSION'   }
sub PATH()        { 'ENVY_PATH'      }
sub STATE()       { 'ENVY_STATE'     }
sub DIMENSION()   { 'ENVY_DIMENSION' }
sub CONTEXT()     { 'ENVY_CONTEXT'   }
sub VERBOSE()     { 'ENVY_VERBOSE'   }

if ($ENV{REGRESSION_ENVY_PATH}) {
    @DefaultPath = split m/\s+/, $ENV{REGRESSION_ENVY_PATH};
    @FORCEPATH = ();
} else {
    @DefaultPath = #SEARCH#
	;
    @FORCEPATH = #FORCEPATH#
	;
}

sub new { #PUBLIC
    my ($class, $env) = @_;
    my $o = bless {}, $class;
    my %env = $env? %$env : ();
    $o->{orig} = \%env;
    $o->{where} = $o->{env}{ &CONTEXT } || 'shell';
    $o->{desc} = {};
    $o->{transaction} = 0;
    $o->{warnlevel} = $o->{env}{ &VERBOSE } || 1;
    $o->begin;
    $o;
}

# help cope with backward compatibility
sub version {
    my ($o) = @_;
    $o->{env}{&EVERSION} || $EVERSION;
}

# ---------------------------------------------------------------
# MESSAGES

sub warnlevel {
    my $o=shift;
    if (@_) {
	$o->{warnlevel} = shift;
    } else {
	$o->{warnlevel}
    }
}

sub e { my $o=shift; _internal_warn($o, 0, 1, @_) }   # abort transaction
sub w { my $o=shift; _internal_warn($o, 1, 1, @_) }   # manditory warning
sub n { my $o=shift; _internal_warn($o, 2, 1, @_) }   # optional warning
sub t { my $o=shift; _internal_warn($o, 3, 0, @_) }   # trace execution
sub d { my $o=shift; _internal_warn($o, 4, 0, @_) }   # debugging info

sub _internal_warn {
    my ($o, $level, $show_context) = splice @_, 0, 3;
    my $w = join('', @_);
    if ($show_context) {
	$w .= $Context
	    if $Context && $w !~ m/\n$/s;
    } else {
	$w = 'D ' . ('  'x$NestLevel).$w;
    }
    $w .= "\n" if $w !~ m/\n$/s;
    if ($level <= $o->{strictness}) {
	$w = 'ERROR: '.$w;
	++$o->{errors};
    }
    push @{$o->{'warn'}}, $w