view release on metacpan or  search on metacpan

lib/BerkeleyDB/Easy/Common.pm  view on Meta::CPAN

		(qq|        \$self->{$name} = shift; |),
		(qq|        return(\$self);          |),
		(qq|    }                            |),
		(qq|    return(\$self->{$name});     |),
		(qq|}                                |),
	);
}

#
# Prior to compilation, interleave code with line directives so that 
# stack traces will be still be somewhat useful. They'll point to the
# file and line number of our caller, the site of the template definition.
# (Internal method, used by _generate and _accessor)
#
sub _lines {
	my $self = shift;
	my ($file, $line) = (caller)[1..2];

	join qq(# line $line $file(EVAL)\n), 
		map { (my $ln = $_) =~ s/\s*$/\n/; $ln }
		grep $_, @_;
}

#
# Compile some code into the requested package (or caller).
# (Internal method, used by _install)
#
sub _compile {
	my ($self, $code, $name, $pack) = @_;
	$name ||= q(__ANON__);
	$pack ||= caller;

	INFO and $self->_info(qq(Compiling method: $name));

	my ($sub, $err);
	{
		local $@;
		no warnings 'redefine';
		$sub = eval(qq(package $pack; $code));
		($err = $@) =~ s/, at EOF\n$//;
	};

	$self->_fatal(qq(Error compiling method "$name": $err)) if $err;
	
	$sub;
}

#
# BerkeleyDB.pm doesn't throw many exceptions -- only during initialization,
# really -- but whenever it might, we wrap it and localize its global error
# variable as well as the operating system's, so we can return everything
# back to the user in a pristine state.
#
sub _wrap {
	my ($self, $func) = (shift, shift);
	local ($BerkeleyDB::Error, $!, $^E);
	$func->(@_);
}

#
# An even tinier Try::Tiny because lol no dependencies.
#
sub _try {
	my ($self, $try, $catch) = @_;
	my ($ok, $ret, $err);

	my $prev = $@;
	{
		local $@;
		$ok = eval {
			local $@ = $prev;
			$ret = $try->();
			1;
		};
		$err = $@;
	};

	if ($catch and not $ok) {
		local $_ = $err;
		$catch->();
	}

	$ret;
}

#
# Log a message and then warn or die depending on the severity level.
# Just prints to STDOUT for now.
# Used by _throw, and thinly wrapped by:
#   _trace _debug _info _notice _warn _error _fatal
#
sub _log {
	my ($self, $level, @args) = @_;

	if (my $exc = ref $args[0] && $args[0]) {
		# TODO: Unpack error object.
	}

	my $msg = @args ? join q(, ), @args : '';
	print STDERR qq(<< $level : $msg >>\n);
	
	if ($level <= BDB_ERROR) {
		die @args;
	}
	elsif ($level == BDB_WARN) {
		warn @args;
	}
}

INFO and __PACKAGE__->_info(q(Common.pm finished loading));

1;