#! /usr/local/bin/perl

# Perl helper script for Caudium Webserver.
# Written By Leif Stensson for the Roxen Webserver
#
# $Id: perlhelper,v 1.2.2.2 2002/12/17 13:08:19 kiwi Exp $

package Caudium::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 "Caudium::SCRIPTCACHE" . $string;
}
 
sub runscript
{ my ($filename) = @_;
  my ($package)  = (packagename($filename));
  my ($mtime)    = (-M $filename);

  die "No such file: $filename" if not -f $filename;

  $Caudium::Internal::script_name = $filename;

  if(defined $Cache{$package}{mtime} && $Cache{$package}{mtime} <= $mtime) 
  { $Caudium::Internal::script_was_cached = 1;
  }
  else
  { $Caudium::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 Caudium::TieStdio;

sub TIEHANDLE
{ my $obj = {};
  bless \$obj, shift;
}

sub PRINT
{ my $len;
  shift;
  $Caudium::Request::req_outbuf .= join('', @_);
  $len = length($Caudium::Request::req_outbuf);
  if ($len > 500)
  { # Drain the output buffer a bit.
    $len = 16384 if $len > 16384;
    Caudium::_helper::Senditem('+',
                       substr($Caudium::Request::req_outbuf, 0, $len));
    $Caudium::Request::req_outbuf =
       substr $Caudium::Request::req_outbuf, $len;
  }
}

package Apache; # Some compatilibity with the Apache interface.

sub request
{ return $Caudium::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; # Some compatilibity with Roxen

sub request
{ return $Caudium::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 Caudium;

sub request
{ return $Caudium::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 Caudium::Request;

sub new
{ my $proto = shift;
  my $class = ref($proto) || $proto;
  my $self  = {};
  bless $self, $class;
  return $self;
}

sub get_remote_host { return $Caudium::Request::req_info{'remoteaddr'};}
sub get_remote_logname { return undef;}
sub protocol { return $Caudium::Request::req_info{'prot'};}
sub method { return $Caudium::Request::req_info{'method'};}
sub main { return undef;}
sub prev { return undef;}
sub next { return undef;}
sub last { return $Caudium::Request::req_req;}
sub is_main { return 1;}
sub is_initial_request { return 0;}
sub header_only { return 0;}
sub uri { return $Caudium::Request::req_info{raw_url};}
sub filename { return $Caudium::Request::req_info{realfile};}
sub args
{ # Should be context sensitive!
  return $Caudium::Request::req_info{query};
}
sub connection { return $Caudium::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 ($Caudium::Request::req_info{auth_type} eq "Basic")
    { return 0, $Caudium::Request::req_info{auth_passwd};}
  else
    { return 0;}
}
sub note_basic_auth_failure
{ # IMPROVE LATER.
  $Caudium::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
{ $Caudium::Request::req_reply{'Content-Type'} = $_[0] if defined $_[0];
  return $Caudium::Request::req_reply{'Content-Type'};
}
sub content_encoding
{ $Caudium::Request::req_reply{'Content-Encoding'} = $_[0] if defined $_[0];
  return $Caudium::Request::req_reply{'Content-Encoding'};
}
sub content_languages
{ $Caudium::Request::req_reply{'Content-Languages'} = join(' ', @_)
        if $#_ >= 0;
  return split / /, $Caudium::Request::req_reply{'Content-Languages'};
}
sub status
{ $Caudium::Request::req_returncode = 0+$_[0] if defined($_[0]);
  return 0+$Caudium::Request::req_returncode;
}
sub status_line
{ $Caudium::Request::req_returncode = $_[0] if defined($_[0]);
  return $Caudium::Request::req_returncode;
}
sub print
{ my ($self, $len) = (shift, 0);
  $Caudium::Request::req_outbuf .= join('', @_);
  $len = length($Caudium::Request::req_outbuf);
  if ($len > 0)
  { $len = 16384 if $len > 16384;
    Caudium::_helper::Senditem('+',substr($Caudium::Request::req_outbuf, 0, $len));
    $Caudium::Request::req_outbuf =
      substr($Caudium::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 ($Caudium::Request::req_returncode != 200)
  {
    Caudium::_helper::Sendreply(sprintf("RETURNCODE=%d",
                                      $Caudium::Request::req_returncode));
  }
  Caudium::_helper::Senddata($Caudium::Request::req_outbuf);
  $Caudium::Request::req_outbuf = "";
  CORE::exit(shift);
}

# Emulated connection object inside request object:

 sub remote_host { return $Caudium::Request::req_info{'remoteaddr'};}
 sub remote_ip { return $Caudium::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 $Caudium::Request::req_info{'auth_user'};}
   # Note: this one exists in both Request and Connection:
 sub auth_type { return $Caudium::Request::req_info{'auth_type'};}


package Caudium::_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 ($Caudium::Request::req_state == 5423522)
  { # Magic number meaning we were evaluating something.
    if ($Caudium::Request::req_returncode != 200)
      { Sendreply(sprintf("RETURNCODE=%d", $Caudium::Request::req_returncode));}
    Senddata($Caudium::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, 'Caudium::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);

  $Caudium::Request::req_req = Caudium::Request->new();

  while (1)
  { $Caudium::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);
      $Caudium::Request::req_info{$var} = $data;
    }
    elsif ($cmd eq "F")
    { $var = Getdata(1); $data = Getdata(3);
      $Caudium::Request::req_vars{$var} = $data;
    }
    elsif ($cmd eq "H")
    { $var = Getdata(1); $data = Getdata(3);
      $Caudium::Request::req_headers{$var} = $data;
    }
    elsif ($cmd eq "L")
    { $var = Getdata(1); $data = Getdata(3);
      if ($var eq "libdir" and $Caudium::Request::req_config{$var} ne $data)
        { push @INC, $data;}
      if ($var eq "cd")
        { chdir $data;}
      $Caudium::Request::req_config{$var} = $data;
    }
    elsif ($cmd eq "R")
    { %ENV = ();
      %Caudium::Request::req_info = ();
      %Caudium::Request::req_vars = ();
      %Caudium::Request::req_headers = ();
    }
    elsif ($cmd eq "S" or $cmd eq "C")
    { $Caudium::Request::req_outbuf = "";
      $Caudium::Request::req_returncode = 200;
      $data = Getdata(3);
      alarm 150; # 2.5 minutes.
      $Caudium::Request::req_state = 5423522; # Magic number.
      if ($cmd eq "C")
      { my ($cmdin, $cmdout, $cmd);
        eval $data;
      }
      else
      { diag "{S:$data}\n";
        Caudium::Internal::runscript($data);
      }
      $Caudium::Request::req_state = 0;
      alarm 60; # One minute.
      if ($Caudium::Request::req_returncode != 200)
        { Sendreply(sprintf "RETURNCODE=%d", $Caudium::Request::req_returncode);}
      Senddata($Caudium::Request::req_outbuf);

      last if $starttime+300 < time; # Timeout after 5 minutes.

      $Caudium::Request::req_req = Caudium::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);
}




