error.pm

普通的ETL工具

# vim:ts=4 sw=4
# ----------------------------------------------------------------------------------------------------
#  Name		: ETL::Pequel3::Error.pm
#  Created	: 7 June 2006
#  Author	: Mario Gaffiero (gaffie)
#
# Copyright 1999-2007 Mario Gaffiero.
# 
# This file is part of Pequel (TM)
# 
# Pequel is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
# 
# Pequel is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# You should have received a copy of the GNU General Public License
# along with Class::STL::Containers; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
# ----------------------------------------------------------------------------------------------------
# Modification History
# When          Version     Who     What
# ----------------------------------------------------------------------------------------------------
# TO DO:
# ----------------------------------------------------------------------------------------------------
package ETL::Pequel3::Error;
require 5.005_62;
use strict;
use warnings;
# ----------------------------------------------------------------------------------------------------
{
	package ETL::Pequel3::Error; # Singleton
	use base qw(Class::STL::Element);
	use Class::STL::ClassMembers qw( trace_dir trace_filename ), 
		Class::STL::ClassMembers::DataMember->new(name => 'trace_level', default => 0),
		Class::STL::ClassMembers::DataMember->new(name => 'echo', default => 0),
		Class::STL::ClassMembers::DataMember->new(name => 'diag_level', default => 0),
		Class::STL::ClassMembers::DataMember->new(name => 'diag_show_time', default => 0),
		Class::STL::ClassMembers::DataMember->new(name => 'debug_on', default => 0);
	use Class::STL::ClassMembers::SingletonConstructor;
	use UNIVERSAL qw(isa can);
	use Carp qw(confess);
	sub new_extra {
		my $self = shift;
		$self->trace_dir('./_Pequel') unless (defined($self->trace_dir()));
		mkdir("@{[ $self->trace_dir() ]}");
		# get the prefix:
		$self->trace_level($ENV{PEQUEL_TRACE_LEVEL}) if (defined($ENV{PEQUEL_TRACE_LEVEL}));
		$self->trace_level(0) unless ($self->trace_level() =~ /^\d+$/);
		$self->echo($ENV{PEQUEL_TRACE_ECHO}) if (defined($ENV{PEQUEL_TRACE_ECHO}));
		if ($self->trace_level() > 0) {
			$self->trace_filename("@{[ $self->trace_dir ]}/trace$$.log") unless (defined($self->trace_filename()));
			my $sub = "{ package " . __PACKAGE__ . ";";
			$sub .= "sub trace_msg { my \$self=shift; my \$level=shift; my \$msg=shift;";
			$sub .= "return unless (\$self->trace_level() >= \$level);";
			$sub .= "open(TRACE, \">>@{[ $self->trace_filename() ]}\");";
			$sub .= "print TRACE \"\$msg\\n\";";
			$sub .= "close(TRACE);";
			$sub .= "print STDERR \"trace(\$level):\$msg\\n\";" if ($self->echo());
	   		$sub .= "}";
			$sub .= "}";
			eval($sub);
			print STDERR "Error in eval:$@\n" if ($@);
		}
		else {
			my $sub = "{ package " . __PACKAGE__ . ";";
			$sub .= "sub trace_msg { }";
			$sub .= "}";
			eval($sub);
			print STDERR "Error in eval:$@\n" if ($@);
		}
		return $self;
	}
	sub diag {
		my $self = shift;
		my $level = shift;
		my $msg = shift;
		my $no_newline = shift;
		return unless ($self->diag_level() >= $level || $self->trace_level() >= $level);
		print STDERR '[' . localtime() . '] ' if ($self->diag_show_time());
		print STDERR $msg;
		print STDERR "\n" if (!defined($no_newline) || $no_newline == 0);
	}
	sub user_error {
		my $self = shift;
		my $errnum = shift;
		my $msg = shift;
		$self->trace_level()
			? confess "Error: [$errnum] $msg\n"
			: print STDERR "Error: [$errnum] $msg\n";
		$self->debug_msg("Called at:", join('-->', caller()), "\n") if ($self->debug_on());
	}
	sub user_warn {
		my $self = shift;
		my $errnum = shift;
		my $msg = shift;
			print STDERR "Warning: [$errnum] $msg\n";
	}
	sub debug_msg {
		my $self = shift;
		my $msg = shift;
		print STDERR $msg, "\n" if ($self->debug_on());
	}
	sub newline_off
	{
	}
	sub newline_on
	{
	}
}
# ----------------------------------------------------------------------------------------------------
1;