Other packages in the module: Error Error::Simple

Toolbar

Package variables

Included modules

Synopsis

No synopsis!

Description

No description!

Methods

Methods description

None available.

Methods code

sub associate {

    my $err = shift;
    my $obj = shift;

    return unless ref($obj);

    if($obj->isa('HASH')) {
	$obj->{'__Error__'} = $err;
    }
    elsif($obj->isa('GLOB')) {
	${*$obj}{'__Error__'} = $err;
    }
    $obj = ref($obj);
    $ERROR{ ref($obj) } = $err;

    return;

}

sub catch {

    my $pkg = shift;
    my $code = shift;
    my $clauses = shift || {};
    my $catch = $clauses->{'catch'} ||= [];

    unshift @$catch,  $pkg, $code;

    $clauses;
}

# Object query methods

}

sub file {

    my $self = shift;
    exists $self->{'-file'} ? $self->{'-file'} : undef;

}

sub import {

    shift;
    local $Exporter::ExportLevel = $Exporter::ExportLevel + 1;
    Error::subs->import(@_);
}

# I really want to use last for the name of this method, but it is a keyword
# which prevent the syntax  last Error

}

sub line {

    my $self = shift;
    exists $self->{'-line'} ? $self->{'-line'} : undef;

}

sub new {

    my $self = shift;
    my($pkg,$file,$line) = caller($Error::Depth);

    my $err = bless {
	'-package' => $pkg,
	'-file'    => $file,
	'-line'    => $line,
	@_
    }, $self;

    $err->associate($err->{'-object'})
	if(exists $err->{'-object'});

    # To always create a stacktrace would be very inefficient, so
    # we only do it if $Error::Debug is set

    if($Error::Debug) {
	require Carp;
	local $Carp::CarpLevel = $Error::Depth;
	my $text = defined($err->{'-text'}) ? $err->{'-text'} : "Error";
	my $trace = Carp::longmess($text);
	# Remove try calls from the trace
	$trace =~ s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog;
	$err->{'-stacktrace'} = $trace
    }

    $@ = $LAST = $ERROR{$pkg} = $err;
}

# Throw an error. this contains some very gory code.

}

sub object {

    my $self = shift;
    exists $self->{'-object'} ? $self->{'-object'} : undef;

}

sub prior {

    shift; # ignore

    return $LAST unless @_;

    my $pkg = shift;
    return exists $ERROR{$pkg} ? $ERROR{$pkg} : undef
	unless ref($pkg);

    my $obj = $pkg;
    my $err = undef;
    if($obj->isa('HASH')) {
	$err = $obj->{'__Error__'}
	    if exists $obj->{'__Error__'};
    }
    elsif($obj->isa('GLOB')) {
	$err = ${*$obj}{'__Error__'}
	    if exists ${*$obj}{'__Error__'};
    }

    $err;
}

# Return as much information as possible about where the error
# happened. The -stacktrace element only exists if $Error::DEBUG
# was set when the error was created

}

sub record {

    my $self = shift;
    local $Error::Depth = $Error::Depth + 1;

    $self->new(@_);
}

# catch clause for
#
# try { ... } catch CLASS with { ... 

}

sub stacktrace {

    my $self = shift;

    return $self->{'-stacktrace'}
	if exists $self->{'-stacktrace'};

    my $text = exists $self->{'-text'} ? $self->{'-text'} : "Died";

    $text .= sprintf(" at %s line %d.\n", $self->file, $self->line)
	unless($text =~ /\n$/s);

    $text;
}

# Allow error propagation, ie
#
# $ber->encode(...) or
#    return Error->prior($ber)->associate($ldap);

}

sub stringify {

    my $self = shift;
    defined $self->{'-text'} ? $self->{'-text'} : "Died";

}

sub text {

    my $self = shift;
    exists $self->{'-text'} ? $self->{'-text'} : undef;
}

# overload methods

}

sub throw {

    my $self = shift;
    local $Error::Depth = $Error::Depth + 1;

    # if we are not rethrow-ing then create the object to throw
    $self = $self->new(@_) unless ref($self);
    
    die $Error::THROWN = $self;
}

# syntactic sugar for
#
#    die with Error( ... );

}

sub value {

    my $self = shift;
    exists $self->{'-value'} ? $self->{'-value'} : undef;
}

package Error::Simple;

@Error::Simple::ISA = qw(Error);

}

sub with {

    my $self = shift;
    local $Error::Depth = $Error::Depth + 1;

    $self->new(@_);
}

# syntactic sugar for
#
#    record Error( ... ) and return;

}

General documentation