a7c7842000-08-01Leif Stensson #! /usr/local/bin/perl # Perl helper script for Roxen Webserver. By Leif Stensson. #
2396182001-04-18Leif Stensson # $Id: perlhelper,v 1.5 2001/04/18 12:18:05 leif Exp $
a7c7842000-08-01Leif 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; }
42bcac2001-02-01Leif Stensson sub get_http_variables () { return %Roxen::Request::req_vars;} sub get_http_headers () { return %Roxen::Request::req_headers;}
a7c7842000-08-01Leif 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 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.
89bb1f2000-12-18Leif Stensson  $cmdin->sysread($cmd, 1) == 1 or die "perlhelper $$/MLR: exiting.\n";
a7c7842000-08-01Leif Stensson  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); alarm 150; # 2.5 minutes. $Roxen::Request::req_state = 5423522; # Magic number.
2396182001-04-18Leif Stensson  $ENV{GATEWAY_INTERFACE} = "CGI-PerlEx"; # Makes CGI.pm happier.
a7c7842000-08-01Leif Stensson  if ($cmd eq "C") { my ($cmdin, $cmdout, $cmd); eval $data;
97d2b42001-02-04Leif Stensson  if ($@) { Senderror("PERL EVAL ERROR: $@"); die "Perl: $@"; }
a7c7842000-08-01Leif 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") { Sendreply(""); } else { die "perlhelper $$/MLQQ: exiting.\n"; } } } # die "$$ perlhelper: exiting normally.\n"; CORE::exit(0); }