--- /dev/null
+#!/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
--- /dev/null
+#!/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;
+ }
+}
jspc29 / daqtools.git / commitdiff