From 256e29fcc03f8dbaffbcca408d9647889e0dbe40 Mon Sep 17 00:00:00 2001
From: hadeshyp <hadeshyp>
Date: Fri, 31 Aug 2012 08:44:32 +0000
Subject: [PATCH] Initial commit of mCTS soft

---
 cts/cts   | 639 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
 cts/gui   |  11 +
 cts/httpi | 498 ++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 1148 insertions(+)
 create mode 100755 cts/cts
 create mode 100755 cts/gui
 create mode 100755 cts/httpi

diff --git a/cts/cts b/cts/cts
new file mode 100755
index 0000000..e0f83c3
--- /dev/null
+++ b/cts/cts
@@ -0,0 +1,639 @@
+#!/usr/bin/perl
+
+# Debugging
+   use warnings;
+   use strict;
+   use Carp;
+   $SIG{ __DIE__ } = sub { Carp::confess( @_ ) };
+
+
+use lib "./include";
+   
+# Trb/Cts IO
+ #  use TrbSim;    included in connectToCTS if required
+   use TrbNet;    #included in connectToCTS if required
+   use Cts;
+   
+# Misc
+   use POSIX qw[ceil];
+   use Scalar::Util qw[looks_like_number];
+   use List::Util qw[min max sum];   
+   use Date::Format;
+   use Data::Dumper;
+   
+   use Time::HiRes qw(usleep gettimeofday tv_interval);
+   
+   use JSON::PP;
+
+   use FileHandle;
+   
+   
+sub help {
+   print <<'END_MSG';
+cts.pl [options] command
+
+Options:
+   -h | --help      Produce this message and quit
+   -e | --endpoint  Endpoint number of CTS
+   -s | --sim       Simulate TrbNet
+   -i | --interval  Interval of rate monitoring in milliseconds. Default: 1000
+   -n               Number of of rates to be stored per counter. Default: 30
+   
+Commands:
+   l | list         Connect to CTS and list all named registers available
+   
+   d | dump         Read configuration from CTS and generate trbcmd-script to
+                    reproduce setup after TrbNet reset
+   
+   r KEYS    |      Read named registers from CTS. KEYS is a white-space 
+   read KEYS        seperated list of registes available (see command l)
+                    Example: cts.pl r trg_pulser_config0 trg_coin_config1
+                     
+   w VALUES     |   Write value to CTS's named registers. VALUES is a comma 
+   write VALUES     sepearated list in the following format: {key}={value}
+                    Example: cts.pl w reg0=0x12, trg_coin_config0.window=10
+                     
+   m [file] |       Rate Monitor. Periodically fetch counters and calculate 
+   monitor [file]   rates. Results are send to STDOUT in an human readable form.
+                    If [file] is provided the data is additionally dumped into
+                    [file].js in the JSON format. Further a trigger rate plot
+                    is stored in [file].jpg
+
+END_MSG
+}
+
+sub printTable {
+   # printTable ($data, [$linefill], [$colsep])
+   #  $data expects an array reference. Each entry is interpreted
+   #  as one row. If the row itself is an array reference, each 
+   #  entry hold the data of one column. If the row is a string,
+   #  it is displayed as a header
+   my $data = shift;
+   my $linefill = shift;
+   my $colsep = shift;
+   
+   $linefill = "-"   unless defined $linefill;
+   $colsep   = " | " unless defined $colsep;
+   
+# find max len per column
+   my @len = (0);
+   
+   my $linelength = 0;
+   foreach my $row ( @{$data} ) {
+      if (ref $row) {
+         foreach my $i ( 0 .. $#{$row} ) {
+            $len[$i] = 0 unless exists $len[$i];
+            $len[$i] = max($len[$i], length $row->[$i]);
+         }
+      } else {
+         $linelength = max($linelength, length $row);
+      }
+   }
+   
+   $linelength = max($linelength, sum(@len) + length($colsep) * $#len);
+
+# print table
+   foreach my $row ( @{$data} ) {
+      my $line = "";
+      if (ref $row) {
+         my @tmp = ();
+         my $last = "";
+         
+         foreach my $i ( 0 .. $#{$row} ) {
+            my $rc  = exists $row->[$i] ? $row->[$i] : " ";
+            my $rcs = $rc . (" " x ($len[$i] - length $rc));
+            
+            if ($rc eq "") {
+               $last .= " " x length $colsep if $last;
+               $last .= $rcs;
+            } else {
+               push @tmp, $last if $last;
+               push @tmp, $rcs;
+               $last = "";
+            }
+         }
+      
+         push @tmp, $last if $last;
+         
+         $line = join $colsep, @tmp;
+      } else {
+         $line = substr($row . ($linefill x ceil( ($linelength - length $row) / length $linefill )), 0, $linelength)
+      }
+      
+      print $line . "\n";
+  }
+}
+   
+
+sub commandDump {
+   # commandDump($cts);
+   #  returns a string containing the trbcmd-script
+   my $cts = shift;
+   
+   my $result;
+   
+   $result  = "# CTS Configuration dump\n";
+   $result .= "#  generated:        " . time2str('%Y-%m-%d %H:%M', time) . "\n";
+   $result .= "#  CTS Compile time: " . time2str('%Y-%m-%d %H:%M', $cts->getTrb()->read(0x40)) . "\n#\n";
+   
+   foreach my $reg ( @{$cts->getExportRegisters()} ) {
+      my $val = $cts->getRegisters->{$reg}->format();
+      my @compact = split /, /, $val->{'_compact'};
+      my @ccompact = ();
+      my $tmp = "";
+      
+      foreach my $c (@compact) {
+         if (length ($tmp . $c) > 40) {
+            push @ccompact, $tmp . ($tmp ? ", ":"") . $c;
+            $tmp = "";
+         } else {
+            $tmp .= ($tmp ? ", " : "") . $c;
+         }
+      }
+      
+      push @ccompact, $tmp if ($tmp);
+      unshift @ccompact, "" if ($#ccompact > 0); 
+      
+      $result .= sprintf("w 0x%04x 0x%04x 0x%08x  # %s: %s\n", 
+         $cts->getTrb()->getEndpoint(),
+         $cts->getRegisters->{$reg}->getAddress(),
+         $val->{'_raw'},
+         $reg,
+         join "\n" . (" " x 28) . "# ",  @ccompact
+      );
+   }
+   
+   return $result;
+}
+
+sub commandList {
+   # commandList ($cts);
+   #  returns a two-dimensional array compatible to the printTable-format
+   my $cts = shift;
+   
+   my @keys = sort keys $cts->getRegisters;
+
+   my $data = [
+      ['Key', 'R/W', 'Module', 'Address', 'Slices'],
+      '-'
+   ];
+   
+   my @mods = sort keys $cts->getModules;
+
+   my $index = 0;
+   $index++ until $mods[$index] eq 'Static';
+   
+   if ($index) {
+      splice(@mods, $index, 1);
+      unshift @mods, "Static"
+   }
+
+   
+   foreach my $modType (@mods) {
+      my $mod = $cts->getModules->{$modType};
+      my $modName = "";
+      
+      $modName = sprintf("0x%02x - ", $modType) if looks_like_number($modType);
+      $modName .= $mod->moduleName;
+      
+      foreach my $reg (sort keys $mod->getRegisters) {
+         next if substr($reg, 0, 1) eq "_";
+         
+         my $slices = join(", ",  @{$cts->getRegisters->{$reg}->getSliceNames});
+         $slices = substr($slices, 0, 40) . "..." if length($slices) > 43;
+         
+         push $data, [
+            $reg,
+            $cts->getRegisters->{$reg}->getAccessMode(),
+            $modName,
+            sprintf("0x%04x", $cts->getRegisters->{$reg}->getAddress()),
+            $slices
+         ];
+      }
+   }
+   
+   return $data;
+}
+
+sub commandRead {
+   # commandRead($cts, $keys)
+   #  where keys is a string containing a whitespace seperated
+   #  list of register names
+   #  returns a two-dimensional array compatible to the printTable-format
+
+   my $cts = shift;
+   my @keys = @{shift()};
+   
+   my $data = [
+      ['Key', 'Address', 'Value', 'Slice', 'Slice Value'],
+      '-'
+   ];
+   
+   foreach my $key (@keys) {
+      chomp $key;
+      my $reg = $cts->getRegisters->{$key};
+      next unless $reg;
+      
+      $cts->getTrb->addPrefetchRegister($reg);
+   }
+   
+   $cts->getTrb->prefetch();
+   
+   foreach my $key (@keys) {
+      chomp $key;
+      next unless $key;
+      
+      my $reg = $cts->getRegisters->{$key};
+      if (defined $reg) {
+         my $values = $reg->format();
+         my $columns = [
+            $key, 
+            sprintf("0x%04x", $reg->getAddress()),
+            sprintf("0x%08x", $values->{'_raw'})
+         ];
+         
+         foreach my $sliceKey (sort keys $values) {
+            next if substr($sliceKey, 0, 1) eq "_";
+            
+            push $columns, $sliceKey;
+            push $columns, $values->{$sliceKey};
+            push $data, $columns;
+            
+            $columns = ['', '', ''];
+
+         }
+      } else {
+         push $data, [$key, 'Key not found'];
+      }
+   }
+
+   $cts->getTrb->clearPrefetch();
+
+   return $data;
+}
+
+sub commandWrite {
+   my $cts = shift;
+   my @exps = split /,/, shift;
+   
+   my $values = {};
+   
+   foreach my $expr (@exps) {
+      if ($expr =~ /^\s*([\w\d_]+)(|\.[\w\d_]+)\s*=\s*(.*)\s*$/) {
+         my $key   = $1;
+         my $slice = $2;
+         my $value = $3;
+
+         if ($slice) {
+            if (exists $values->{$key} and not ref $values->{$key}) {
+               die "Mixing of sliced/unsliced values for same register not allowed";
+            
+            } elsif (not exists $values->{$key}) {
+               $values->{$key} = {};
+               
+            }
+            
+            $values->{$key}->{substr $slice, 1} = $value;
+         
+         } else {
+            if (exists $values->{$key} and ref $values->{$key}) {
+               die "Mixing of sliced/unsliced values for same register not allowed";
+            }
+         
+            unless(looks_like_number($value)) {
+               die "Assignment of non-numeric values is allowed only for compatible sliced registers";
+            }
+            
+            $values->{$key} = $value;
+         
+         }
+      
+      } else {
+         die ("Invalid expression: $expr");
+      }
+   }
+   
+   foreach my $key (keys $values) {
+      $cts->getRegisters->{$key}->write( $values->{$key} );
+   }
+   
+   print "Done.\n";
+}
+
+sub commandMonitor {
+   my $cts = shift;
+   my $filename = shift;
+   my $interval = shift;
+   my $rateNumber = shift;
+   
+   my $trb = $cts->getTrb;
+   my @rateRegs = ();
+   my @slices = ();
+   
+   my @monRegs = ();
+
+# gather all registers and slices that need to be monitored
+   $trb->clearPrefetch();
+   while ((my $key, my $reg) = each %{ $cts->getRegisters }) {
+      next unless $reg->isa( 'TrbRegister' );
+   
+      if ($reg->getOptions->{'monitorrate'}) {
+         $trb->addPrefetchRegister($reg);
+         
+         if ( scalar keys $reg->getDefinitions == 1 ) {
+            push @rateRegs, $key;
+            push @slices, @{$reg->getSliceNames()}[0];
+         } else {
+            while ((my $sliceKey, my $slice) = each %{ $cts->getDefitions }) {
+               next unless $slice->{'monitorrate'};
+               push @rateRegs, $key;
+               push @slices, $sliceKey;
+            }
+         }
+      } elsif ($reg->getOptions->{'monitor'}) {
+         $trb->addPrefetchRegister($reg);
+         push @monRegs, $key;
+
+      }
+   }
+   
+   @monRegs = sort @monRegs;
+   @rateRegs = sort @rateRegs;
+
+# monitor !
+   my $t0;
+   my $rates = {};
+   my $lastRead = {};
+   
+   my $timeOverflow = 1.048576; #s
+   my $time = 0;
+
+   my $monData = {};
+   
+   my $plotData = [];
+   
+   
+   while (1) {
+      my $tab = [
+         ['Label', 'Register', 'Address', 'Value'],
+         '-'
+      ];
+      
+      print chr(27) . "[1;1H" . chr(27) . "[2J";
+   
+      my $read = {};
+      $trb->prefetch(1);
+      my $pcInterval = $t0 ? tv_interval($t0) : 0;
+      $t0 = [gettimeofday];
+
+ # monitoring
+      foreach my $regKey (@monRegs) {
+         $monData->{$regKey}->{'v'} = $cts->getRegisters->{$regKey}->read();
+         $monData->{$regKey}->{'f'} = $cts->getRegisters->{$regKey}->format();
+         
+         my $reg = $cts->getRegisters->{$regKey};
+         my $label = $reg->getOptions->{'label'};
+         my @values = split /,\s*/, $monData->{$regKey}->{'f'}{'_compact'};
+         
+         my @dispValues = (shift @values);
+         
+         while (my $val = shift @values) {
+            if ( length($dispValues[-1]) + length $val < 55 ) {
+               $dispValues[-1] .= ', ' . $val;
+            } else {
+               push @dispValues, $val
+            }
+         }
+         
+         push $tab, [$label, $regKey, sprintf("0x%04x", $reg->getAddress), shift @dispValues];
+         
+         while (my $val = shift @dispValues) {
+            push $tab, [' ', ' ', ' ', $val];
+         }
+      }
+
+      printTable $tab;
+      print "\n";
+      $tab = [
+         ['Label', 'Register', 'Address', 'Rate [1/s]', 'Abs. Value'],
+         '-'
+      ];
+      
+ # rates
+      foreach my $i (0..$#rateRegs) {
+         my $regKey = $rateRegs[$i];
+         my $slice =  $slices[$i];
+         
+        
+         my $cur = $read->{$regKey} = $cts->getRegisters->{$regKey}->read(0, 1);
+         
+         if ($pcInterval) {
+            my $last = $lastRead->{$regKey};
+            
+            my $timeDiff = ($cur->{'time'} - $last->{'time'}) * 1.6e-5;  #s
+            my $exactPeriod = $timeDiff + $timeOverflow * sprintf("%.0f", abs($pcInterval - $timeDiff)/$timeOverflow);
+
+            $time += $exactPeriod unless $i;
+            
+            my $counterDiff = $cur->{'value'}{$slice} - $last->{'value'}{$slice};
+            $counterDiff += (1 << $cts->getRegisters->{$regKey}->{'_defs'}{$slice}{'len'}) - 1 if $counterDiff < 0;
+            
+            my $rate = $counterDiff / $exactPeriod;
+            
+            $rates->{$regKey . '.' . $slice} = {
+               'rate' => sprintf("%.2f", $rate) + 0.0,     # add 0 to numifying value,  
+               'value' => $cur->{'value'}{$slice} + 0.0    # i.e. prevent escape in json
+            };
+            
+            my $label = $cts->getRegisters->{$regKey}->getOptions->{'label'};
+            $label = $regKey unless $label;
+            
+            $rate = sprintf("%.2f", $rate);
+            $rate = " " x (12 - length($rate)) . $rate;
+            
+            my $value = " " x (12 - length($cur->{'value'}{$slice})) . $cur->{'value'}{$slice};
+            
+            push $tab, [$label, $regKey, 
+               sprintf("0x%04x", $cts->getRegisters->{$regKey}->getAddress),
+               $rate , $value];
+         }
+      }
+
+      if ($filename) {
+      # store json
+         my $json = JSON::PP->new->encode({
+            'time' => $time,
+            'servertime' => time2str('%Y-%m-%d %H:%M', time),
+            'interval' => $interval,
+            'endpoint' => $trb->getEndpoint,
+            'rates' => $rates,
+            'monitor' => $monData
+         });
+         
+         open FH, ">$filename.js";
+         print FH $json;
+         close FH;
+      
+      # generate plot
+         shift $plotData if $#{ $plotData } > 30;
+         push $plotData, [
+            $time,
+            $rates->{'cts_cnt_trg_asserted.value'}{'rate'},
+            $rates->{'cts_cnt_trg_edges.value'}{'rate'},
+            $rates->{'cts_cnt_trg_accepted.value'}{'rate'}
+         ] if $rates->{'cts_cnt_trg_asserted.value'};
+         
+         
+         if ($#{ $plotData } > 4) {
+            open FH, ">$filename.gpdata";
+            foreach (@{$plotData}) {
+               my @row = (@{ $_ });
+               $row[0] -= $plotData->[-1][0];
+               print FH (join "  ", @row) . "\n";
+            }
+            close FH;
+
+            my $fh = new FileHandle ("|gnuplot");
+            $fh->autoflush(1);
+            
+            print $fh <<"EOF";
+set terminal png font "monospace,8" size 450,170
+set font 
+set output "$filename.png"
+set grid
+set key 
+set autoscale xfixmin
+#set yrange [* : *<1000000]
+set xlabel "Time [s]"
+set ylabel "Rate [1/s]"
+plot \\
+   "$filename.gpdata" using 1:3:(\$3 / 1000) with yerrorlines title "Edges", \\
+   "$filename.gpdata" using 1:4:(\$4 / 1000) with yerrorlines title "Accepted"
+
+EOF
+            ;
+            close $fh;
+         }
+      }
+      
+      printTable $tab;
+      
+      $lastRead = $read;
+      usleep($interval*1e3);
+      
+   }
+}
+
+sub connectToCTS {
+   my $mode = shift;
+   my $endpoint = shift;
+   
+   my $trb;
+   if ($mode eq 'sim') {
+      eval {require "TrbSim.pm"};
+      $trb = TrbSim->new($endpoint);
+      my $fp;
+      open $fp, "<memory.dump";
+      $trb->loadDump($fp);
+      close $fp;
+
+   } else{
+      eval {require "TrbNet.pm"};
+      $trb = TrbNet->new($endpoint);
+   }
+      
+   return Cts->new($trb);
+}
+
+####################################################################################
+my $trbMode = 'net';
+my $endpoint = 0xf3c0;
+
+my $updateInterval = 1000;
+my $rateNumber     = 30;
+
+for(my $i=0; $i < @ARGV; $i++) {
+   my $arg = $ARGV[$i];
+   chomp $arg;
+   $arg = lc $arg;
+   
+   if ($arg eq "-h" or $arg eq "--help") {
+      help();
+      exit();
+   } elsif ($arg eq "-s" or $arg eq "--sim") {
+      $trbMode = 'sim';
+      
+   } elsif ($arg eq "-e" or $arg eq "--endpoint") {
+      unless ($i < @ARGV) {
+         print "last parameter expects value\n";
+         exit();
+      }
+      
+      $i++;
+      
+      if ($ARGV[$i] =~ /0x([\da-f]{1,4})/) {
+         $endpoint = hex($1);
+      } else {
+         print "endpoint requires hex-number\n";
+         exit();
+      }
+   
+   } elsif ($arg eq "-i" or $arg eq "--interval") {
+      unless ($i < @ARGV) {
+         print "last parameter expects value\n";
+         exit();
+      }
+      
+      $updateInterval = $ARGV[++$i];
+
+   } elsif ($arg eq "-n") {
+      unless ($i < @ARGV) {
+         print "last parameter expects value\n";
+         exit();
+      }
+      
+      $rateNumber = $ARGV[++$i];
+   
+   } elsif ($arg eq "l" or $arg eq "list") {
+      printTable commandList connectToCTS($trbMode, $endpoint);
+      exit();
+      
+   } elsif ($arg eq "d" or $arg eq "dump") {
+      print commandDump connectToCTS($trbMode, $endpoint);
+      exit();
+   
+   } elsif ($arg eq "r" or $arg eq "read") {
+      unless ($i < $#ARGV) {
+         print "register name missing\n";
+         exit();
+      }
+      
+      my @list  = @ARGV[$i+1 .. $#ARGV];
+      printTable commandRead(connectToCTS($trbMode, $endpoint), \@list);
+      exit();
+   
+   } elsif ($arg eq "w" or $arg eq "write") {
+      unless ($i < $#ARGV) {
+         print "register name missing\n";
+         exit();
+      }
+      
+      my $cts = connectToCTS($trbMode, $endpoint);
+      commandWrite($cts, lc join(" ", @ARGV[$i+1 .. $#ARGV]));
+      exit();
+   
+   } elsif ($arg eq "m" or $arg eq "monitor") {
+      my $cts = connectToCTS($trbMode, $endpoint);
+      commandMonitor($cts, $ARGV[++$i], $updateInterval, $rateNumber);
+      
+   } else {
+      print "Invalid argument: $arg \n";
+      help();
+      exit;
+      
+   }
+}
+
+print "Command missing\n";
+help();
+exit;
\ No newline at end of file
diff --git a/cts/gui b/cts/gui
new file mode 100755
index 0000000..7405c9a
--- /dev/null
+++ b/cts/gui
@@ -0,0 +1,11 @@
+#!/bin/bash
+host=`hostname`
+port="1234"
+
+./httpi $host $port &
+echo "Started webserver at http://$host:$port"
+
+until ./cts m htdocs/monitor > /dev/null; do
+    echo "Cts monitor crashed with exit code $?.  Respawning.." >&2
+    sleep 1
+done
diff --git a/cts/httpi b/cts/httpi
new file mode 100755
index 0000000..cea5322
--- /dev/null
+++ b/cts/httpi
@@ -0,0 +1,498 @@
+#!/usr/bin/perl
+use POSIX qw(SIGALRM SIGTERM sigaction);
+$VERSION = "1.7 (Demonic/Linux)";
+
+# HTTPi Hypertext Tiny Truncated Process Implementation
+# Copyright 1999-2010 Cameron Kaiser and Contributors # All rights reserved
+# Please read LICENSE # Do not strip this copyright message.
+
+###############################################################
+# WHITE HATS ONLY BELOW THIS POINT -- SEE DOCUMENTATION FIRST #
+###############################################################
+
+%system_content_types =
+	("html" => "text/html",
+	 "htm" => "text/html",
+	 "txt" => "text/plain",
+	 "xml" => "text/xml",
+	 "xsl" => "text/xml",
+	 "xhtml" => "application/xhtml+xml",
+	 "css" => "text/css",
+	 "gif" => "image/gif",
+	 "jpeg" => "image/jpeg",
+	 "jpg" => "image/jpeg",
+	 "bmp" => "image/bmp",
+	 "png" => "image/png",
+	 "tif" => "image/tiff",
+	 "tiff" => "image/tiff",
+	 "ico" => "image/x-icon",
+	 "svg" => "image/svg+xml",
+	 "svgz" => "image/svg+xml",
+	 "wbmp" => "image/vnd.wap.wbmp",
+	 "wbm" => "image/vnd.wap.wbmp",
+	 "xbm" => "image/x-xbitmap",
+	 "mp3" => "audio/x-mpeg",
+	 "wma" => "audio/x-ms-wma",
+	 "wav" => "audio/x-wav",
+	 "au" => "audio/basic",
+	 "aif" => "audio/x-aiff",
+	 "aiff" => "audio/x-aiff",
+	 "ogg" => "audio/x-ogg", 
+	 "oga" => "audio/x-ogg",
+	 "mid" => "audio/midi",
+	 "wma" => "audio/x-ms-wma",
+	 "mpeg" => "video/mpeg",
+	 "mpg" => "video/mpeg",
+	 "aac" => "audio/aac",
+	 "ogv" => "video/x-ogg",
+	 "ogx" => "application/x-ogg",
+	 "avi" => "video/x-msvideo",
+	 "wmv" => "video/x-ms-wmv",
+	 "asf" => "video/x-ms-asf",
+	 "mov" => "video/quicktime",
+	 "mp4" => "video/mp4",
+	 "rv" => "video/vnd.m-realvideo",
+	 "rm" => "application/vnd.m-realmedia",
+	 "ra" => "audio/vnd.m-realaudio",
+	 "ram" => "audio/vnd.m-realaudio",
+	 "pdf" => "application/pdf",
+	 "fdf" => "application/vnd.fdf",
+	 "class" => "application/octet-stream",
+	 "jar" => "application/octet-stream",
+	 "js" => "application/x-javascript",
+	 "lnk" => "application/x-hyperlink",
+	 "prg" => "application/x-c64-prg-binary",
+	 "d64" => "application/x-c64-disk-image",
+	 "tar" => "application/x-tar",
+	 "sit" => "application/x-stuffit",
+	 "Z" => "application/x-compress",
+	 "gz"  => "application/x-gzip",
+	 "dmg" => "application/octet-stream",
+	 "img" => "application/octet-stream",
+	 "lzh" => "application/octet-stream",
+	 "lha" => "application/octet-stream",
+	 "exe" => "application/octet-stream",
+	 "com" => "application/octet-stream",
+	 "zip" => "application/x-zip-compressed",
+	 "hqx" => "application/x-binhex",
+	 "swf" => "x-shockwave-flash",
+	 "flv" => "video/x-flv",
+
+	 "bin" => "application/octet-stream");
+
+$logfile = "./htdocs/access.log";
+$path = "./htdocs";
+$sockaddr = 'S n a4 x8';
+$server_host = $ARGV[0];
+$server_port = $ARGV[1];
+
+die("$0 [host] [port] required. got >$server_host< >$server_port<") unless ($server_host and $server_port); 
+   
+%content_types =
+	("html" => "text/html",
+	 "htm" => "text/html",
+    "shtml" => "text/html"
+	 );
+%restrictions = (
+	 "/nw" => "^10\.##^Mozilla#MSIE",
+	 "/status" => "####voyeur:daNrZR3TcSwD2",
+	 "/" => "###(NPBot|WebZIP|HTTrack|eCatch|Offline Explorer|UdmSearch|WebCopier|internetseer|MSIECrawler|SuperBot|LinkWalker|Tutorial Crawler|WebReaper)",
+	);
+		# See documentation for interpreting this string.
+
+$headers = <<"EOF";
+Server: HTTPi/$VERSION
+MIME-Version: 1.0
+EOF
+
+
+%content_types = (%system_content_types, %content_types);
+undef %system_content_types;
+
+if ($pid = fork()) { exit; }
+$0 = "dhttpi: binding port ...";
+$bindthis = pack($sockaddr, 2, 1234, pack('C4', 0, 0, 0, 0));
+socket(S, 2, 1, 6);
+setsockopt(S, 1, 2, 1);
+bind(S, $bindthis) || die("$0: while binding port 1234:\n\"$!\"\n");
+listen(S, 128);
+$0 = "dhttpi: connected and waiting ANY:1234";
+
+$statiosuptime = time();
+
+sub sock_to_host {
+	return ($cache_hn, $cache_port, $cache_ip)
+		if (length($cache_ip));
+
+	return (undef, undef, undef) if (!$sock);
+	my($AFC, $cache_port, $thataddr, $zero) = unpack($sockaddr, $sock);
+	$cache_ip = join('.', unpack("C4", $thataddr));
+	$cache_hn =
+		gethostbyaddr($thataddr, 2) ||
+		$cache_ip;
+	return ($cache_hn, $cache_port, $cache_ip);
+}
+
+
+sub htsponse {
+	($currentcode, $currentstring) = (@_);
+	return if (0+$httpver < 1);
+	my($what) = <<"EOF";
+HTTP/$httpver $currentcode $currentstring
+${headers}Date: $rfcdate
+EOF
+	$what =~ s/\n/\r\n/g;
+	print STDOUT $what;
+	&hthead("Connection: close") if (0+$httpver > 1);
+}
+
+sub hthead {
+	my($header, $term) = (@_);
+	return if (0+$httpver < 1);
+	print STDOUT "$header\r\n" , ($term) ? "\r\n" : "";
+}
+
+sub htcontent {
+	my($what, $ctype, $mode) = (@_);
+	($contentlength) = $mode || length($what);
+	&hthead("Content-Length: $contentlength");
+	&hthead("Content-Type: $ctype", 1);
+	return if ($method eq 'HEAD' || $mode);
+	print STDOUT $what;
+}
+
+sub log {
+ 	if (open(J, ">>$logfile")) {
+		my $q = $address . (($variables) ? "?$variables" : "");
+		$contentlength += 0;
+		$contentlength = 0 if ($method eq 'HEAD');
+		my ($hostname, $port, $ip) = &sock_to_host();
+		$hostname ||= "-";
+		$httpuser ||= "-";
+		print J <<"EOF";
+$hostname - $httpuser [$date] "$method $q HTTP/$httpver" $currentcode $contentlength "$httpref" "$httpua"
+EOF
+		close(J);
+	}
+}
+
+
+sub bye { exit; }
+sub byebye { kill(9,$secondary_pid) if ($secondary_pid); exit; }
+
+sub dead {
+	&htsponse(500, "Server Error");
+	&hterror("Server Error", <<"EOF");
+The server cannot comply with your request for resource <tt>$::address</tt>.
+Please attempt to notify the administrators.
+<p>Useful(?) debugging information:
+<pre>
+@_
+</pre>
+EOF
+	&log; exit;
+}
+
+sub defaultsignals {
+	$SIG{'__DIE__'} = \&dead;
+	sigaction SIGALRM, new POSIX::SigAction \&bye
+		or die "sigalrm failed: $!\n";
+	sigaction SIGTERM, new POSIX::SigAction \&byebye
+		or die "sigterm failed: $!\n";
+}
+&defaultsignals;
+
+sub alarmsignals {
+	undef $SIG{'__DIE__'};
+	sigaction SIGALRM, new POSIX::SigAction sub { die; }
+		or die "sigalrm failed: $!\n";
+}
+
+sub master {
+	$0 = "dhttpi: handling request";
+$sock = getpeername(STDIN);
+$rfcdate = &rfctime(scalar gmtime, 1);
+$date = scalar localtime;
+($dow, $mon, $dt, $tm, $yr) = ($date =~
+	m/(...) (...) (..) (..:..:..) (....)/);
+$dt += 0;
+$dt = substr("0$dt", length("0$dt") - 2, 2);
+$date = "$dt/$mon/$yr:$tm +0000"; 
+
+select(STDOUT); $|=1; $address = 0; 
+alarm 5;
+while (<STDIN>) {
+	if(/^([A-Z]+)\s+([^\s]+)\s+([^\s\r\l\n]*)/) {
+		$method = $1;
+		$address = $2; 
+		$httpver = $3;
+		$httpref = '';
+		$httpua = '';
+		$httpver = ($httpver =~ m#HTTP/([0-9]\.[0-9]+)#) ?
+			($1) : (0.9);
+		$address =~ s#^http://[^/]+/#/#;
+		$0 = $execstring = "dhttpi: $method $address $httpver";
+		next unless ($httpver < 1);
+	} else {
+		s/[\r\l\n\s]+$//;
+		(/^Host:\s+(.+)/i) && ($httphost = substr($1, 0, 255))
+			&& ($httphost =~ s/:\d+$//);
+		(/^Referer:\s+(.+)/i) && ($httpref = substr($1, 0, 1024));
+		(/^User-agent:\s+(.+)/i) && ($httpua = substr($1, 0, 1024));
+		(/^Content-length:\s+(\d+)/i) &&
+			($ENV{'CONTENT_LENGTH'} = $httpcl = 0+$1);
+		(/^Content-type:\s+(.+)/i) &&
+			($ENV{'CONTENT_TYPE'} = $httpct = substr($1, 0, 255));
+		(/^Expect:\s+/) && ($expect = 1);
+		(/^Cookie:\s+(.+)/i) &&
+			($ENV{'HTTP_COOKIE'} = substr($1, 0, 16384));
+		(/^Authorization:\s+Basic (.+)/i) &&
+			($httprawu = substr($1, 0, 1024));
+		(/^Range:\s+(.+)/i) &&
+			($ENV{'CONTENT_RANGE'} = substr($1, 0, 255));
+		(/^If-Modified-Since:\s+(.+)/i) &&
+			($modsince = $ENV{'HTTP_IF_MODIFIED_SINCE'} =
+				substr($1, 0, 255));
+		(/^Accept:\s+(.+)/i) &&
+			($ENV{'HTTP_ACCEPT'} = substr($1, 0, 255));
+		(/^Accept-([a-zA-Z0-9]+):\s+(.+)/i) &&
+			($ENV{'HTTP_ACCEPT_'.uc(substr($1, 0, 16))} =
+				substr($2, 0, 255));
+		(/^X-Requested-With:\s+(.+)/i) &&
+			($ENV{'HTTP_X_REQUESTED_WITH'} = substr($1, 0, 1024));
+		next unless (/^$/);
+	}
+	if ($expect) {
+		&htsponse(417, "Expectation Failed");
+		&hterror("Expectation Failed",
+			"The server does not support this method.");
+		&log; exit;
+	}
+	if (!length($address) || (0+$httpver > 1 && !$httphost)) {
+		&htsponse(400, "Bad Request");
+		&hterror("Bad Request",
+			"The server cannot understand your request.");
+		&log; exit;
+	}
+	if ($method !~ /^(GET|HEAD|POST)$/) {
+		&htsponse(501, "Not Implemented");
+		&hterror("Not Implemented",
+			"Only GET, HEAD and POST are supported.");
+		&log; exit;
+	}
+	($address, $variables) = split(/\?/, $address);
+	$address =~ s/%([0-9a-fA-F]{2})/pack("H2", $1)/eg;
+	$address=~ s#^/?#/#;
+	1 while $address =~ s#/\.(/|$)#\1#;
+        1 while $address =~ s#/[^/]*/\.\.(/|$)#\1#;
+	1 while $address =~ s#^/\.\.(/|$)#\1#;
+	$fail = 0;
+	J: foreach(sort { length $a <=> length $b }
+			keys %restrictions) {
+		next if ($address !~ /^$_/);
+		($allowip, $denyip, $allowua, $denyua, $auser) =
+			split(/#/, $restrictions{$_});
+		if ($allowip || $denyip) {
+			($hostname, $port, $ip) = &sock_to_host();
+			($allowip && $ip !~ /$allowip/) && ($fail = 1,
+				last J);
+			($denyip && $ip =~ /$denyip/) && ($fail = 1,
+				last J);
+		}
+		($allowua && $httpua !~ /$allowua/) &&
+			($fail = 2, last J);
+		($denyua && $httpua =~ /$denyua/) &&
+			($fail = 2, last J);
+	}
+	if ($fail) {
+		&htsponse(403, "Forbidden");
+		if ($fail == 1) {
+			&hterror("Forbidden (Client Disallowed)", <<"EOF");
+Your network address (<i>$ip</i>) is not allowed to access this resource.
+EOF
+			&log; exit;
+		} else {
+			&hterror("Forbidden (Browser Disallowed)", <<"EOF");
+The browser you are using (<i>$httpua</i>) is not capable of or
+is not allowed access to this resource.
+EOF
+			&log; exit;
+		}
+	}
+	if ($auser) {
+		$httprawu =~ tr#A-Za-z0-9+/##cd;
+		$httprawu =~ tr#A-Za-z0-9+/# -_#;
+		$httprawu = unpack("u", pack("c", 32+0.75*length($httprawu))
+			. $httprawu);
+		($httpuser, $httppw) = split(/:/, $httprawu);
+		$fail = 1;
+		foreach $user (split(/,/, $auser)) {
+			($user, $pw) = split(/:/, $user);
+			($fail = 0, last) if ($user eq $httpuser &&
+				crypt($httppw, substr($pw, 0, 2)) eq $pw);
+		}
+		if ($fail) {
+			$httpuser = '';
+			&htsponse(401, "Authorization Required");
+			&hthead("WWW-Authenticate: Basic realm=\"$address\"");
+			&hterror("Authorization Required", <<"EOF");
+You must provide a username and password to use this resource. Either you
+entered this information incorrectly, or your browser does not know how to
+present the credentials required.
+EOF
+			&log; exit;
+		}
+	}
+
+	alarm 0;
+
+
+
+
+	$raddress = "$path$address"
+	;
+	1 while ($raddress =~ s#//#/#);
+	&hterror301("http://manchot:1234$address/")
+		if ($address !~ m#/$# && -d $raddress);
+	$raddress = (-r "${raddress}index.shtml") ?
+		"${raddress}index.shtml" : "${raddress}index.html"
+			if (-d $raddress);
+	IRED: ($hostname, $port, $ip) = &sock_to_host();
+	if(!sysopen(S, $raddress, 0)) { &hterror404; } else {
+		if ((-x $raddress) 
+			) {
+			$currentcode = 100; &nsecmodel;
+			$ENV{'REQUEST_METHOD'} = $method;
+			$ENV{'SERVER_NAME'} = "manchot";
+			$ENV{'SERVER_PROTOCOL'} = "HTTP/$httpver";
+			$ENV{'SERVER_SOFTWARE'} = "HTTPi/$VERSION";
+			$ENV{'SERVER_PORT'} = "1234";
+			$ENV{'SERVER_URL'} = "http://manchot:1234/";
+			$ENV{'SCRIPT_FILENAME'} = $raddress;
+			$ENV{'SCRIPT_NAME'} = $address;
+			$ENV{'REMOTE_HOST'} = $hostname;
+			$ENV{'REMOTE_ADDR'} = $ip;
+			$ENV{'REMOTE_PORT'} = $port;
+			$ENV{'QUERY_STRING'} = $variables;
+			$ENV{'HTTP_USER_AGENT'} = $httpua;
+			$ENV{'HTTP_REFERER'} = $httpref;
+			undef $pid;
+			if ($pid = fork()) { kill 15, $$; exit; }
+			elsif (!defined($pid)) {
+				die
+			"temporary(?) fork error, please retry request: $!\n";
+			} else {
+				require $raddress;
+				exit;
+			}
+		}
+		($x,$x,$x,$x,$x,$x,$x,$length,$x,$mtime) = stat(S);
+		$ctype = 0;
+		foreach(keys %content_types) {
+			if ($raddress =~ /\.$_$/i) {
+				$ctype = $content_types{$_};
+			}
+		}
+		$mtime = &rfctime($mtime);
+SERVEIT:	
+		if ($mtime eq $modsince) {
+			&htsponse(304, "Not Modified");
+			&hthead("Last-Modified: $mtime", 1);
+			&log; exit;
+		}
+		$ctype ||= 'text/plain';
+		if ($pid = fork()) { kill 15, $$; exit; }
+		$contentlength ||= $length;
+			&htsponse(200, "OK");
+			&hthead("Last-Modified: $mtime");
+			&htcontent("", $ctype, $length);
+			&nsecmodel;
+			$bytecount = 0;
+			unless ($method eq 'HEAD') {
+				while(!eof(S)) {
+					read(S, $q, 32768);
+					print STDOUT $q;
+					$bytecount += 32768;
+					$0 = $execstring .
+						" ($bytecount bytes sent)";
+				}
+			}
+		alarm 0;
+	}
+	exit;
+}
+
+exit;
+}
+
+
+sub nsecmodel {
+	&log;
+	($x,$x,$x,$x,$uid,$gid) = stat(S);
+	(!$uid || !$gid || $uid < 1000) &&
+		die "resource is root-owned, secured or not stat-able\n";
+	if (!$<) {
+		($) = "$gid $gid") || die "can't set egid to $gid";
+		($> = $uid) || die "can't set euid to $uid";
+		($( = "$gid $gid") || die "can't set rgid to $gid";
+		($< = $uid) || die "can't set ruid to $uid";
+	}
+}
+
+sub rfctime {
+	my $mtime = shift;
+	$mtime = (scalar gmtime $mtime) if (!(shift));
+	my ($dow, $mon, $dt, $tm, $yr) =
+		($mtime =~ m/(...) (...) (..) (..:..:..) (....)/);
+	$dt += 0; $yr += 0;
+	return "$dow, $dt $mon $yr $tm GMT";
+}
+
+sub hterror {
+	my($errstr, @expl) = (@_);
+	&htcontent(<<"EOF", "text/html");
+<html>
+<body>
+<h1>$errstr</h1>
+@expl
+<hr>
+<address><a href = "http://httpi.floodgap.com/">httpi/$VERSION</a>
+by Cameron Kaiser</address>
+</body>
+</html>
+EOF
+	}
+
+sub hterror404 {
+	&htsponse(404, "Not Found");
+	&hterror("Not Found",
+		"The resource <tt>$address</tt> was not found on this system.");
+	&log; exit;
+}
+
+sub hterror301 {
+	&htsponse(301, "Moved Permanently");
+	&hthead("Location: @_");
+	&hterror("Resource Moved Permanently",
+		"This resource has moved <a href = \"@_\">here</a>.");
+	&log; exit;
+}
+
+
+$0 = "dhttpi: on ANY:1234, ready!";
+$master_pid = $$;
+for (;;) {
+	if ($secondary_pid = fork()) {
+		waitpid($secondary_pid, 0);
+		$0 = "dhttpi: on ANY:1234, last request " .
+			scalar localtime;
+	} else {
+		$0 = "dhttpi (child of $master_pid): waiting for connect";
+		$addr=accept(NS,S);
+		open(STDIN, "<&NS");
+		open(STDOUT, ">&NS");
+		&defaultsignals;
+		&master;
+		exit;
+	}
+}
-- 
2.43.0