#!/usr/bin/perl -T package SlicingDemo; use POSIX ":signal_h"; use CGI qw(:standard); $CGI::POST_MAX=32768; # max 32K posts $ENV{PATH}="/bin:/usr/bin:/usr/local/bin"; $query = new CGI; $| = 1; $title = "A Type Error Slicer for MiniML"; $session = unpack("H*", pack("Nn", time, $$)); $submit_label = 'Display any type errors in MiniML code in entry panel'; $submit_example_label = 'Display any type errors in the example selected in the above menu'; sub write_status_page { my %params = @_; my @status = @{$params{-status}}; my $refresh_current = ""; open(INFO, ">tmp/$session.html"); print INFO $query->start_html(-title=> "$title", -head=>[$refresh_current], -dtd=>"-//W3C//DTD HTML 4.01//EN"); print INFO "

$title

"; print INFO @status; print INFO $query->end_html; # This is for IE: print INFO ""; close(INFO); } sub write_final_page { my %params = @_; my @status = @{$params{-status}}; my $refresh_current = ""; open(INFO, ">tmp/$session.html"); print INFO $query->start_html(-title=> "$title", -head=>[$refresh_current], -dtd=>"-//W3C//DTD HTML 4.01//EN"); print INFO "

$title

"; print INFO @status; print INFO $query->end_html; close(INFO); } sub run_type_checking { my %params = @_; # my $input = ${$params{-input}}; # Write a status page before we fork, to prevent race conditions @status = (); write_status_page(-status=>[@status]); # Fork a child to handle the remainder of the session after redirecting $childpid = fork; if($childpid != 0) { $new_url = $query->self_url(); $new_url =~ s/^(.*)\/(.*)$/$1\//; print $query->redirect($new_url."tmp/$session.html"); #waitpid($childpid, 0); exit; } open STDIN, "/dev/null"; # Write the source file push @status, "

Writing source file...

"; write_status_page(-status=>[@status]); open(SOURCE, ">tmp/$session.sml"); print SOURCE $input; close(SOURCE); # Run the type error slicing tool push @status, "

Running the type error slicing tool...

"; write_status_page(-status=>[@status]); my $childpid = fork; if($childpid == 0) { exec("bin/slicer tmp/$session.sml > tmp/$session.out 2> tmp/$session.err"); } else { $timeout = 0; eval { local $SIG{ALRM} = sub { die("timedout"); }; alarm(120); waitpid($childpid, 0); alarm(0); }; if ($@ and $@ =~ /timedout/) { $timeout = 1; kill 9, $childpid; } } if ($timeout) { push @status, "

Timed out, sorry.

"; write_status_page(-status=>[@status]); return 2; } # Formatting the output push @status, "

Formatting the output...

"; write_status_page(-status=>[@status]); system("./bin/post $session >> tmp/".$session.".err"); # Done push @status, "

Success, redirecting you to the results...

"; write_final_page(-status=>[@status]); exit; } if(!$query->param("Action")) { open INPUT, "; close INPUT; open INPUT, "; close INPUT; open INPUT, "; close INPUT; open INPUT, "; close INPUT; open INPUT, "; close INPUT; print $query->header; print $query->start_html(-title=>"$title", -head=>[""], -dtd=>"-//W3C//DTD HTML 4.01//EN", -onLoad=>'examples_init();'); print "

"; print "

$title

"; print "

Welcome user@".$query->remote_host()."!

"; print @intro; print $query->start_multipart_form(-action=>"slicing.cgi"); print "

"; print $query->submit('Action',$submit_label); print " "; print ""; print "
"; print @examples; print ""; print $query->submit('Action',$submit_example_label); print $query->textarea(-name=>'Source', -rows=>25, -cols=>80, -value=>"", -id=>"source"); print $query->endform; print "

"; print @authors; print "

"; print @miniml; print @todo; print $query->end_html; } elsif ($query->param("Action") eq $submit_label) { $input = $query->param("Source"); $input =~ s/\r//g; run_type_checking(); } elsif ($query->param("Action") eq $submit_example_label) { open INPUT, "; close INPUT; my $fn = @examples[$query->param("ExampleId")]; open INPUT, "<$fn"; my @input = ; close INPUT; $input = join("",@input); run_type_checking(); } else { print $query->header; print $query->start_html(-title=>'$title', -head=>[""], -dtd=>"-//W3C//DTD HTML 4.01//EN"); print "

Error

"; print "

Invalid request.

"; print $query->end_html; }