| a7c784 | 2000-08-01 | Leif Stensson | | #! /usr/local/bin/perl
# Perl helper script for Roxen Webserver. By Leif Stensson.
#
|
| 9591de | 2001-04-18 | Leif Stensson | | # $Id: perlhelper,v 1.5 2001/04/18 12:16:42 leif Exp $
|
| a7c784 | 2000-08-01 | Leif Stensson | |
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 $@;
}
|
| d2b8c8 | 2001-02-01 | Leif Stensson | | # Extra debugging.
# if (-x "/home/leif/bin/pike7r90" )
# {
# # Extra diagnostics.
# print STDERR "Started subperl.\n";
# };
|
| a7c784 | 2000-08-01 | Leif Stensson | |
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;
}
}
|
| ccc16b | 2001-03-13 | Leif Stensson | | sub PRINTF
{ my $self = shift;
Roxen::TieStdio::PRINT($self, CORE::sprintf($_[0], @_[1..$#_]));
}
|
| a7c784 | 2000-08-01 | Leif Stensson | | 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;
}
|
| d2b8c8 | 2001-02-01 | Leif Stensson | | sub get_http_variables () { return %Roxen::Request::req_vars;}
sub get_http_headers () { return %Roxen::Request::req_headers;}
|
| a7c784 | 2000-08-01 | Leif Stensson | | 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, @_);
}
|
| d2b8c8 | 2001-02-01 | Leif Stensson | | 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");
}
|
| a7c784 | 2000-08-01 | Leif Stensson | | 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 ($infd, $outfd) = (-1, -1);
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($infd, "r") or die "Unable to open command input.\n";
$cmdout->fdopen($outfd, "w") or die "Unable to open command output.\n";
$cmdout->autoflush(1);
$Roxen::Request::req_req = Roxen::Request->new();
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;}
if ($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);
|
| d2b8c8 | 2001-02-01 | Leif Stensson | | alarm 180; # 3 minutes.
|
| a7c784 | 2000-08-01 | Leif Stensson | | $Roxen::Request::req_state = 5423522; # Magic number.
|
| 9591de | 2001-04-18 | Leif Stensson | | $ENV{GATEWAY_INTERFACE} = "CGI-PerlEx"; # Makes CGI.pm happier.
|
| a7c784 | 2000-08-01 | Leif Stensson | | if ($cmd eq "C")
{ my ($cmdin, $cmdout, $cmd);
eval $data;
|
| 14f9a2 | 2001-02-04 | Leif Stensson | | if ($@)
{ Senderror("PERL EVAL ERROR: $@");
die "Perl: $@";
}
|
| a7c784 | 2000-08-01 | Leif Stensson | | }
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+300 < time; # Timeout after 5 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")
|
| d2b8c8 | 2001-02-01 | Leif Stensson | | { Sendreply(""); }
elsif ($cmd eq "V")
|
| 9591de | 2001-04-18 | Leif Stensson | | { Sendreply('Roxen Perl Helper: $Id: perlhelper,v 1.5 2001/04/18 12:16:42 leif Exp $'); }
|
| a7c784 | 2000-08-01 | Leif Stensson | | else
|
| d2b8c8 | 2001-02-01 | Leif Stensson | | { die "perlhelper $$/MLQQ: exiting.\n"; }
|
| a7c784 | 2000-08-01 | Leif Stensson | | }
}
# die "$$ perlhelper: exiting normally.\n";
CORE::exit(0);
}
|