Changeset 14366 for misc/runpugs
- Timestamp:
- 10/17/06 08:26:33 (2 years ago)
- svk:copy_cache_prev:
- 21206
- Location:
- misc/runpugs
- Files:
-
- 12 added
- 6 modified
-
bin/termdispatcher2.pl (added)
-
bin/termserv2.pl (added)
-
cgi-bin/runpugs (modified) (2 diffs)
-
data/runpugs.html (modified) (2 diffs)
-
htdocs/index.html (modified) (4 diffs)
-
lib/Web (added)
-
lib/Web/Terminal (added)
-
lib/Web/Terminal/Config.pm (added)
-
lib/Web/Terminal/Dispatcher.pm (added)
-
lib/Web/Terminal/Msg.pm (added)
-
lib/Web/Terminal/Server (added)
-
lib/Web/Terminal/Server.pm (added)
-
lib/Web/Terminal/Server/Session.pm (added)
-
lib/Web/Terminal/Server/Terminal.pm (added)
-
lib/Web/Terminal/Settings.pm (added)
-
lib/WebTerminal/Dispatcher.pm (modified) (1 diff)
-
lib/WebTerminal/Server.pm (modified) (2 diffs)
-
lib/WebTerminal/Server/Terminal.pm (modified) (2 diffs)
Legend:
- Unmodified
- Added
- Removed
-
misc/runpugs/cgi-bin/runpugs
r14271 r14366 58 58 my $ip=$ENV{'REMOTE_ADDR'}; 59 59 #my $ip="127.0.0.".int(rand(100)); 60 60 #if ($ip eq '86.0.200.34') { 61 #$ip='127.'.int(rand(100)).'.'.int(rand(100)).'.'.int(rand(100)); 62 #} 61 63 ######### MAIN SITEMANAGER PROGRAM ################### 62 64 … … 122 124 ################### PRINTHTTPHEADER ####################### 123 125 sub printhttpheader { 124 my $cookie;126 # my $cookie; 125 127 unless ($headerprinted) { 126 128 127 if ($sessionid) {128 $cookie = $query->cookie( -name => 'sessionid',129 -"value" => $sessionid,130 -path => '/' );131 }129 # if ($sessionid) { 130 # $cookie = $query->cookie( -name => 'sessionid', 131 # -"value" => $sessionid, 132 # -path => '/' ); 133 # } 132 134 133 135 $headerprinted=1; 134 136 135 if ($sessionid) {136 print $query->header(-pragma=>'no-cache',137 -cookie=>$cookie,138 -charset=>$lang_charset,139 );140 } else {137 # if ($sessionid) { 138 # print $query->header(-pragma=>'no-cache', 139 # -cookie=>$cookie, 140 # -charset=>$lang_charset, 141 # ); 142 # } else { 141 143 print $query->header(-pragma=>'no-cache', 142 144 -charset=>$lang_charset, 143 145 ); 144 }146 # } 145 147 } 146 148 } -
misc/runpugs/data/runpugs.html
r14299 r14366 4 4 <meta http-equiv="Content-Type" content="text/html; charset=utf-8"> 5 5 6 <title>Run Perl 6 Now!</title>6 <title>Run Perl 6 Now -- in your browser!</title> 7 7 <link rel="stylesheet" type="text/css" href="/runpugs.css"> 8 8 <script language="JavaScript"> … … 26 26 <body> 27 27 <div id="mainwindow"> 28 <h1>Run Perl 6 now -- in your browser!</h1>28 <h1>Run Perl 6 now -- in your browser!</h1> 29 29 <p>This live web terminal runs the latest developement snapshot of 30 30 the <a href="http://www.pugscode.org">pugs</a> interpreter for <a 31 href="http://dev.perl.org/perl 6/">Perl6</a>. For more information, read<a32 href="http://feather.perl6.nl/~andara/runpugs/"> this</a>.31 href="http://dev.perl.org/perl 6/">Perl 6</a>. For more details, read the <a 32 href="http://feather.perl6.nl/~andara/runpugs/">info page</a>. 33 33 </p> 34 34 <form style="text-align: center" id="term" name="terminal" action="/cgi-bin/runpugs" method="POST"> -
misc/runpugs/htdocs/index.html
r14299 r14366 3 3 <head> 4 4 <meta http-equiv="Content-Type" content="text/html; charset=utf-8"> 5 <title>Run Perl 6 Now -- in your browser!</title>5 <title>Run Perl 6 Now -- in your browser!</title> 6 6 <link rel="stylesheet" type="text/css" href="runpugs.css"> 7 7 </head> … … 9 9 10 10 <div id="mainwindow"> 11 <h1>Run Perl 6 now -- in your browser!</h1>11 <h1>Run Perl 6 now -- in your browser!</h1> 12 12 13 <p>Welcome to <tt>runpugs</tt>, a web terminal for <a href="http://www.pugscode.org">pugs</a>. Pugs is an implementation of <a href="http://dev.perl.org/perl6/">Perl 6</a> which aims to implement the full Perl6 specification.</p>13 <p>Welcome to <tt>runpugs</tt>, a web terminal for <a href="http://www.pugscode.org">pugs</a>. Pugs is an implementation of <a href="http://dev.perl.org/perl6/">Perl 6</a> which aims to implement the full Perl 6 specification.</p> 14 14 <p><tt>runpugs</tt> currently lives <a 15 15 href="http://feather.perl6.nl:8080/cgi-bin/runpugs">here</a>.</p> … … 21 21 22 22 <ul> 23 <li> Pugsruns in <em>safe mode</em>, so system-related calls (including <code>say()</code>!) are disabled.</li>23 <li><The code>pugs</code> shell runs in <em>safe mode</em>, so system-related calls (including <code>say()</code>!) are disabled.</li> 24 24 <li>If a call takes too long, the <code>pugs</code> session will time out.</li> 25 25 <li>If left idle for too long, the <code>pugs</code> session will time out.</li> … … 41 41 <li>There is no command history.</li> 42 42 </ul> 43 <p>You can find the source code for <tt>runpugs</tt> (in Perl 5) in the <a href="http://svn.openfoundry.org/pugs/">pugs subversion repository</a> under <code>/misc/runpugs</code>.43 <p>You can find the source code for <tt>runpugs</tt> (in Perl 5) in the <a href="http://svn.openfoundry.org/pugs/">pugs subversion repository</a> under <code>/misc/runpugs</code>. 44 44 <p>Thank you for trying <tt>pugs</tt> and <tt>runpugs</tt>!</p> 45 45 <p class="copyright">© Copyright 2006 by Wim Vanderbauwhede</p> -
misc/runpugs/lib/WebTerminal/Dispatcher.pm
r14233 r14366 61 61 $conn->disconnect(); 62 62 if ( "$id" ne "$rid" ) { 63 die "Terminal server returned wrong id: $rid, should be $id"; 63 # die "Terminal server returned wrong id: $rid, should be $id"; 64 return "Sorry, the pugs session died."; 64 65 } 65 66 return $reply; -
misc/runpugs/lib/WebTerminal/Server.pm
r14299 r14366 30 30 31 31 our %terminals=(); 32 our %lastcalled=();33 32 our %sessions_per_ip=(); 34 33 35 34 sub termhandler { 36 35 my $id = shift; 37 my $ip =shift;36 my $ip = shift; 38 37 my $cmd = shift; 39 if(scalar(keys %lastcalled)>50){ # each pugs takes 1% of feather's MEM! 40 return "Sorry, I can't run any more sessions.\nPlease try again later."; 41 } else { 42 $lastcalled{$id}=time; 43 if ( exists $terminals{$id} ) { 44 my $term = $terminals{$id}; 45 my $lines = $term->write($cmd); 46 if ( $cmd eq ':q' ) { 47 delete $terminals{$id}; 48 delete $lastcalled{$id}; 49 $sessions_per_ip{$ip}--; 50 } 51 if ($lines=~/Aborted/s) { 52 delete $terminals{$id}; 53 delete $lastcalled{$id}; 54 $sessions_per_ip{$ip}--; 55 } 56 return $lines; 57 } else { 58 if ($sessions_per_ip{$ip}>10) { 59 return "Sorry, you can't run more than 10 sessions from one IP 60 address.\n"; 61 } else { 62 $sessions_per_ip{$ip}++; 63 $terminals{$id} = new WebTerminal::Server::Terminal(); 64 my $term = $terminals{$id}; 65 return $term->{'init'}; 66 } 67 } 68 } 38 if(scalar(keys %terminals)>50){ # each pugs takes 1% of feather's MEM! 39 return "Sorry, I can't run any more sessions.\nPlease try again later."; 40 } else { 41 if ( exists $terminals{$id} ) { 42 $terminals{$id}->{called}=time; 43 my $term = $terminals{$id}; 44 my $lines = $term->write($cmd); 45 if ( $cmd eq ':q' ) { 46 delete $terminals{$id}; 47 $sessions_per_ip{$ip}--; 48 } 49 if ($lines=~/Aborted/s) { 50 delete $terminals{$id}; 51 $sessions_per_ip{$ip}--; 52 } 53 return $lines; 54 } else { 55 if ($sessions_per_ip{$ip}>10) { 56 return "Sorry, you can't run more than 10 sessions from one IP address.\n"; 57 } else { 58 $sessions_per_ip{$ip}++; 59 $terminals{$id} = new WebTerminal::Server::Terminal(); 60 $terminals{$id}->{called}=time; 61 $terminals{$id}->{ip}=$ip; 62 my $term = $terminals{$id}; 63 return $term->{'init'}; 64 } 65 } 66 } 69 67 } 70 68 … … 90 88 91 89 sub run { 92 my $host=shift;93 my $port=shift;94 $SIG{USR1}=\&timeout;95 Proc::Daemon::Init;96 # fork/exec by the book:97 use Errno qw(EAGAIN);98 my $pid;99 FORK: {100 if ($pid=fork) {101 #parent here102 WebTerminal::Msg->new_server( $host, $port, \&login_proc );103 WebTerminal::Msg->event_loop();104 } elsif (defined $pid) {105 # child here106 while (getppid()>10) { # a bit ad-hoc.107 sleep 300;108 #print getppid(),"\n";109 kill 'USR1',getppid();110 }111 } elsif ($! == EAGAIN) {112 sleep 5;113 redo FORK;114 } else {115 die "Can't fork: $!\n";116 }117 } # FORK90 my $host=shift; 91 my $port=shift; 92 $SIG{USR1}=\&timeout; 93 Proc::Daemon::Init; 94 # fork/exec by the book: 95 use Errno qw(EAGAIN); 96 my $pid; 97 FORK: { 98 if ($pid=fork) { 99 #parent here 100 WebTerminal::Msg->new_server( $host, $port, \&login_proc ); 101 WebTerminal::Msg->event_loop(); 102 } elsif (defined $pid) { 103 # child here 104 while (getppid()>10) { # a bit ad-hoc. 105 sleep 300; 106 #print getppid(),"\n"; 107 kill 'USR1',getppid(); 108 } 109 } elsif ($! == EAGAIN) { 110 sleep 5; 111 redo FORK; 112 } else { 113 die "Can't fork: $!\n"; 114 } 115 } # FORK 118 116 } 119 117 120 118 sub timeout() { 121 119 my $now=time(); 122 for my $id (keys % lastcalled) {123 my $then=$ lastcalled{$id};120 for my $id (keys %terminals) { 121 my $then=$terminals{$id}->{called}; 124 122 if ($now-$then>600) { 125 123 if(exists $terminals{$id}) { 124 my $ip=$terminals{$id}->{ip}; 125 $sessions_per_ip{$ip}--; 126 126 $terminals{$id}->write(':q'); 127 127 delete $terminals{$id}; 128 }129 if (exists $lastcalled{$id}) {130 delete $lastcalled{$id};131 128 } 132 129 } -
misc/runpugs/lib/WebTerminal/Server/Terminal.pm
r14266 r14366 15 15 my $class = ref($invocant) || $invocant; 16 16 my $self = {@_}; 17 my $prompt = '/\>\ /'; 17 #my $prompt = '/\>\ /'; 18 my $prompt = '/>\ /'; 18 19 ## Start pugs 19 20 # $ENV{PUGS_SAFEMODE}=1;# Must be in CGI script! … … 24 25 $self->{'pugs'} = new Net::Telnet( 25 26 -fhopen => $self->{'pty'}, 27 -timeout => 20, 26 28 -prompt => $prompt, 27 29 -telnetmode => 0,
