;# $Id: interface.pl,v 3.0.1.6 1998/03/31 15:23:00 ram Exp $
;#
;#  Copyright (c) 1990-1993, Raphael Manfredi
;#  
;#  You may redistribute only under the terms of the Artistic License,
;#  as specified in the README file that comes with the distribution.
;#  You may reuse parts of this distribution only within the terms of
;#  that same Artistic License; a copy of which may be found at the root
;#  of the source tree for mailagent 3.0.
;#
;# $Log: interface.pl,v $
;# Revision 3.0.1.6  1998/03/31 15:23:00  ram
;# patch59: added hook for the new ON command
;#
;# Revision 3.0.1.5  1997/02/20  11:45:12  ram
;# patch55: made use of local $lastcmd instead of main's
;#
;# Revision 3.0.1.4  1995/08/07  16:19:24  ram
;# patch37: new BIFF command interface routine for PERL hooks
;# patch37: fixed symbol table lookups for perl5 support
;#
;# Revision 3.0.1.3  1995/02/16  14:33:49  ram
;# patch32: forgot to add interfaces for BEEP and PROTECT
;#
;# Revision 3.0.1.2  1994/09/22  14:23:38  ram
;# patch12: mailhook package cleaning now done only for subroutines
;# patch12: package name is separated with '::' in perl5
;#
;# Revision 3.0.1.1  1994/07/01  15:01:19  ram
;# patch8: new UMASK command
;# patch8: cannot dataload exit
;#
;# Revision 3.0  1993/11/29  13:48:53  ram
;# Baseline for mailagent 3.0 netwide release.
;#
;# 
;# This is for people who, like me, are perl die-hards :-). It simply provides
;# a simple perl interface for hook scripts and PERL commands. Instead of
;# writing 'COMMAND with some arguments;' in the filter rule file, you may say
;# &command('with some arguments') in the perl script. Big deal! Well, at least
;# that brings you some other nice features from perl itself ;-).
;#
#
# Perl interface with the filter actions
#

package mailhook;

