| 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 $@;
}
#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;
}
}
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_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 send_http_header
{ # FIX LATER
;
}
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_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.
|