view release on metacpan or  search on metacpan

Datum/Strip.pm  view on Meta::CPAN

require Exporter;

use vars qw(@ISA @EXPORT_OK);
@ISA = qw(Exporter);

@EXPORT_OK = qw(datum_strip);

use Log::Agent;

#
# datum_strip
#
# Strip all Datum assertions in file and flow control tracing.
# Also turn Datum off by stripping the "use" line.
#
# Let all DTRACE statements pass through.
#
# Arguments:
#   file	old file path, to strip
#   fnew	new file, stripped
#	ext		when defined, renames fnew as file upon success and file with ext
#
# Returns 1 if OK, undef otherwise.
#
sub datum_strip {
	my ($file, $fnew, $ext) = @_;

	local *OLD;
	local *NEW;

	if ($file eq '-') {
		logdie "can't dup stdin: $!" unless open(OLD, '<&STDIN');
	} else {
		unless (open(OLD, $file)) {
			logerr "can't open $file: $!";
			return;
		}
	}

	if ($fnew eq '-') {
		logdie "can't dup stdout: $!" unless open(NEW, '>&STDOUT');
	} else {
		unless (open(NEW, ">$fnew")) {
			logerr "can't create $fnew: $!";
			close OLD;
			return;
		}
	}

	eval { strip(\*OLD, \*NEW) };
	if (chop $@) {
		logerr "can't write to $fnew: $@";
		close NEW;
		close OLD;
		return;
	}

	if ($file ne '-' && $fnew ne '-') { 
		my $mode = (stat(OLD))[2] & 07777;
		chmod $mode, $fnew or logwarn "can't propagate mode %04o on $fnew: $!";
	}

	unless (close NEW) {
		logerr "can't flush $fnew: $!";
		close OLD;
		return;
	}

	close OLD;
	return 1 if $file eq '-' || $fnew eq '-';
	return 1 unless defined $ext;

	unless (rename($file, "$file$ext")) {
		logwarn "can't rename $file as $file$ext: $!";
		return;
	}

	unless (rename($fnew, $file)) {
		logwarn "can't rename $fnew as $file: $!";
		return;
	}

	return 1;		# OK
}

#
# strip
#
# Lexical stripping of assertions, and return tracing routines.
# We don't have the pretention of handling all the possible cases.
# That would be foolish, because we'd have to write a Perl parser!
#
# Therefore, unless the conventions documented in the Carp::Datum manpage
# are strictly followed, stripping will be incorret.
#
# Note: we don't remove DTRACE, they will be remapped to Log::Agent calls
# dynamically.  We can't do that statically because the syntax is not
# compatible.
#
sub strip {
	my ($old, $new) = @_;

	local $_;
	my $last_was_nl = 0;

	while (<$old>) {
		next if s/^(\s*use Carp::Datum).*;/$1;/;	# Turns it off
		next if s/^(\s*)(?:DVOID|DVAL|DARY)\b/$1/;
		next if s/^(\s*return)\s+DVOID\b/$1/;
		next if s/^(\s*return\s+)(?:(?:DVAL|DARY)\s*)/$1/;

		if (s/^(\s*)(?:DFEATURE|DREQUIRE|DENSURE|DASSERT)\b//) {
			my $indent = $1;
			$_ = skip_to_sc($old, $_);
			s/^\s+//;
			$_ = /^\s*$/ ? '' : ($indent . $_);		# Keep leading indent
			next;
		}
	} continue {
		my $is_nl = /^\s*$/;