[comp.lang.perl] new menu.pl

marc@athena.mit.edu (07/30/90)

I've added a few new features to my menu package.  It's short, so I'm
reposting the whole thing:

--cut--
# package, meant to be do'ed, not run directly
#
# $Id: menu.pl,v 1.2 90/07/29 02:50:42 marc Exp $
#

package menu;

@gencmds = (
	"help","__internal","Print the list of commands in this menu",
	"?","","help",
	"exit","__internal","Exit the current menu",
	"quit","__internal","Quit",
);

sub sigint {
	$foo = "@_[0..]";  # always generates a perl error at runtime.
}

sub main'menu { # @_ = ($prompt,@cmds)
	local($oldsigint,$prompt,@cmds,%fcts,%helps);

	$prompt = shift(@_);
	@table = (@_,@gencmds);

	while (@table > $[) {
		$cmd = shift(@table);
		$fct = shift(@table);
		$help = shift(@table);
		if (defined($fcts{$cmd})) {next;}
		if ($fct eq "") {
			$fct = $fcts{$help};
			$help = $helps{$help};
		}
		push(@cmds,$cmd);
		$fcts{$cmd} = $fct;
		$helps{$cmd} = $help;
	}

	while (1) {
		print "\n$prompt: ";
		if (!($_ = <>)) {
			print "eof on input.  Aborting...\n";
			exit(2);
		}
		chop;

		# strip leading whitespace, get cmd, arg.
		/^\s*(\S+)\s*/;
		($cmd,$arg) = ($1,$');
		# strip trailing whitespace
		$arg =~ /\s*$/;
		$arg = $`;

		if (defined($fct = $fcts{$cmd})) {
			if ($fct eq "__internal") { # Magic...
				if (($_ eq "help") || ($_ eq "?")) {
					foreach (@cmds) {
						printf "%-15s%s\n",$_,$helps{$_};
					}
				} elsif ($cmd eq "exit") {
					return;
				} elsif ($cmd eq "quit") {
					exit(0);
				} else {
					die "Bogon __internal $_!\n";
				}
			} else {
				if (!($fct =~ /\'/)) {
					$fct = "main'".$fct;
				}

				# exception handling!

				$oldsigint = $main'SIG{'INT'};
				$main'SIG{'INT'} = "menu'sigint";

				eval("&$fct(\$arg);");

				$main'SIG{'INT'} = $oldsigint;
				
			}
		} else {
			print "\"$cmd\" is not a valid command.  Type ? for help.\n";
		}
	}
}
--cut--

Of particular interest are the following lines:

	sub sigint {
		$foo = "@_[0..]";  # always generates a perl error at runtime.
	}

	# ...

	# exception handling!

	$oldsigint = $main'SIG{'INT'};
	$main'SIG{'INT'} = "menu'sigint";

	eval("&$fct(\$arg);");

	$main'SIG{'INT'} = $oldsigint;

I've basically implemented exception handling.  Since eval returns at
any fatal error, the menu function can be aborted at any time by a
perl error.  In this case, I install a signal handler which causes a
perl error.  (Larry, is there any better way to generate a guaranteed
perl error?)  It would be pretty trivial to implement throw- and
catch-style semantics given this technique: (Following untested)

sub catch {
	local($thrown);
	$thrown = 0;
	eval($_[0]);
	if ($thrown) {
		print "Exception caught\n";
	}
}

sub throw {
	$thrown = 1;
	$foo = "@_[0..]";
}

sub main {
	&catch("&s1();");
}

sub s1 {
	#...
	&s2();
	#...
}	

sub s2 {
	#...
	&s3();
	#...
}	

sub s1 {
	#...
	&throw();
	#...
}	

With some clever code, you could probably implement real catch and
throw, with different kinds of throws and data.

I think this one can go under "functionality Larry never even dreamed
about."  Need another chapter in the book? :-)

		Marc

lwall@jpl-devvax.JPL.NASA.GOV (Larry Wall) (07/31/90)

In article <1990Jul29.195437.7608@uvaarpa.Virginia.EDU> marc@mit.edu writes:
: Of particular interest are the following lines:
: 
: 	sub sigint {
: 		$foo = "@_[0..]";  # always generates a perl error at runtime.
: 	}
: 
: 	# ...
: 
: 	# exception handling!
: 
: 	$oldsigint = $main'SIG{'INT'};
: 	$main'SIG{'INT'} = "menu'sigint";
: 
: 	eval("&$fct(\$arg);");
: 
: 	$main'SIG{'INT'} = $oldsigint;
: 
: I've basically implemented exception handling.  Since eval returns at
: any fatal error, the menu function can be aborted at any time by a
: perl error.  In this case, I install a signal handler which causes a
: perl error.  (Larry, is there any better way to generate a guaranteed
: perl error?)  It would be pretty trivial to implement throw- and
: catch-style semantics given this technique: (Following untested)

You don't need to get so fancy to generate a fatal error.  Just use the
die operator:

	sub sigint {
	    die 'Here is a parameter that will be passed back in $@' . "\n";
	}

: With some clever code, you could probably implement real catch and
: throw, with different kinds of throws and data.

Seems fairly easy to me.  Here's an implementation of typed exception
handlers:

sub catch {
    local($typelist, $code) = @_;
    local($retval);
    eval $code;
    if ($@ =~ /^(\w*):/) {
	$retval = $1;
	die $@ unless $typelist =~ /\b$retval\b/;	# propagate exception
	$@ =~ s/^\w*://;
    }
    elsif ($@ ne '') {
	die $@;
    }
    $retval;
}

sub throw {
    local($type, $message) = @_;
    die "$type:$message\n";
}

$except = &catch('INT MATH SYNTAX', '&calc');
if ($except eq 'MATH') {...}


sub calc {
    ...
    &throw('MATH', "Can't divide by zero") if $denom == 0;
    ...
}

Or something like that--I haven't tested it.

: I think this one can go under "functionality Larry never even dreamed
: about."

Don't teach your grandmother to suck eggs.   :-)

: Need another chapter in the book? :-)

Short chapter.  :-)

Larry