Path: utzoo!attcan!utgpu!news-server.csri.toronto.edu!mailrus!tut.cis.ohio-state.edu!zaphod.mps.ohio-state.edu!rpi!bu.edu!purdue!haven!uvaarpa!mmdf
From: marc@athena.mit.edu
Newsgroups: comp.lang.perl
Subject: new menu.pl
Message-ID: <1990Jul29.195437.7608@uvaarpa.Virginia.EDU>
Date: 29 Jul 90 19:54:37 GMT
Sender: mmdf@uvaarpa.Virginia.EDU (Uvaarpa Mail System)
Reply-To: marc@mit.edu
Organization: The Internet
Lines: 159

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