tools/dev/parrot_shell.pl

   1 #! perl
   2 # Copyright (C) 2009, Parrot Foundation.
   3 # $Id$
   4
   5 use 5.008;
   6 use strict;
   7 use warnings;
   8 use FindBin qw($Bin);
   9 use lib "$Bin/../lib";    # install location
  10 use lib "$Bin/../../lib"; # build location
  11 use IO::File ();
  12 use File::Spec;
  13 use Parrot::Config;
  14 use File::Temp qw/ tempfile /;
  15 use Benchmark qw/timeit timestr :hireswallclock/;
  16
  17 =head1 NAME
  18
  19 tools/dev/parrot_shell.pl - The Parrot Shell
  20
  21 =head1 SYNOPSIS
  22
  23     % perl tools/dev/parrot_shell.pl
  24
  25 =head1 DESCRIPTION
  26
  27 The Parrot Shell allows you to rapidly prototype Parrot code. It wraps your code
  28 in a ".sub main" and ".end", so you don't have to, unless your code begins with
  29 ".sub". It reads code from STDIN until it sees a line containing a single ".",
  30 which is how you tell parrot_shell to run the code you are giving to it:
  31
  32 Example:
  33     parrot_shell 0> $I0 = 42
  34     $N1 = sqrt $I0
  35     say $N1
  36     .
  37     Output:
  38     6.48074069840786
  39
  40     parrot_shell 1> quit
  41     Thanks for visiting the Parrot Shell, come back soon!
  42
  43 Each numbered Parrot Shell session is run in its own interpreter, so no registers
  44 or variables are shared/leaked between them.
  45
  46 =cut
  47
  48 my $parrot;
  49 my $session_no = 0;
  50
  51 BEGIN {
  52     $parrot = File::Spec->catfile( ".", "parrot");
  53     unless (-e $parrot) {
  54         warn "$parrot not found, attempting to use an installed parrot";
  55         $parrot = 'parrot';
  56     }
  57     my $exefile = $parrot . $PConfig{exe};
  58 }
  59
  60 show_welcome();
  61
  62 while(1) {
  63     my $code;
  64     show_prompt($session_no);
  65
  66     while( my $line = <STDIN> ) {
  67         exit_shell() if $line =~ m/^q(uit)?$/;
  68
  69         if ($line =~ m/^h(elp)?$/) {
  70             show_help();
  71             show_prompt($session_no) if !defined $code;
  72             next;
  73         }
  74         if ($line =~ m/^\s*\.\s*$/) { # Run it, baby!
  75             print eval_snippet($code);
  76             last;
  77         }
  78         else {
  79             $code .= $line;
  80         }
  81     }
  82
  83     $session_no++;
  84 }
  85
  86 sub show_welcome {
  87     print <<BIENVENIDO;
  88 Welcome to the Parrot Shell, it's experimental!
  89 Type h or help for some basic help
  90 Type q or quit to flee the madness
  91 BIENVENIDO
  92
  93 }
  94
  95 sub show_prompt {
  96     my ($session_no) = @_;
  97     print "\nparrot_shell $session_no> ";
  98 }
  99 sub exit_shell {
 100     print "Thanks for visiting the Parrot Shell, come back soon!\n";
 101     exit 0;
 102 }
 103
 104 sub show_help {
 105     print <<'EX';
 106
 107 The Parrot Shell allows you to rapidly prototype Parrot code. It wraps your code
 108 in a ".sub main" and ".end", so you don't have to, unless your code begins with
 109 ".sub". It reads code from STDIN until it sees a line containing a single ".",
 110 which is how you tell parrot_shell to run the code you are giving to it:
 111
 112 Example:
 113     parrot_shell> $I0 = 42
 114     $N1 = sqrt $I0
 115     say $N1
 116     .
 117     Output:
 118     6.48074069840786
 119 EX
 120 }
 121
 122 sub eval_snippet {
 123     my ($snippet) = @_;
 124     my $codefn   = get_tempfile();
 125     my $stdoutfn = get_tempfile();
 126     my $f        = IO::File->new(">$codefn");
 127
 128     $f->print(normalize_snippet($snippet || ''));
 129     $f->close();
 130
 131     my $time = timestr(timeit(1, sub { system("$parrot $codefn >$stdoutfn 2>&1") } ));
 132     $time =~ s/\(.*//g;
 133
 134     handle_errors($?) if $?;
 135
 136     $f = IO::File->new($stdoutfn);
 137
 138     my $output = join( '', <$f> );
 139     return "Time: $time\nOutput:\n$output";
 140 }
 141
 142 sub handle_errors {
 143     my ($exit_code) = @_;
 144     if ($exit_code == -1) {
 145         print "Error: failed to execute: $!\n";
 146     }
 147     elsif ($exit_code & 127) {
 148         printf "Error: child died with signal %d, %s coredump\n",
 149             ($exit_code & 127),  ($exit_code & 128) ? 'with' : 'without';
 150     }
 151     else {
 152         printf "Error: child exited with value %d\n", $? >> 8;
 153     }
 154 }
 155
 156 sub get_tempfile {
 157     my (undef, $name)   = tempfile( CLEANUP => 1);
 158     return $name;
 159 }
 160
 161 sub normalize_snippet {
 162     my ($snippet) = @_;
 163
 164     if ($snippet =~ m/^\.sub/) {
 165         # don't wrap snippet
 166         return $snippet;
 167     }
 168     else {
 169         return <<SNIP;
 170 .sub main :main
 171 $snippet
 172 .end
 173 SNIP
 174     }
 175 }
 176
 177 # Local Variables:
 178 #   mode: cperl
 179 #   cperl-indent-level: 4
 180 #   fill-column: 100
 181 # End:
 182 # vim: expandtab shiftwidth=4: