Article 4654 of comp.lang.perl: Xref: feenix.metronet.com comp.lang.perl:4654 Newsgroups: comp.lang.perl Path: feenix.metronet.com!news.ecn.bgu.edu!usenet.ins.cwru.edu!howland.reston.ans.net!darwin.sura.net!uvaarpa!mmdf From: William Hails Subject: menu utility and perl-byacc eg Message-ID: <1993Jul29.181612.10290@uvaarpa.Virginia.EDU> Sender: mmdf@uvaarpa.Virginia.EDU (Mail System) Reply-To: bill@tardis.co.uk Organization: The Internet Date: Thu, 29 Jul 1993 18:16:12 GMT Lines: 725 If you haven't got perl-byacc yet, it's worth a look. Available from ftp.sterling.com [192.124.9.1] in /local/perl-byacc1.8.2.tar.Z (info amended from perl FAQ). Although I first thought the idea was more than a bit OTT, after playing with it for less than a day I'd come up with a (IMHO) really neat menu system for perl, which I'm posting both as an example of perl-byacc and as a useful utility in its own right. Basically you can write: require('menu.pl'); $result = &menu(<<'EOMENU'); MENU main "Main Menu" "Sub Menu" MENU sub1 "Do Some Perl" & some perl & END MENU sub1 'A Sub-Menu' ... END ... EOMENU eval($result) if $result; and see: Main Menu --------- What do you want to do? a) Sub Menu b) Do Some Perl x) exit Select an option[x]: A re-working for curseperl could be very interesting, but perhaps the most exciting thing (well .. I'm easily excited :-) is that since everything is run-time, menus can be constructed on the fly. As not everyone has perl-byacc I'm including the yacc output as menu2.pl - COPY to menu.pl and *DON'T RUN MAKE*. 8<----8<----8<----8<----8<----8<----8<----8<----8<----8<----8<----8<---- #! /bin/sh # This is a shell archive. Remove anything before this line, then unpack # it by saving it into a file and typing "sh file". To overwrite existing # files, type "sh file -c". You can also feed this as standard input via # unshar, or by typing "sh 'Makefile' <<'END_OF_FILE' X# makefile for perl menu system X Xmenu.pl: menu.y X rm -f $@ X byacc -P menu.y X mv y.tab.pl $@ END_OF_FILE if test 92 -ne `wc -c <'Makefile'`; then echo shar: \"'Makefile'\" unpacked with wrong size! fi # end of 'Makefile' fi if test -f 'menu.doc' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'menu.doc'\" else echo shar: Extracting \"'menu.doc'\" \(993 characters\) sed "s/^X//" >'menu.doc' <<'END_OF_FILE' XThe &menu() function takes an argument string specifying the menu Xstructure according to the following grammar: X Xmenus :1 menu X |2 menus menu X ; X Xmenu :3 MENU NAME STRING options END X ; X Xoptions :4 option X |5 options option X ; X Xoption :6 STRING action X |7 '*' STRING action X |8 IF NAME STRING action X ; X Xaction :9 MENU NAME X |10 PERL X ; X XIt translates this into a string of perl which can then be eval'd X(or written to a file or whatever). X XEND - keyword 'END' XIF - keyword 'IF' XMENU - keyword 'MENU' XNAME - a name (/^[a-zA-Z_][a-zA-Z0-9_]*$/) not a keyword XPERL - raw perl code, delimited by any two matching non-alphanumeric X non-whitespace characters which cannot occur, even escaped X (sorry) in the quoted code. XSTRING - a string, delimeted by matching ' or " X Xa '*' in front of a menu option specifies the default option if the Xuser just hits return. The IF NAME construct means that unless X$NAME is true when the generated code is eval'd that menu option Xwill not appear. END_OF_FILE if test 993 -ne `wc -c <'menu.doc'`; then echo shar: \"'menu.doc'\" unpacked with wrong size! fi # end of 'menu.doc' fi if test -f 'menu.y' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'menu.y'\" else echo shar: Extracting \"'menu.y'\" \(3849 characters\) sed "s/^X//" >'menu.y' <<'END_OF_FILE' X%{ package menu; X$menuident = "$Id: menu.y,v 1.4 1993/07/28 14:13:22 bill Exp $"; X%} X%token MENU NAME STRING END PERL STAR IF X X%start menus X X%% X Xmenus : menu X | menus menu X ; X Xmenu : MENU NAME STRING options END X { X ++$topstate; X ++$menus{$2}; X $statedecls .= "\$" . $2 . " = $topstate;\n"; X $defaultact = ' || $ans eq "\n"' unless $selectopt; X $selectopt = '[x]' unless $selectopt; X $main_loop .= "\n if (\$NEXTSTATE == \$" . $2 . X ") {\n\tsystem 'clear';\n" . X "\tprint q@" . "\n" . $3 . "\n" . X '-' x length($3) ."\n\n" . X " What do you want to do?\n\n@;\n" . X $option_strings . X "\tprint \"\\tx) exit\\n\\n\";\n" . X "\n\tprint \" Select an option" . $selectopt . X ": \";\n\n\t" . X '($ans = substr(,0,1)) =~ y/A-Z/a-z/;' . X "\n\t" . 'exit(0) if $ans eq "x" || $ans eq ""' . X $defaultact . ';' . X "\n" . $selectactions . "\n" . X "\tnext LOOP;\n }\n"; X $option_strings = $selectactions = X $selectopt = $defaultact = ''; X $optionchar = 'a'; X } X ; X Xoptions : option X | options option X ; X Xoption : STRING action X { X $option_strings .= "\tprint \"\\t$optionchar) " . X $1 . "\\n\";\n"; X $selectactions .= "\tif (\$ans eq '$optionchar') { " . X $2 . " }\n"; X ++$optionchar; X } X | STAR STRING action X { X $option_strings .= "\tprint \"\\t$optionchar) " . $2 . X "\\n\";\n"; X $selectactions .= X "\tif (\$ans eq '$optionchar' || \$ans eq \"\\n\") { " . X $3 . " }\n"; X $selectopt = "[$optionchar]"; X ++$optionchar; X } X | IF NAME STRING action X { X $option_strings .= "\tprint \"\\t$optionchar) " . X $3 . "\\n\" if \$" . $2 . ";\n"; X $selectactions .= "\tif (\$" . $2 . X " && \$ans eq '$optionchar') { " . $4 . " }\n"; X ++$optionchar; X } X ; X Xaction : MENU NAME X { X push(@called_menus, $2); X $$ = "\$NEXTSTATE = \$" . $2 . ";"; X } X | PERL X { $$ = $1; } X ; X X%% X X# end of grammar X Xsub main'menu { X ($text) = @_; X @text = split("\n", $text); X $optionchar = 'a'; X $main_loop = ''; X $line = ''; X $option_strings = $selectactions = ''; X $selectopt = $defaultact = ''; X $resultmenu = ''; X $lineno = 0; X X &yyparse; X X foreach $menu (@called_menus) { X &yyerror("menu $menu used but not defined") X unless $menus{$menu}; X } X X $resultmenu = $statedecls . "\n" . X "LOOP: for (\$NEXTSTATE = 1;;) {\n" . X $main_loop . "}\n"; X X $errors ? undefined : $resultmenu; X} X Xsub yyerror { X print @_, " in menu at line $lineno, token: '$yylval'\n"; X ++$errors; X} X Xsub yylex { X TOKEN: for (;;) { X $line =~ s/^[ \t\f\r\v]*//; X print "Line is: '$line'\n" if $yydebug; X if ($line eq '') { X $line = shift(@text); X ++$lineno; X return(0) if !defined $line; X next TOKEN; X } elsif ($line =~ /^#/) { X $line = ''; X next TOKEN; X } elsif ($line =~ /^(['"])/) { X $char = $1; X if ($line =~ s/^$char([^$char]*)$char//) { X ($yylval = $1) =~ s/@/\\@/g; X } else { X &yyerror('unterminated string'); X $yylval = ''; X } X return $STRING; X } elsif ($line =~ s/^(MENU)\b//) { X $yylval = $1; # for errors X return $MENU; X } elsif ($line =~ s/^(END)\b//) { X $yylval = $1; X return $END; X } elsif ($line =~ s/^(IF)\b//) { X $yylval = $1; X return $IF; X } elsif ($line =~ s/^(\w+)//) { X $yylval = $1; X return $NAME; X } elsif ($line =~ s/^(\*)//) { X $yylval = $1; X return $STAR; X } else { X $line =~ s/^(.)//; X $sep = "\\" . $1; X print "Sep is: '$sep'\n" if $yydebug; X until ($line =~ /$sep/) { X $nextline = shift(@text); X ++$lineno; X last TOKEN if !defined $nextline; X $line .= "\xFF" . $nextline; X } X $yylval = $line; X $line =~ s/.*$sep//; X $yylval =~ s/$sep.*//; X $yylval =~ s/\xFF/\n/g; X print "Collected: $yylval" if $yydebug; X return $PERL; X } X } X} X X1; END_OF_FILE if test 3849 -ne `wc -c <'menu.y'`; then echo shar: \"'menu.y'\" unpacked with wrong size! fi # end of 'menu.y' fi if test -f 'menu2.pl' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'menu2.pl'\" else echo shar: Extracting \"'menu2.pl'\" \(8158 characters\) sed "s/^X//" >'menu2.pl' <<'END_OF_FILE' X$yysccsid = "@(#)yaccpar 1.8 (Berkeley) 01/20/91 (Perl 2.0 12/31/92)"; X X package menu; X$menuident = "$Id: menu.y,v 1.4 1993/07/28 14:13:22 bill Exp $"; X$MENU=257; X$NAME=258; X$STRING=259; X$END=260; X$PERL=261; X$STAR=262; X$IF=263; X$YYERRCODE=256; X@yylhs = ( -1, X 0, 0, 1, 2, 2, 3, 3, 3, 4, 4, X); X@yylen = ( 2, X 1, 2, 5, 1, 2, 2, 3, 4, 2, 1, X); X@yydefred = ( 0, X 0, 0, 1, 0, 2, 0, 0, 0, 0, 0, X 4, 0, 10, 6, 0, 0, 3, 5, 9, 7, X 0, 8, X); X@yydgoto = ( 2, X 3, 10, 11, 14, X); X@yysindex = ( -254, X -245, -254, 0, -250, 0, -252, -249, -244, -242, -258, X 0, -241, 0, 0, -249, -240, 0, 0, 0, 0, X -249, 0, X); X@yyrindex = ( 0, X 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, X 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, X 0, 0, X); X@yygindex = ( 0, X 12, 0, 8, -15, X); X$YYTABLESIZE=19; X@yytable = ( 20, X 7, 17, 1, 8, 9, 22, 7, 12, 6, 8, X 9, 13, 4, 5, 15, 16, 19, 18, 21, X); X@yycheck = ( 15, X 259, 260, 257, 262, 263, 21, 259, 257, 259, 262, X 263, 261, 258, 2, 259, 258, 258, 10, 259, X); X$YYFINAL=2; X X X X$YYMAXTOKEN=263; X Xsub yyclearin { $yychar = -1; } Xsub yyerrok { $yyerrflag = 0; } X$YYSTACKSIZE = $YYSTACKSIZE || $YYMAXDEPTH || 500; X$YYMAXDEPTH = $YYMAXDEPTH || $YYSTACKSIZE || 500; X$yyss[$YYSTACKSIZE] = 0; X$yyvs[$YYSTACKSIZE] = 0; Xsub YYERROR { ++$yynerrs; &yy_err_recover; } Xsub yy_err_recover X{ X if ($yyerrflag < 3) X { X $yyerrflag = 3; X while (1) X { X if (($yyn = $yysindex[$yyss[$yyssp]]) && X ($yyn += $YYERRCODE) >= 0 && X $yycheck[$yyn] == $YYERRCODE) X { X X $yyss[++$yyssp] = $yystate = $yytable[$yyn]; X $yyvs[++$yyvsp] = $yylval; X next yyloop; X } X else X { X X return(1) if $yyssp <= 0; X --$yyssp; X --$yyvsp; X } X } X } X else X { X return (1) if $yychar == 0; X X $yychar = -1; X next yyloop; X } X0; X} # yy_err_recover X Xsub yyparse X{ X X if ($yys = $ENV{'YYDEBUG'}) X { X $yydebug = int($1) if $yys =~ /^(\d)/; X } X X X $yynerrs = 0; X $yyerrflag = 0; X $yychar = (-1); X X $yyssp = 0; X $yyvsp = 0; X $yyss[$yyssp] = $yystate = 0; X Xyyloop: while(1) X { X yyreduce: { X last yyreduce if ($yyn = $yydefred[$yystate]); X if ($yychar < 0) X { X if (($yychar = &yylex) < 0) { $yychar = 0; } X X } X if (($yyn = $yysindex[$yystate]) && ($yyn += $yychar) >= 0 && X $yycheck[$yyn] == $yychar) X { X X $yyss[++$yyssp] = $yystate = $yytable[$yyn]; X $yyvs[++$yyvsp] = $yylval; X $yychar = (-1); X --$yyerrflag if $yyerrflag > 0; X next yyloop; X } X if (($yyn = $yyrindex[$yystate]) && ($yyn += $yychar) >= 0 && X $yycheck[$yyn] == $yychar) X { X $yyn = $yytable[$yyn]; X last yyreduce; X } X if (! $yyerrflag) { X &yyerror('syntax error'); X ++$yynerrs; X } X return(1) if &yy_err_recover; X } # yyreduce X X $yym = $yylen[$yyn]; X $yyval = $yyvs[$yyvsp+1-$yym]; X switch: X { Xif ($yyn == 3) { X{ X ++$topstate; X ++$menus{$yyvs[$yyvsp-3]}; X $statedecls .= "\$" . $yyvs[$yyvsp-3] . " = $topstate;\n"; X $defaultact = ' || $ans eq "\n"' unless $selectopt; X $selectopt = '[x]' unless $selectopt; X $main_loop .= "\n if (\$NEXTSTATE == \$" . $yyvs[$yyvsp-3] . X ") {\n\tsystem 'clear';\n" . X "\tprint q@" . "\n" . $yyvs[$yyvsp-2] . "\n" . X '-' x length($yyvs[$yyvsp-2]) ."\n\n" . X " What do you want to do?\n\n@;\n" . X $option_strings . X "\tprint \"\\tx) exit\\n\\n\";\n" . X "\n\tprint \" Select an option" . $selectopt . X ": \";\n\n\t" . X '($ans = substr(,0,1)) =~ y/A-Z/a-z/;' . X "\n\t" . 'exit(0) if $ans eq "x" || $ans eq ""' . X $defaultact . ';' . X "\n" . $selectactions . "\n" . X "\tnext LOOP;\n }\n"; X $option_strings = $selectactions = X $selectopt = $defaultact = ''; X $optionchar = 'a'; X Xlast switch; X} } Xif ($yyn == 6) { X{ X $option_strings .= "\tprint \"\\t$optionchar) " . X $yyvs[$yyvsp-1] . "\\n\";\n"; X $selectactions .= "\tif (\$ans eq '$optionchar') { " . X $yyvs[$yyvsp-0] . " }\n"; X ++$optionchar; X Xlast switch; X} } Xif ($yyn == 7) { X{ X $option_strings .= "\tprint \"\\t$optionchar) " . $yyvs[$yyvsp-1] . X "\\n\";\n"; X $selectactions .= X "\tif (\$ans eq '$optionchar' || \$ans eq \"\\n\") { " . X $yyvs[$yyvsp-0] . " }\n"; X $selectopt = "[$optionchar]"; X ++$optionchar; X Xlast switch; X} } Xif ($yyn == 8) { X{ X $option_strings .= "\tprint \"\\t$optionchar) " . X $yyvs[$yyvsp-1] . "\\n\" if \$" . $yyvs[$yyvsp-2] . ";\n"; X $selectactions .= "\tif (\$" . $yyvs[$yyvsp-2] . X " && \$ans eq '$optionchar') { " . $yyvs[$yyvsp-0] . " }\n"; X ++$optionchar; X Xlast switch; X} } Xif ($yyn == 9) { X{ X push(@called_menus, $yyvs[$yyvsp-0]); X $yyval = "\$NEXTSTATE = \$" . $yyvs[$yyvsp-0] . ";"; X Xlast switch; X} } Xif ($yyn == 10) { X{ $yyval = $yyvs[$yyvsp-0]; Xlast switch; X} } X } # switch X $yyssp -= $yym; X $yystate = $yyss[$yyssp]; X $yyvsp -= $yym; X $yym = $yylhs[$yyn]; X if ($yystate == 0 && $yym == 0) X { X X $yystate = $YYFINAL; X $yyss[++$yyssp] = $YYFINAL; X $yyvs[++$yyvsp] = $yyval; X if ($yychar < 0) X { X if (($yychar = &yylex) < 0) { $yychar = 0; } X X } X return(0) if $yychar == 0; X next yyloop; X } X if (($yyn = $yygindex[$yym]) && ($yyn += $yystate) >= 0 && X $yyn <= $#yycheck && $yycheck[$yyn] == $yystate) X { X $yystate = $yytable[$yyn]; X } else { X $yystate = $yydgoto[$yym]; X } X X $yyss[++$yyssp] = $yystate; X $yyvs[++$yyvsp] = $yyval; X } # yyloop X} # yyparse X X X Xsub main'menu { X ($text) = @_; X @text = split("\n", $text); X $optionchar = 'a'; X $main_loop = ''; X $line = ''; X $option_strings = $selectactions = ''; X $selectopt = $defaultact = ''; X $resultmenu = ''; X $lineno = 0; X X &yyparse; X X foreach $menu (@called_menus) { X &yyerror("menu $menu used but not defined") X unless $menus{$menu}; X } X X $resultmenu = $statedecls . "\n" . X "LOOP: for (\$NEXTSTATE = 1;;) {\n" . X $main_loop . "}\n"; X X $errors ? undefined : $resultmenu; X} X Xsub yyerror { X print @_, " in menu at line $lineno, token: '$yylval'\n"; X ++$errors; X} X Xsub yylex { X TOKEN: for (;;) { X $line =~ s/^[ \t\f\r\v]*//; X print "Line is: '$line'\n" if $yydebug; X if ($line eq '') { X $line = shift(@text); X ++$lineno; X return(0) if !defined $line; X next TOKEN; X } elsif ($line =~ /^#/) { X $line = ''; X next TOKEN; X } elsif ($line =~ /^(['"])/) { X $char = $1; X if ($line =~ s/^$char([^$char]*)$char//) { X ($yylval = $1) =~ s/@/\\@/g; X } else { X &yyerror('unterminated string'); X $yylval = ''; X } X return $STRING; X } elsif ($line =~ s/^(MENU)\b//) { X $yylval = $1; # for errors X return $MENU; X } elsif ($line =~ s/^(END)\b//) { X $yylval = $1; X return $END; X } elsif ($line =~ s/^(IF)\b//) { X $yylval = $1; X return $IF; X } elsif ($line =~ s/^(\w+)//) { X $yylval = $1; X return $NAME; X } elsif ($line =~ s/^(\*)//) { X $yylval = $1; X return $STAR; X } else { X $line =~ s/^(.)//; X $sep = "\\" . $1; X print "Sep is: '$sep'\n" if $yydebug; X until ($line =~ /$sep/) { X $nextline = shift(@text); X ++$lineno; X last TOKEN if !defined $nextline; X $line .= "\xFF" . $nextline; X } X $yylval = $line; X $line =~ s/.*$sep//; X $yylval =~ s/$sep.*//; X $yylval =~ s/\xFF/\n/g; X print "Collected: $yylval" if $yydebug; X return $PERL; X } X } X} X X1; END_OF_FILE if test 8158 -ne `wc -c <'menu2.pl'`; then echo shar: \"'menu2.pl'\" unpacked with wrong size! fi # end of 'menu2.pl' fi if test -f 'testmenu' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'testmenu'\" else echo shar: Extracting \"'testmenu'\" \(750 characters\) sed "s/^X//" >'testmenu' <<'END_OF_FILE' X#!/usr/local/bin/perl X Xrequire("menu.pl"); X X$wantother = $ARGV[0] eq '-o'; X X$result = &menu(<<'EOMENU'); X X MENU main "Main Menu" X "Sub Menu" MENU sub1 X IF wantother "Other Sub Menu" MENU sub2 X "ls" & X system "ls"; X print "hit return:"; X local($ret); X $ret = ; X & X END X X MENU sub1 "Sub Menu" X "ls" & system "ls"; & X "perl eval" | &evalstr; | X * "Back to main menu" MENU main X END X X MENU sub2 "Other Sub Menu" X "ls" @system "ls";@ X * "Back to main menu" MENU main X END X XEOMENU X Xeval($result) if $result; Xwarn "$@" if $@; X Xsub evalstr { X print "enter a line of perl: "; X eval ; X warn "$@" if $@; X print "hit return: "; X local($ret); X $ret = ; X} END_OF_FILE if test 750 -ne `wc -c <'testmenu'`; then echo shar: \"'testmenu'\" unpacked with wrong size! fi chmod +x 'testmenu' # end of 'testmenu' fi echo shar: End of shell archive. exit 0 =========================================================================== | Bill Hails | | | C.L.I. Connect Ltd. | README: permission denied | | 19, Quarry St., Guildford, Surrey | | | GU1 3UY. Tel (UK) 0483 300 200 | | =========================================================================== .