sub abort		{ &interface'dispatch; }
sub annotate	{ &interface'dispatch; }
sub apply		{ &interface'dispatch; }
sub assign		{ &interface'dispatch; }
sub back		{ &interface'dispatch; }
sub beep		{ &interface'dispatch; }
sub begin		{ &interface'dispatch; }
sub biff		{ &interface'dispatch; }
sub bounce		{ &interface'dispatch; }
sub delete		{ &interface'dispatch; }
sub feed		{ &interface'dispatch; }
sub forward		{ &interface'dispatch; }
sub give		{ &interface'dispatch; }
sub keep		{ &interface'dispatch; }
sub leave		{ &interface'dispatch; }
sub macro		{ &interface'dispatch; }
sub message		{ &interface'dispatch; }
sub nop			{ &interface'dispatch; }
sub notify		{ &interface'dispatch; }
sub on			{ &interface'dispatch; }
sub once		{ &interface'dispatch; }
sub pass		{ &interface'dispatch; }
sub perl		{ &interface'dispatch; }
sub pipe		{ &interface'dispatch; }
sub post		{ &interface'dispatch; }
sub process		{ &interface'dispatch; }
sub protect		{ &interface'dispatch; }
sub purify		{ &interface'dispatch; }
sub queue		{ &interface'dispatch; }
sub record		{ &interface'dispatch; }
sub reject		{ &interface'dispatch; }
sub require		{ &interface'dispatch; }
sub restart		{ &interface'dispatch; }
sub resync		{ &interface'dispatch; }
sub run			{ &interface'dispatch; }
sub save		{ &interface'dispatch; }
sub select		{ &interface'dispatch; }
sub server		{ &interface'dispatch; }
sub split		{ &interface'dispatch; }
sub store		{ &interface'dispatch; }
sub strip		{ &interface'dispatch; }
sub subst		{ &interface'dispatch; }
sub tr			{ &interface'dispatch; }
sub umask		{ &interface'dispatch; }
sub unique		{ &interface'dispatch; }
sub vacation	{ &interface'dispatch; }
sub write		{ &interface'dispatch; }

# A perl filtering script should call &exit and not exit directly.
# Perload OFF
# (Cannot be data-loaded or it will corrupt $@ expected by &main'perl)
sub exit { 
	local($code) = @_;
	die "OK\n" unless $code;
	die "Exit $code\n";
}
# Perload ON

package interface;

# Perload OFF
# (Cannot be dynamically loaded as it uses the caller() function)

# The dispatch routine is really simple. We compute the name of our caller,
# prepend it to the argument and call run_command to actually run the command.
# Upon return, if we get anything but a continue status, we simply die with
# an 'OK' string, which will be a signal to the routine monitoring the execution
# that nothing wrong happened.
sub dispatch {
	local($args) = join(' ', @_);			# Arguments for the command
	local($name) = (caller(1))[3];			# Function which called us
	local($status);							# Continuation status
	$name =~ s/^\w+('|::)//;				# Strip leading package name
	&'add_log("calling '$name $args'") if $'loglvl > 18;
	$status = &'run_command("$name $args");	# Case does not matter

	# The status propagation is the only thing we have to deal with, as this
	# is handled within run_command. All other variables which are meaningful
	# for the filter are dynamically bound to function called before in the
	# stack, hence they are modified directly from within the perl script.

	die "Status $status\n" unless $status == $'FT_CONT;

	# Return the status held in $lastcmd, unless the command does not alter
	# the status significantly, in which case we return success. Note that
	# this is in fact a boolean success status, so 1 means success, whereas
	# $lastcmd records a failure status.

	$name =~ tr/a-z/A-Z/;					# Stored upper-cased
	$'Nostatus{$name} ? 1 : !$'lastcmd;		# Propagate status
}

# Perload ON

$in_perl = 0;					# Number of nested perl evaluations

# Record entry in new perl evaluation
sub new {
	++$in_perl;					# Add one evalution level
}

# Reset an empty mailhook package by undefining all its symbols.
# (Warning: heavy wizardry used here -- look at perl's manpage for recipe.)
sub reset {
	return if --$in_perl > 0;	# Do nothing if pending evals remain
	&'add_log("undefining variables from mailhook") if $'loglvl > 11;
	local($key, $val);			# Key/value from perl's symbol table
	# Loop over perl's symbol table for the mailhook package
	eval "*_mailhook = *::mailhook::" if $] > 5;	# Perl 5 support
	while (($key, $val) = each(%_mailhook)) {
		local(*entry) = $val;	# Get definitions of current slot
		# Temporarily disable those. They are causing problems with perl
		# 4.0 PL36 on some machines when running PERL escapes. Keep only
		# the removal of functions since the re-definition of routines is
		# the most harmful with perl 4.0.
		#undef $entry unless length($key) == 1 && $key !~ /^\w/;
		#undef @entry;
		#undef %entry unless $key =~ /^_/ || $key eq 'header';
		undef &entry if defined &entry && &valid($key);
		$_mailhook{$key} = *entry;	# Commit our changes
	}
}

# Return true if the function may safely be undefined
sub valid {
	local($fun) = @_;			# Function name
	return 0 if $fun eq 'exit';	# This function is a convenience
	# We cannot undefine a filter function, which are listed (upper-cased) in
	# the %main'Filter table.
	return 1 unless length($fun) == ($fun =~ tr/a-z/A-Z/);
	return 1 unless $'Filter{$fun};
	0;
}

# Add a new interface function for user-defined commands
sub add {
	local($cmd) = @_;			# Command name
	$cmd =~ tr/A-Z/a-z/;		# Cannonicalize to lower case
	eval &'q(<<EOP);			# Compile new mailhook perl interface function
:	sub mailhook'$cmd { &interface'dispatch; }
EOP
	if (chop($@)) {
		&'add_log("ERROR while adding 'sub $cmd': $@") if $'loglvl;
		&'add_log("WARNING cannot use '&$cmd' in perl hooks")
			if $'loglvl > 5;
	}
}

package main;

