1: #!/usr/bin/perl
   2: #  yapsh - Yet Another Perl Shell
   3: #  Copyright (C) 2001 Drake Wilson
   4: #  This program is free software; you can redistribute it and/or
   5: #  modify it under the terms of the GNU General Public License
   6: #  as published by the Free Software Foundation; either version 2
   7: #  of the License, or (at your option) any later version.
   8: #  
   9: #  This program is distributed in the hope that it will be useful,
  10: #  but WITHOUT ANY WARRANTY; without even the implied warranty of
  11: #  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12: #  GNU General Public License for more details.
  13: #  
  14: #  If you wish to receive a copy of the GNU General Public License, write to the Free Software
  15: #  Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA, or see
  16: #  <http://www.gnu.org/copyleft/gpl.html>.
  17: #  
  18: #  You can contact me by e-mail at drake@libcom.com.
  19: 
  20: use strict 'subs';
  21: use Term::ReadLine;
  22: use Shell;
  23: my (@brackets, %special, $nprompt, $bprompt, $reader, $command, $toe);
  24: @brackets = (%special = ());
  25: $nprompt="& ";
  26: $bprompt=". ";
  27: $reader=new Term::ReadLine 'perl shell';
  28: 
  29: print "This is yapsh v1.0.  See source for license...\n\n";
  30: 
  31: {
  32:     print $nprompt;
  33:     last unless (defined($_ = $reader->readline()));
  34:     $command="";
  35:     do
  36:     {
  37: 	{
  38: 	    my ($foo,$qux);
  39: 	    foreach $foo (keys %special)
  40: 	    {
  41: 		if ($_ eq $foo)
  42: 		{
  43: 		    $qux = $special{$foo};
  44: 		    &$qux();
  45: 		}
  46: 	    }
  47: 	}
  48: 	$_ = scalar reverse $_;
  49: 	{
  50: 	    my $ch;
  51: 	    while ($ch = chop $_)
  52: 	    {
  53: 		$command .= $ch;
  54: 		foreach ('{','(','[')
  55: 		{
  56: 		    push @brackets, $ch if ($ch eq $_);
  57: 		}
  58: 		foreach ('}',')',']')
  59: 		{
  60: 		    if ($ch eq $_)
  61: 		    {
  62: 			$ch = '[' if ($ch eq ']'); 
  63: 			$ch = '(' if ($ch eq ')');
  64: 			$ch = '{' if ($ch eq '}');
  65: 			warn "Mismatched parentheses.\n" unless ($ch eq pop @brackets);
  66: 		    }
  67: 		}
  68: 	    }
  69: 	}
  70: 	if (@brackets)
  71: 	{
  72: 	    $command .= " ";
  73: 	    print $bprompt;
  74: 	    $_ = $reader->readline();
  75: 	}
  76:     } while (@brackets);
  77:     eval ($command);
  78:     warn "$@\n" if ($@);
  79:     redo;
  80: }
  81: __END__
  82: 
  83: =head1 yapsh - Yet Another Perl Shell
  84: 
  85: As the title implies, this is -- yet another Perl Shell.  Any
  86: text typed in will be interpreted as Perl and executed immediately,
  87: unless there are unmatched open brackets, in which case a different
  88: prompt will be displayed to allow the user to continue until the
  89: bracket becomes matched.
  90: 
  91: See the Shell.pm documentation for more information.
  92: 
  93: =head1 COPYRIGHT
  94: 
  95: Copyright (C) 2001 Drake Wilson, drake@libcom.com.