#! /usr/local/bin/perl |
|
# Perl helper script for Roxen Webserver. By Leif Stensson. |
# |
# $Id: perlhelper,v 1.7 2003/09/16 17:48:31 mast Exp $ |
|
package Roxen::Internal; |
|
use strict; |
use vars '%Cache'; |
|
sub packagename |
{ my($string) = @_; |
|
$string =~ s/([^A-Za-z0-9\/])/sprintf("_%2x",unpack("C",$1))/eg; |
$string =~ s|/(\d)|sprintf("/_%2x",unpack("C",$1))|eg; |
$string =~ s|/|::|g; |
$string = "::$string" if not $string =~ /^::/; |
|
return "Roxen::SCRIPTCACHE" . $string; |
} |
|
sub runscript |
{ my ($filename) = @_; |
my ($package) = (packagename($filename)); |
my ($mtime) = (-M $filename); |
|
die "No such file: $filename" if not -f $filename; |
|
$Roxen::Internal::script_name = $filename; |
|
if(defined $Cache{$package}{mtime} && $Cache{$package}{mtime} <= $mtime) |
{ $Roxen::Internal::script_was_cached = 1; |
} |
else |
{ $Roxen::Internal::script_was_cached = 0; |
local *FH; |
open FH, $filename or die "open '$filename' $!"; |
local($/) = undef; |
my ($sub) = (<FH>); |
close FH; |
|
my ($eval) = (qq{package $package; sub handler { $sub; }}); |
{ |
my($filename,$mtime,$package,$sub); |
eval $eval; |
} |
die $@ if $@; |
} |
|
eval {$package->handler;}; |
die $@ if $@; |
} |
|
# Extra debugging. |
# if (-x "/home/leif/bin/pike7r90" ) |
# { |
# # Extra diagnostics. |
# print STDERR "Started subperl.\n"; |
# }; |
|
package Roxen::TieStdio; |
|
sub TIEHANDLE |
{ my $obj = {}; |
bless \$obj, shift; |
} |
|
sub PRINT |
{ my $len; |
shift; |
$Roxen::Request::req_outbuf .= join('', @_); |
$len = length($Roxen::Request::req_outbuf); |
if ($len > 500) |
{ # Drain the output buffer a bit. |
$len = 16384 if $len > 16384; |
Roxen::_helper::Senditem('+', |
substr($Roxen::Request::req_outbuf, 0, $len)); |
$Roxen::Request::req_outbuf = |
substr $Roxen::Request::req_outbuf, $len; |
} |
} |
|
sub PRINTF |
{ my $self = shift; |
Roxen::TieStdio::PRINT($self, CORE::sprintf($_[0], @_[1..$#_])); |
} |
|
package Apache; # Some compatilibity with the Apache interface. |
|
sub request |
{ return $Roxen::Request::req_req; |
} |
sub unescape_url |
{ my ($s) = (shift); |
$s =~ s/%([0-9a-fA-F][0-9a-fA-F])/chr(hex($1))/eg; |
return $s; |
} |
sub unescape_url_info |
{ my ($s) = (shift); |
$s =~ s/\+/ /g; |
$s =~ s/%([0-9a-fA-F][0-9a-fA-F])/chr(hex($1))/eg; |
return $s; |
} |
sub perl_hook |
{ return 0; |
} |
|
package Apache::Registry; |
|
sub __foo |
{ return 0; |
}; |
|
package Roxen; |
|
sub request |
{ return $Roxen::Request::req_req; |
} |
sub unescape_url |
{ my ($s) = (shift); |
$s =~ s/%([0-9a-fA-F][0-9a-fA-F])/chr(hex($1))/eg; |
return $s; |
} |
sub unescape_url_info |
{ my ($s) = (shift); |
$s =~ s/\+/ /g; |
$s =~ s/%([0-9a-fA-F][0-9a-fA-F])/chr(hex($1))/eg; |
return $s; |
} |
|
package Roxen::Request; |
|
sub new |
{ my $proto = shift; |
my $class = ref($proto) || $proto; |
my $self = {}; |
bless $self, $class; |
return $self; |
} |
|
sub get_http_variables () { return %Roxen::Request::req_vars;} |
sub get_http_headers () { return %Roxen::Request::req_headers;} |
|
sub get_remote_host { return $Roxen::Request::req_info{'remoteaddr'};} |
sub get_remote_logname { return undef;} |
sub protocol { return $Roxen::Request::req_info{'prot'};} |
sub method { return $Roxen::Request::req_info{'method'};} |
sub main { return undef;} |
sub prev { return undef;} |
sub next { return undef;} |
sub last { return $Roxen::Request::req_req;} |
sub is_main { return 1;} |
sub is_initial_request { return 0;} |
sub header_only { return 0;} |
sub uri { return $Roxen::Request::req_info{raw_url};} |
sub filename { return $Roxen::Request::req_info{realfile};} |
sub args |
{ # Should be context sensitive! |
return $Roxen::Request::req_info{query}; |
} |
sub connection { return $Roxen::Request::req_req;} |
sub auth_name |
{ # Realm |
return "Default"; |
} |
sub document_root |
{ # FIX LATER... |
return "/"; |
} |
sub get_basic_auth_pw |
{ if ($Roxen::Request::req_info{auth_type} eq "Basic") |
{ return 0, $Roxen::Request::req_info{auth_passwd};} |
else |
{ return 0;} |
} |
sub note_basic_auth_failure |
{ # IMPROVE LATER. |
$Roxen::Request::req_returncode = 401; |
} |
sub handler |
{ # NOT SUPPORTED. |
die "$$ perlhandler: Arrgh! \$r->handler called!\n"; |
} |
sub notes |
{ # NOT SUPPORTED. |
die "$$ perlhandler: Arrgh! \$r->notes called!\n"; |
} |
sub content_type |
{ $Roxen::Request::req_reply{'Content-Type'} = $_[0] if defined $_[0]; |
return $Roxen::Request::req_reply{'Content-Type'}; |
} |
sub content_encoding |
{ $Roxen::Request::req_reply{'Content-Encoding'} = $_[0] if defined $_[0]; |
return $Roxen::Request::req_reply{'Content-Encoding'}; |
} |
sub content_languages |
{ $Roxen::Request::req_reply{'Content-Languages'} = join(' ', @_) |
if $#_ >= 0; |
return split / /, $Roxen::Request::req_reply{'Content-Languages'}; |
} |
sub status |
{ $Roxen::Request::req_returncode = 0+$_[0] if defined($_[0]); |
return 0+$Roxen::Request::req_returncode; |
} |
sub status_line |
{ $Roxen::Request::req_returncode = $_[0] if defined($_[0]); |
return $Roxen::Request::req_returncode; |
} |
sub print |
{ my ($self, $len) = (shift, 0); |
$Roxen::Request::req_outbuf .= join('', @_); |
$len = length($Roxen::Request::req_outbuf); |
if ($len > 0) |
{ $len = 16384 if $len > 16384; |
Roxen::_helper::Senditem('+',substr($Roxen::Request::req_outbuf, 0, $len)); |
$Roxen::Request::req_outbuf = |
substr($Roxen::Request::req_outbuf, $len); |
} |
} |
sub printf |
{ my ($self, $fmt) = (shift, shift); |
$self->print(sprintf $fmt, @_); |
} |
sub send_http_header |
{ my ($self, $headers) = (shift, ""); |
for(keys %Roxen::Request::req_reply) |
{ $headers .= sprintf("%s: %s\r\n", $_, $Roxen::Request::req_reply{$_});} |
Roxen::_helper::Sendreply("HEADERS=$headers"); |
} |
sub send_fd |
{ my ($self, $fh, $buf) = (shift, shift); |
while (read($fh, $buf, 8192) > 0) { $self->print($buf);} |
} |
sub log_reason |
{ my ($self, $msg, $file) = (shift, shift, shift); |
print STDERR "Perl script: $msg\n"; |
} |
sub log_error |
{ my ($self, $msg) = (shift, shift); |
print STDERR "Perl script error: $msg\n"; |
} |
sub warn |
{ my ($self, $msg) = (shift, shift); |
print STDERR "Perl script warning: $msg\n"; |
} |
sub exit |
{ shift; |
if ($Roxen::Request::req_returncode != 200) |
{ |
Roxen::_helper::Sendreply(sprintf("RETURNCODE=%d", |
$Roxen::Request::req_returncode)); |
} |
Roxen::_helper::Senddata($Roxen::Request::req_outbuf); |
$Roxen::Request::req_outbuf = ""; |
CORE::exit(shift); |
} |
|
# Emulated connection object inside request object: |
|
sub remote_host { return $Roxen::Request::req_info{'remoteaddr'};} |
sub remote_ip { return $Roxen::Request::req_info{'remoteaddr'};} |
sub local_addr { die "Perl: Arrgh! \$r->connection->local_addr\n";} |
sub remote_addr { die "Perl: Arrgh! \$r->connection->remote_addr\n";} |
sub user { return $Roxen::Request::req_info{'auth_user'};} |
# Note: this one exists in both Request and Connection: |
sub auth_type { return $Roxen::Request::req_info{'auth_type'};} |
|
|
package Roxen::_helper; |
|
use IO::Handle; |
|
my ($cmdin ) = (new IO::Handle); |
my ($cmdout) = (new IO::Handle); |
|
# for(; $ARGV[0] =~ /^-/; shift @ARGV) |
# { if ($ARGV[0] =~ /^--cmdsocket=(\d+)$/) |
# { $infd = $1; $outfd = $1;} |
# else |
# { die "Invalid option: $ARGV[0]\n";} |
# } |
|
sub diag |
{ |
# print STDERR join('', @_); |
} |
|
|
sub Getdata($) |
{ my ($bytes, $len, $tmp, @lens) = (shift); |
$cmdin->sysread($tmp, $bytes) == $bytes or die "$$/Getdata: exiting.\n"; |
if ($bytes == 1) |
{ @lens = unpack "C", $tmp; $len = $lens[0];} |
elsif ($bytes == 3) |
{ @lens = unpack "CCC", $tmp; |
$len = $lens[0]*65536 + $lens[1]*256 + $lens[2]; |
} |
else |
{ die "$$/Getdata/B: exiting.\n";} |
$cmdin->sysread($tmp, $len) == $len or die "$$/Getdata/C: exiting.\n"; |
return $tmp; |
} |
|
sub Senditem($$) |
{ my ($key, $data) = (shift, shift); |
$cmdout->syswrite($key . |
pack("CCC", 0, length($data)/256, length($data)&255), 4); |
$cmdout->syswrite($data, length($data)); |
} |
|
sub Senddata($) |
{ my ($data, $hdr) = (shift); |
diag "(", length($data); |
while (length($data) > 16384) |
{ diag "+"; |
Senditem "+", substr($data, 0, 16384); |
$data = substr($data, 16384); |
} |
diag "*)"; |
Senditem "*", $data; |
} |
|
sub Senderror($) |
{ my ($data, $hdr) = (shift); |
$hdr = pack("CCC", 0, length($data)/256, length($data) & 255); |
$cmdout->syswrite("?$hdr", 4); |
$cmdout->syswrite($data, length($data)); |
diag "[WR:4+", length($data), "]"; |
} |
|
sub Sendreply($) |
{ my ($data, $hdr) = (shift); |
$hdr = "=" . pack("CCC", 0, length($data)/256, length($data) & 255); |
$cmdout->syswrite($hdr, 4); |
$cmdout->syswrite($data, length($data)); |
diag "[WR:4+", length($data), "]"; |
} |
|
sub _CatchAlarm |
{ #die "$$ perlhelper: exiting (timeout).\n"; |
CORE::exit(7); |
} |
|
sub _CatchExit |
{ |
if ($Roxen::Request::req_state == 5423522) |
{ # Magic number meaning we were evaluating something. |
if ($Roxen::Request::req_returncode != 200) |
{ Sendreply(sprintf("RETURNCODE=%d", $Roxen::Request::req_returncode));} |
Senddata($Roxen::Request::req_outbuf); |
} |
if (defined($_[0])) { CORE::exit($_[0]);} |
else { CORE::exit(17);} |
die "$$ perlhelper: CORE::exit failed!\n"; |
} |
|
*CORE::GLOBAL::exit = \&_CatchExit; |
|
$SIG{ALRM} = \&_CatchAlarm; |
|
tie(*STDOUT, 'Roxen::TieStdio'); |
|
# Main loop. |
{ my ($cmd, $var, $len, $data) = (); |
my ($starttime, $runcount) = (time, 0); |
|
$cmdin->fdopen(0, "r") or die "Unable to open command input.\n"; |
$cmdout->fdopen(1, "w") or die "Unable to open command output.\n"; |
$cmdout->autoflush(1); |
|
$Roxen::Request::req_req = Roxen::Request->new(); |
|
%Roxen::Request::req_config = ( "timeout" => 180, |
"lifelength" => 300 |
); |
|
while (1) |
{ $Roxen::Request::req_state = 0; |
alarm 60; # One minute. |
$cmdin->sysread($cmd, 1) == 1 or die "perhelper $$/MLR: exiting.\n"; |
diag "[$cmd]"; |
if ($cmd eq "E") |
{ $var = Getdata(1); $data = Getdata(3); |
$ENV{$var} = $data; |
} |
elsif ($cmd eq "I") |
{ $var = Getdata(1); $data = Getdata(3); |
$Roxen::Request::req_info{$var} = $data; |
} |
elsif ($cmd eq "F") |
{ $var = Getdata(1); $data = Getdata(3); |
$Roxen::Request::req_vars{$var} = $data; |
} |
elsif ($cmd eq "H") |
{ $var = Getdata(1); $data = Getdata(3); |
$Roxen::Request::req_headers{$var} = $data; |
} |
elsif ($cmd eq "L") |
{ $var = Getdata(1); $data = Getdata(3); |
if ($var eq "libdir" and $Roxen::Request::req_config{$var} ne $data) |
{ push @INC, $data;} |
elsif ($var eq "cd") |
{ chdir $data;} |
$Roxen::Request::req_config{$var} = $data; |
} |
elsif ($cmd eq "R") |
{ %ENV = (); |
%Roxen::Request::req_info = (); |
%Roxen::Request::req_vars = (); |
%Roxen::Request::req_headers = (); |
} |
elsif ($cmd eq "S" or $cmd eq "C") |
{ $Roxen::Request::req_outbuf = ""; |
$Roxen::Request::req_returncode = 200; |
$data = Getdata(3); |
alarm 180; # 3 minutes. |
if ($Roxen::Request::req_config{timeout} >= 30 and |
$Roxen::Request::req_config{timeout} <= 900) |
{ alarm 0+$Roxen::Request::req_config{timeout};} |
$Roxen::Request::req_state = 5423522; # Magic number. |
$ENV{GATEWAY_INTERFACE} = "CGI-PerlEx"; # Makes CGI.pm happier. |
if ($cmd eq "C") |
{ my ($cmdin, $cmdout, $cmd); |
eval $data; |
if ($@) |
{ Senderror("PERL EVAL ERROR: $@"); |
die "Perl: $@"; |
} |
} |
else |
{ diag "{S:$data}\n"; |
Roxen::Internal::runscript($data); |
} |
$Roxen::Request::req_state = 0; |
alarm 60; # One minute. |
if ($Roxen::Request::req_returncode != 200) |
{ Sendreply(sprintf "RETURNCODE=%d", $Roxen::Request::req_returncode);} |
Senddata($Roxen::Request::req_outbuf); |
|
last if $starttime+$Roxen::Request::req_config{lifelength} < time; |
last if $starttime+1800 < time; # Final timeout after 30 minutes. |
|
$Roxen::Request::req_req = Roxen::Request->new(); |
} |
elsif ($cmd eq "Q") |
{ $cmdin->sysread($cmd, 1) == 1 or die "perlhelper $$/MLQ: exiting.\n"; |
diag "{Q$cmd}"; |
if ($cmd eq "P") |
{ Sendreply(""); } |
elsif ($cmd eq "V") |
{ Sendreply('Roxen Perl Helper: $Id: perlhelper,v 1.7 2003/09/16 17:48:31 mast Exp $'); } |
else |
{ die "perlhelper $$/MLQQ: exiting.\n"; } |
} |
} |
# die "$$ perlhelper: exiting normally.\n"; |
CORE::exit(0); |
} |
|
|
|
|
|