ScriptParserExamples.pl

# AGPLv3, Eric Windisch. GrokThis.net / VPS Village.com
# This is an snippet / extract from a larger application.
# I don't necessarily expect this to work all on its lonesome.

use Locale::TextDomain ('CloudShell');
our $ginterp;
our %interpcache;
my $prompt;

# Execute main subroutine, unless we're being subclassed...
__PACKAGE__->main() unless caller;
exit 0;

{ # Perl Parser
  package CloudShell::ScriptParser::Perl;

  sub new {
    my $class=shift;
    my $self={};
    bless $self, $class;

    # We've gotta be safe!
    use Safe;
    use Safe::Hole;

    # We create a *safe* Perl interpreter
    my $interp=new Safe("Dungeon");
    my $hole = new Safe::Hole {};

    my %cmds;
    delete $lookupTable{'?'};
    foreach my $cmd (keys %lookupTable) {
      $hole->wrap( $lookupTable{$cmd}->{'sub'} , $interp, '&'.$cmd);
    }

    $self->{_interp}=$interp;
    return $self;
  }

  sub parse {
    my $self=shift;
    local *ret=$self->{_interp}->reval(join (' ',@_));
    if (defined $@ && $@ != undef) {
      die $@;
    }
    return *ret;
  }

  sub handle_error {
    print __"Unknown or bad command.\n";
  }
}

{ # TCL Package
  package CloudShell::ScriptParser::TCL;
  sub new {
    my $class=shift;
    my $self={};
    bless $self, 'CloudShell::ScriptParser::TCL'; #$class;
    # We only include this evil beast if we're using it.
    use Tcl;

    # We create a *safe* TCL interpreter

    # Stdout is allowed...
    my $t=Tcl::new();
    my $tcl=$t->CreateSlave('slave',1);
    $t->Eval("interp share {} stdout slave");

    # Init shell
    open(my $TCLinit, "/etc/cloudinf/cloud-admin-shell.init.tcl");
    $tcl->EvalFileHandle($TCLinit);
    close $TCLinit;

    foreach (keys %lookupTable) {
      $tcl->CreateCommand($_,sub {
        my $function=shift;
        my $interp=shift;
        my $function1=shift;
        $lookupTable{$function}->{'sub'} (@_);
      }, $_);
    }

    $tcl->CreateCommand("_uriexec",sub {
      my $function=shift;
      my $interp=shift;
      my $function1=shift;
      $interp->Eval(do_fetch(@_));
    },$_);

    # If we don't save $t to an instance var, then
    # accessing _interp will Segfault.
    $self->{_interp0}=$t;

    # This is what we'll normally use...
    $self->{_interp}=$tcl;
    return $self;
  }

  sub parse {
    my $self=shift;
    my $line=shift;
    return $self->{_interp}->Eval($line);
  }

  sub handle_error {
    my $self=shift;
    my $_=shift;
    s/\s*at \/usr.*//;
    print $_."\n";
  }
}


sub getInterpreter
{
  my %INTERPRETERS=(
    'tcl'=>'CloudShell::ScriptParser::TCL',
    'javascript'=>'CloudShell::ScriptParser::Javascript',
    'ruby'=>'CloudShell::ScriptParser::Ruby',
    'perl'=>'CloudShell::ScriptParser::Perl',
    'simple'=>'CloudShell::ScriptParser::Simple'
  );

  my $shell=shift;
  if (exists $INTERPRETERS{$shell}) {
    # We must use a cache as otherwise, we might 
    # re-initalize a module which can only run once
    # some of our shells are sensitive
    if (exists $interpcache{$shell}) {
      return $interpcache{$shell};
    } else {
      $interpcache{$shell}=eval("$INTERPRETERS{$shell}->new()");
      if ($@) {
        print __"Error building interpreter.";
        print $@;
        return;
      }
      return $interpcache{$shell};
    }
  } else {
    # This should never happen!
    print __x("Unknown interpreter: {shell}\n",shell=>$shell);
    return;
  }
}

sub goInteractive
{
    my ($term) = (@_);

    # Determine which interactive shell to use.
    my $shell;
    eval {
        # This is where we keep our user settings...
        $shell=(tied $INSTANCE)->vm->data->{interactive_shell};
    };
    $shell ||= "perl"; #"tcl";
    # ginterp and prompt are globals...
    $ginterp=getInterpreter($shell);
    $prompt=getPrompt($shell);

    while ( defined( my $line = $term->readline($prompt) ) )
    {   
        # Call the function with any arguments we might have.
        eval {
          $ginterp->parse($line);
        };
        if ($@) {
            print Dumper $@;
            print $ginterp->handle_error($@);
            print __"\nType 'help' for help.\n";
        }
    }
    #
    #  Save history on exit.
    #
    do_exit();
}

sub main {
  my $term = new Term::ReadLine 'cloud-admin-shell';
  goInteractive($term);
}