#!/usr/bin/perl -s
# ^^^^^^^^^^^^^ Unix gurus will know to change this if your Perl
#               is not installed in the normal place.
##############################################################
#
# HyperLink Parsing Proxy version 1.1 for Unix and Perl5
#
# (c)2001, 2002, 2003, 2008 Cameron Kaiser and Computer Workshops, Inc.
# All rights reserved.
#
# Intended for use with HyperLink 2.5 and up for the C64/128.
#
#### PLEASE READ THIS SYNOPSIS OF THIS SOFTWARE'S LICENSE ####
#
# This program is distributed under the CWI Freeware License, not GPL.
# IF YOU PORT OR ALTER THIS SOFTWARE AND/OR DISTRIBUTE IT IN A MODIFIED
# FORM, YOU ARE STILL BOUND BY THIS LICENSE AND ITS TERMS. This is a
# brief synopsis of major points ONLY. Please read CAREFULLY. DO NOT
# USE THIS SOFTWARE IF YOU DO NOT AGREE TO HONOUR THESE STIPULATIONS.
#
# You may distribute this server software provided you do not
# sell it at a profit, sell a derivative work at a profit,
# or sell a port of this software at a profit. Placement of
# derivative works or ports under mutually exclusive license
# terms, such as GPL, is prohibited. Removal of this copyright
# or license message from any port, modified version or distribution;
# or release of this software, your modifications and adjustments
# to this software, or your port of this software, into the public
# domain; is prohibited. Usage, porting, modification or distribution
# of this software constitutes your acceptance of this License
# as legally binding. * THIS SUMMARY DOES NOT REPRESENT THE LICENSE
# IN ITS ENTIRETY, AND THERE MAY BE OTHER TERMS REGULATING YOUR USE
# OF THIS SOFTWARE. * For a complete copy of the License terms,
# E-mail
#
# spectre@deepthought.armory.com
#
# These terms do not apply to client software, which may have
# completely different terms and legalities binding its
# distribution, porting and modification. Please refer to your client
# program's documentation for its respective license.
#
######### NO USER SERVICEABLE PARTS BELOW THIS POINT #########
#
$ENV{'PERL_SIGNALS'} = "unsafe";        # for 5.8.1+
require 5.0;
#234567890123456789012345678901234567
$vstring = <<"EOF";

[HyperLink Parsing Proxy v1.1.13
 (C)2003, 2008 Cameron Kaiser]
EOF

($h || $help) && (($noend = 1), (print <<"EOF"), exit);
$vstring
** debugging options only! **
URL as an argument does a test
(implies -notrans -nopause)

-interactive: no stty control
   (probably needs -notrans)
-log: log activity to hlpp.log
-nocrunch: no trivial line crunch
-noend: no end msg or stty disable
-nointro: start quietly
-nopause: no LBL/PBP xmit (implies
 -nocrunch -nointro -interactive)
-nosocket: use built-in socket lib
-notrans: PETSCII xmissions off
-pdelay=n: set xmit timeout to n sec
-pcont=n: set contrast to n 0<n<oo
   (default 1.22)
-rc=file: use file for settings
   (default is \$HOME/.hlpprc or
    /etc/hlpprc)
-test: self-test initialisation

keep intel outside, boys'n'girls
EOF

if ($ARGV[0]) {
	$ENV{'PAGER'} ||= 'more';
	$url = shift @ARGV;
	$do_v = "-v" if ($v);
	exec("echo '$url' | $0 -notrans -nopause $do_v @ARGV | $ENV{'PAGER'}")
}

print "$vstring\n" unless ($nointro || $nopause);
&read_settings(0);

undef @xmitbuf;
if ($UNAME = &findexec('uname')) {
	chomp($OSTYPE = `$UNAME`);
	print "Detected operating system $OSTYPE.\n" unless
		($nointro || $nopause);
} else {
	warn "WARNING: No uname utility to detect your operating system!\n";
	# always want this warning
}
if ($STTY = &findexec('stty')) {
	# really should use POSIX but this isn't much less portable :-)
	print "Signal handler: $STTY\n" unless ($nointro || $nopause);
} else {
	die "FATAL ERROR: The stty utility must be\nin your path.\n";
}
if ($DJPEG = ($PPCONFIG{'jpeghelper'} || &findexec('djpeg'))) {
	$args = $PPCONFIG{'jpeghelpargs'} || 
		"-onepass -nosmooth -dither none -dct fast -pnm";
	$DJPEG = "$DJPEG $args";
	print "JPEG helper: $DJPEG\n" unless
		($nointro || $nopause);
} else {
	warn "NO JPEG HELPER! Can't view JPEG images.\n"
		unless ($nointro || $nopause);
}
if ($GIFTOPPM = ($PPCONFIG{'gifhelper'} || &findexec('giftoppm')
	|| &findexec('giftopnm') || &findexec('giftopbm'))) {
	$GIFTOPPM = "$GIFTOPPM $PPCONFIG{'gifhelpargs'}" if
		($PPCONFIG{'gifhelpargs'});
	print "GIF helper: $GIFTOPPM\n" unless
		($nointro || $nopause);
} else {
	warn "NO GIF HELPER! Can't view GIF images.\n"
		unless ($nointro || $nopause);
}
if ($TIFTOPNM = ($PPCONFIG{'tifftopnm'} || &findexec('tifftopnm'))) {
	$TIFTOPNM = "$TIFTOPNM $PPCONFIG{'tiffhelpargs'}" if
		($PPCONFIG{'tiffhelpargs'});
	print "TIFF helper: $TIFTOPNM\n" unless
		($nointro || $nopause);
} else {
	warn "NO TIFF HELPER! Can't view TIFF images.\n"
		unless ($nointro || $nopause);
}
print "Perl version $]\n";

unless ($nosocket) {
	eval "use Socket;";
	$AF_INET = &AF_INET;
	$PF_INET = &PF_INET;
	$SOCK_STREAM = &SOCK_STREAM;
	$SOL_SOCKET = &SOL_SOCKET;
	$SO_REUSEADDR = &SO_REUSEADDR;
	$SOMAXCONN = &SOMAXCONN;
} else {
	$AF_INET = $PF_INET = 2;
	$SOCK_STREAM = 1;
	$SOL_SOCKET = 65535;
	$SO_REUSEADDR = 4;
	$SOMAXCONN = 5;
}
$IPPROTO_TCP = 6;

($test) && (($noend = 1), print(<<"EOF"), exit);
+++++++++++++++++++++++++++++++++++++
SELF-TEST WAS SUCCESSFUL!
If the self-test reported missing
image helpers, you can still access
web pages, but you may be unable to
view some types of images.

EOF
$SIG{'__DIE__'} = sub { &barf(@_) };
$SIG{'INTR'} = $SIG{'ABRT'} = $SIG{'QUIT'} = $SIG{'TERM'} = # $SIG{'HUP'} =
	$SIG{'USR1'} = $SIG{'USR2'} = 'ignore';
END { &barf("successful.") unless ($noend); }

$CACHE = $PPCONFIG{'cachepath'} || "hlpp-cache";
$CACHE =~ s/\$UID/$</g;

&ooboff;
select(STDIN); $|++;
select(STDOUT); $|++;

@comcolours = (
	[ 0, 0, 0 ],
	[ 255, 255, 255 ],
	[ 255, 0, 0 ],
	[ 0, 255, 255 ],
	[ 255, 0, 255 ],
	[ 0, 255, 0 ],
	[ 0, 0, 255 ],
	[ 255, 255, 0 ],
	[ 224, 160, 64 ],
	[ 156, 116, 72 ],
	[ 255, 160, 160 ],
	[ 84, 84, 84 ],
	[ 136, 136, 136 ],
	[ 160, 255, 160 ],
	[ 160, 160, 255 ],
	[ 192, 192, 192 ]
);

%cname = (
	"black" => 0,
	"white" => 1,
	"red" => 2,
	"green" => 5,
	"maroon" => 2,
	"olive" => 9,
	"navy" => 6,
	"purple" => 4,
	"gray" => 12,
	"yellow" => 7,
	"blue" => 6,
	"teal" => 14,
	"lime" => 13,
	"aqua" => 3,
	"fuchsia" => 4,
	"silver" => 15,
);

%gophertypes = (
	"0" => "text/plain",
	"1" => "application/x-gophermenu",
	"4" => "application/octet-stream",
	"g" => "image/gif",
	"7" => "application/x-gophersearch",
	"h" => "text/html",
	"9" => "application/octet-stream",
	"I" => "image/jpeg", # awful kludge here
	"l" => "application/x-hyperlink",
);

%gopherlongtypes = (
	"0" => "Text file",
	"1" => "Menu",
	"4" => "Binary file (encoded)",
	"g" => "GIF image",
	"7" => "Search engine",
	"h" => "HTML file",
	"9" => "Raw binary file",
	"I" => "Image",
	"l" => "LinkScript file",
	"2" => "CSO search (not supported)",
	"8" => "Telnet (not supported)",
);

%supported_app_types = (
	"application/x-hyperlink" => "1",
	"text/plain" => "1",
	"text/vnd.wap.wml" => "1",
	"text/html" => "1",
	"application/x-gophermenu" => "1",
	"application/x-gophersearch" => "1",
);

$TIMEOUT = 20; # I demand satisfaction!
$F1LEN = 36;
$F2LEN = 18;
$PBPPLENGTH = 16;
$IMAGEUNROLL = 16; 
$BURSTPACKETS = 96;
$XMITTIMEOUT = $pdelay || 2;
$pcont ||= 1.22;
$tries = 0;
$MAX_RETRIES = 5;
$MAX_SOCK_RETRIES = 5;
$wbuf = "";
$lterm = ($notrans) ? "\n" : "\r";
$defram = $maxbufsize = 15360;	# max size of ninnyo buffer (take out
				# a suitable pad for safety -- 1K or so)

#$SIG{'CHLD'} = \&mother;

# end routine: reenable signals, echo and XON/OFF
sub barf {
	print STDOUT "Exiting proxy: @_\n";
	if ($log) {
		open(S, ">>hlpp.log") && printf(S "%s %s\n", scalar localtime,
			"@_") && close(S);
	}
	&oobon;
	exit;
}

sub ooboff { system("$STTY -echo -isig -ixon")
	unless ($nopause || $interactive);
	# no in-band signaling in protocols
}

sub oobon {
	system ("$STTY echo isig ixon") unless ($nopause || !$STTY);
}

# routine for making data from the HTML parser "LBL-safe"
#
# escape any characters that might be confusing to HL
# (assume if we calls output or lblput directly, we know
# what we're doing :-)
sub eoutput {
	local ($line) = (@_);
	$line =~ s/^\.//;
	1 while ($line =~ s/^##/#/);
	$line =~ s/^\.//;
	$line =~ s/\t/    /g;
	&output($line);
}

# output massager that automatically adds on truncate
# trailer when needed
sub output {
	local ($line, $countit) = (@_);
	return if ($bprint >= $maxbufsize);

	# any remaining unprintable characters, remove them
	$line =~ s/[\000-\011]//g;
	$line =~ s/[\013-\037]//g;
	$line =~ s/[\200-\377]//g;
	undef $line if ($line eq "\n");
	$line ||= " \n";

	if ($bprint >= ($maxbufsize - 48)) {
		if ($clength > 65535*$PBPPLENGTH) {
			$line = <<"EOF";
${line}

[Truncated: too large]
##end##
EOF
		} else {
			$line = <<"EOF";
${line}

.lihldl://_p\@$tproto\@$them$dport$page
[Truncated: download HTML]
##end##
EOF
		}
	}
	unless ($hlpp_header_printed || !$need_hlpp_header) {
		$hlpp_header_printed = 1;
		$mline = <<"EOF";
.tr
.lihlpp://settings/$address
<HLPP settings>
.tr
EOF
		if ($prom) {
			$mline .= ".ix$prom\n<Searchable>\n";
			$no_more_forms = 1;
		}
		if ($x_cst) {
			$mline .= $x_cst;
			undef $x_cst;
		}
		$line = "${mline}${line}";
	}
	$flushnow = ($line =~ /##end##\n$/s) ? 1 : 0;
	&lblput($line, $countit, $flushnow);
}

# LBL protocol routine: calculate checksum and call &transmit
sub lblput {
	local ($lgl, $countit, $flushnow) = (@_);
	local (@lines) = split(/\n/, $lgl);
	local ($line, $wx, $cs) = ('', '', 0);
	
	return if ($lprint == -1) ; # squelched
	#{ print "squelch\n"; return; }
	XMF: foreach $line (@lines) {
		$bprint += length($line) unless ($countit);
		next if (++$lprint <= $startpoint);
		# calculate checksum
		unless ($notrans) {
			$line =~ tr/A-Za-z/a-zA-Z/;
		}
		# try to do trivial case compression
		unless ($lastline ne $line || !$allowcrunch ||
			$nocrunch || $nopause) {
			$line = '';
		} else {
			$lastline = $line;
		}
		unless ($nopause) {
			my $i, $j;
			# add synchronisation code for HL
			# and compute LBL checksum
			$synchn = ($lprint & 7);
			$line = $synchn . $line;
			#$cs = 0; foreach $q (split(//, $line)) {
			$cs = 0; for($i=0; $i<length($line); $i++) {
				$cs += unpack("c", substr($line, $i, 1));
				$cs &= 255;
			}
			$cs = sprintf("%02x", $cs);
			$line = "$cs$line$lterm"; 
		}
		&transmit($line, $flushnow);
	}
}

# PBP protocol routine, then call transmit
# pad out the packet and then add to front: length, sequence number and
# then checksum ($PBPPLENGTH + 3 packet size)
sub pbpput {
	local ($buf) = (@_);
	return if ($lprint == -1);	# squelched
	local ($wx, $cs) = ('', length($buf));

	$lprint++;
	$buf .= ("z" x ($PBPPLENGTH - $cs)) if ($cs < $PBPPLENGTH);
	# calculate checksum -- -nopause is ignored here
	$buf = chr($lprint & 255) . chr($cs & 255) . $buf;
	$cs = 0; foreach (0..length($buf)) {
		$cs += unpack("c", substr($buf, $_, 1)); $cs &= 255;
	}
	$buf = chr($cs) . $buf;
	&transmit($buf);
}

# low level transmit routine, common for LBL and PBP transmissions
#
# try to do some burst communications and cache and send things. also
# fork a transmission process so we can do work in the background.
#
# notes on bandwidth: sustained packet bursts of greater than 60chars/packet
# cause flow control floods on some systems and the client/server synch
# is lost. don't try this
#
# most normal LBL packets should be 37 or less + seq# and 2 byte xsum
# PBP packets are 32 + length#, seq# and xsum
#
# a lot of the syswrite chachacha and file descriptor wait stuff is
# superfluous but if it ain't broke don't fix it
sub transmit {
	local ($line, $flushnow) = (@_);

	push(@xmitbuf, $line);
	#warn "we're at ", scalar(@xmitbuf), "now\n";
	return if (scalar(@xmitbuf) < $BURSTPACKETS && !$flushnow);

	waitpid($transpid, 0) if ($transpid); # blocking wait
	undef $transpid;
	# with all the subprocesses spawned, make sure returned signals
	# do NOT conflict!
	if ($? == 768) {
		warn ">> transmit process shut down output stream ($?).\n"
			if ($v);
		$bprint = $maxbufsize;
		$lprint = -1;
		return;
	}
	if ($transpid = fork()) {
		warn ">> sending $BURSTPACKETS packets (pid $transpid).\n"
			if ($v);
		undef @xmitbuf;
		return if (!$flushnow); # last one, so let's hang on
		warn ">> waiting for transmit thread ...\n" if ($v);
		waitpid($transpid, 0);
		undef $transpid;
		return;
	} elsif ($@) {
		warn ">> yikes, fork failed: $@\n" if ($v);
		undef @xmitbuf;
		return;
	}

	local $j, $wx, $cs, $rin, $win, $ein;
	$SIG{'__WARN__'} = sub { 1; }; # horrid kludge!

	XMITL: foreach $line (@xmitbuf) {
	$wx = ''; $cs = 0; $rin = $win = $ein = '';

	unless ($nopause || $interactive) {
		$j = sub {
			$SIG{'ALRM'} = 'ignore';
			alarm 0;
			select(undef, $win, undef, undef);
			syswrite(STDOUT, $line, length($line));
			unless (++$cs > 12) {
				$SIG{'ALRM'} = $j;
				alarm $XMITTIMEOUT;
			}
		};
		vec($rin, fileno(STDIN), 1) = 1;
		vec($win, fileno(STDOUT), 1) = 1;
		$SIG{'ALRM'} = 'ignore'; alarm 0;
		while ($wx !~ /^o$/i && $wx !~ /^b(reak)?$/i &&
			$wx !~ m#://#) {
			syswrite(STDOUT, $line, length($line))
				unless ($cs++);
			$SIG{'ALRM'} = $j; alarm $XMITTIMEOUT;
			select($rin, undef, undef, $XMITTIMEOUT);
			sysread(STDIN, $wx, 16); chomp $wx;
			if ($cs > 12 || $wx =~ /^b(reak)?$/i ||
				$wx =~ m#://#) {
				$SIG{'ALRM'} = sub { 1; };
				alarm 0;
				exit 3;
			}
		}
		alarm 0;
		$SIG{'ALRM'} = \&tiedie;
	} else {
		#print STDOUT (($pproto eq 'lbl') ? "$line$lterm" :
		#		(unpack("H70", $line) . "$lterm"));
		print STDOUT unpack("H90", $line) . "$lterm"
			if ($v);
		print STDOUT "$line$lterm";
	}

	} #foreach
	exit 0;
}

# simple word-wrap routine
sub wrapr {
	local ($adl) = (@_);
	$wbuf =~ s/\n/ /sg; $adl = "$wbuf$adl"; $wbuf = "";
	if (length($adl) <= $llen) {
		&eoutput("$indent$adl");
		return;
	}
	($adl =~ /^(.{$llen})(.*)$/s) && ($adl = $1, $wbuf = $2);
	if ($adl !~ /\s/s || $adl =~ /\s$/s) {
		&eoutput("$indent$adl\n");
		return;
	} else {
		($adl =~ /^(.*)\s([^\s]*)$/s) &&
			($wbuf = "$2$wbuf", &eoutput("$indent$1\n"));
	}
}

# SIGCHLD handler
sub mother { $SIG{'CHLD'} = \&mother unless ($OSTYPE =~ /^SCO/i ||
		$OSTYPE =~ /sysv/i ||
		$OSTYPE =~ /_sv$/i);
        while ($fchild != $child && $fchild != -1) {
		# could be a problem if it reaps $transpid? who knows?
		$fchild = wait; }
	$returned = $?; $child = 0; alarm 0; }

#$/ = "\r"; wtf?
print STDOUT <<"EOF" unless ($nopause || $nointro);

Proxy is ready to begin. Press F1
on your console to return to
HyperLink.

EOF

# main loop
COMLOOP: while(<STDIN>) {
	s/[\r\n]*$//;
	tr/A-Za-z/a-zA-Z/ unless ($notrans);
	if($log) {
		open(S, ">>hlpp.log") && printf(S "%s command: %s\n",
			scalar localtime, $_) && close(S);
	}

	# ignore leftover lbl/pbp acks and interrupts
	next if (/^b(reak)?$/i || /^o$/i);

	if (/^quit$/i) {
		exit;
	}

	# -- for future expansion --
	if (/^ram (\d+)$/i) {
		$maxbufsize = $1 || 15616;
		next;
	}
	if (/^s(tart )?(\$)?([a-fA-F0-9]+)$/i) {
		$startpoint = ($2 eq '$') ? hex($3) : $3;
		$_ = "cache";
	} # ------------------------

	$address = $_;
	$traddress = (length($address) > 36) ? substr($address, 0, 33).'...'
		: $address;
	# make this easier on HL: take the last '?xxx' section
	if ($address =~ /\?/) {
		local(@x) = split(/\?/, $address);
		$address = $x[0] . '?' . $x[$#x];
	}
	$indent = $olddent = '';
	$returned = $tries = $bprint = $lprint = $synch = 0;
	while (!$returned) {
		last if ($tries >= $MAX_RETRIES);
		$tries++;
		$returned = &spawn;
	} 
	if ($tries >= $MAX_RETRIES || $returned > 512) {
		$lprint = $startpoint;
		&buildcache(<<"EOF");
.fs2
14 Failed
.fs

The address

.fc15
$traddress
.fc

could not be accessed.
The address could be wrong, or the
remote computer may be down.

Press CTRL-R to reload the page.
$vstring
EOF
		$address = "cache";
		$returned = &spawn;
	}
	if ($returned == 512) { &read_settings(1); }
	$startpoint = 0;
	$ishistory = 1;
	$returned = 0;
	$tries = 0;
}

sub tiedie { exit 255; }

sub spawn {
	$/ = "\n";
	$stries = 0;
        if (!defined ($child = fork())) {
                warn "All forked up! (error was $!)\n";
                $returned = 2;
        } elsif ($child) {
		waitpid($child, 0);
		return $?;
	}

alarm $TIMEOUT;
$SIG{'ALRM'} = \&tiedie;
$noend = 1;
$exitsig = 1;
$lastline = "\0\0";

RETRY302:
undef $page, $port, $them;
if ($address eq 'cache') {
	&selcache;
	goto GRABFILE;
}

        ($address =~
	m#^(gopher|hlcn|hlpv|http|hldl|hlpp)://([^:/]+):(\d+)/(.*)$#i) &&
                (($uproto, $them, $port, $page) = ($1, $2, $3, "/$4"));
        ($address =~
	m#^(gopher|hlcn|hlpv|http|hldl|hlpp)://([^:/]+):(\d+)$#i) &&
                (($uproto, $them, $port, $page) = ($1, $2, $3, '/'));
        ($address =~
	m#^(gopher|hlcn|hlpv|http|hldl|hlpp)://([^:/]+)/(.*)$#i) &&
                (($uproto, $them, $port, $page) = ($1, $2, 0, "/$3"));
        ($address =~
	m#^(gopher|hlcn|hlpv|http|hldl|hlpp)://([^:/]+)$#i) &&
                (($uproto, $them, $port, $page) = ($1, $2, 0, '/'));
	$uproto =~ s/^h//; # yucky!
	($them =~ /^_p@(http|gopher|ftp)@(.+)$/) &&
		(($tproto, $them) = ($1, $2));
	$tproto ||= ($uproto eq 'gopher') ? 'gopher' : 'http';
	($page, $anchor) = split(/#/, $page, 2);
	$port ||= ($tproto eq 'gopher') ? 70 : 80;

$dport = ($port == 80) ? "" : ":$port";

if ($uproto eq 'lcn') {
	# Console mode extensions for future expansion
	print STDOUT "Yay!\n$address\n";
	print STDOUT "For future expansion!\n";

	print STDOUT "Type to stdeof.\n";
	&oobon;
	1 while (<STDIN>);
	&ooboff;
	print STDOUT "Press F1 to resume.\n";
	exit $exitsig;
}

if ($uproto eq 'lpp') {
	$pproto = 'lbl'; # these are LBL transmissions
	# meta controls
	if ($them eq 'console') {
		&buildcache(<<"EOF");
.lnhlcn://go-console
Go Console
EOF
		&selcache; goto GRABFILE;
	}
	if ($them eq 'readme') {
		&buildcache(<<"EOF");
.fs2
HLPP Readme
.fs

Your on-line help facility is
current and should contain the
most up-to-date information on
the Parsing Proxy.

Press F7 to back up.
$vstring
EOF
		&selcache; goto GRABFILE;
	}
	if ($them eq 'no-cache') {
		# sort of a pragma no cache ...
		if ($page =~ m#^/http://#) {
			$address = substr($page, 1);
			goto RETRY302;
		}
	}
	if ($them eq 'settings') {
		if ($page =~ s#^/set_([a-z0-9_]+)\=([a-z0-9_]+)\=/##) {
			($key, $val) = ($1, $2);
			if ($val) {
				$PPCONFIG{$1} = $2;
			} else {
				delete($PPCONFIG{$1});
			}
			if (scalar(%PPCONFIG)) {
				if (!open(RS, ">$ENV{'HOME'}/.hlpprc")) {
					&buildcache(<<"EOF");
.fs2
18 System Error
.fs

Could not save options:
$@
$!

Press F7 to back up.
$vstring
EOF
					&selcache; goto GRABFILE;
				} else {
					print RS <<"EOF";

# this configuration file was automatically built by hlpp
# (c)2003 cameron kaiser
# you can put additional options here -- ask CWI technical support

EOF
					foreach(keys %PPCONFIG) {
						print RS "$_: $PPCONFIG{$_}\n";
					}
					close(RS);
				}
			} else {
				unlink("$ENV{'HOME'}/.hlpprc");
			}
		}
		if ($PPCONFIG{'nocolour'}) {
			$colouronoff = "on";
			$coloursetval = 0;
		} else {
			$colouronoff = "off";
			$coloursetval = 1;
		}
		if ($PPCONFIG{'noimages'}) {
			$imagesonoff = "on";
			$imagessetval = 0;
		} else {
			$imagesonoff = "off";
			$imagessetval = 1;
		}
		if ($PPCONFIG{'noaltonly'}) {
			$altonlyonoff = "on";
			$altonlysetval = 0;
		} else {
			$altonlyonoff = "off";
			$altonlysetval = 1;
		}
		$page =~ s#^/##;
#234567890123456789012345678901234567
		&buildcache(<<"EOF");
.fs2
HLPP Options
.fs

-Page display options-
.lihlpp://settings/set_nocolour=${coloursetval}=/$page
Turn BODY colours $colouronoff

-Image display options-
.lihlpp://settings/set_noimages=${imagessetval}=/$page
Turn images fully $imagesonoff
or
.lihlpp://settings/set_noaltonly=${altonlysetval}=/$page
Turn ALT-ONLY mode $altonlyonoff

.lihlpp://no-cache/$page
Go back to previous page

$vstring
EOF
		$exitsig = 2;
		&selcache; goto GRABFILE;
	}
	if ($them eq 'prox-fatal') {
		$page = substr($page, 1);
		&buildcache(<<"EOF");
.fs2
18 Inconsistency
.fs

An inconsistency in the proxy has
occurred. Please report this
code to Computer Workshops, with
the URL and proxy version.

.fc15
$page
.fc

Press F7 to back up.
$vstring
EOF
		&selcache; goto GRABFILE;
	}
	if ($them eq 'prox-mail-err') {
		$page = substr($page, 1);
		&buildcache(<<"EOF");
.fs2
11 Mailto
.fs

This link points to the following
E-mail address:

.fc15
$page
.fc

Press F7 to back up.
EOF
		&selcache; goto GRABFILE;
	}
	if ($them eq 'prox-prot-err') {
		$page = (length($page) > 35) ? substr($page, 1, 33).'...'
			: substr($page, 1);
		&buildcache(<<"EOF");
.fs2
12 Protocol Error
.fs

This resource requires an Internet
protocol the parsing proxy does not
yet support. The URL is

.fc15
$page
.fc

Press F7 to back up.
$vstring
EOF
		&selcache; goto GRABFILE;
	}
	&buildcache(<<"EOF");
.fs2
18 Meta-error
.fs

A meta-directive has no
handler.

.fc15
$them
$page
.fc

Press F7 to back up.
$vstring
EOF
	&selcache; goto GRABFILE;
}

warn("going to $them:$port for $page\n\ttransport: $tproto user: $uproto\n")
	if ($v);

if ($them eq 'localfile') {
	if(open(S, $page)) {
		$clength = (-s $page);
		$ctype =
			($page =~ /\.txt$/i) ? 'text/plain' :
			($page =~ /\/lnk\./i) ? 'application/x-hyperlink' :
			($page =~ /\.s?html?$/i) ? 'text/html' :
			($page =~ /\.jpe?g$/i) ? 'image/jpeg' :
			($page =~ /\.gif$/i) ? 'image/gif' :
			($page =~ /\.tiff?$/i) ? 'image/tiff' :
			 'application/octet-stream';
		goto GRABFILE;
	}
	&buildcache(<<"EOF");
.fs2
14 Failed
.fs

File not found. Make sure you use a
full path and that you didn't make a
typing error.
$vstring
EOF
	&selcache; goto GRABFILE;
}	

RETRY:
if ($stries > $MAX_SOCK_RETRIES) {
	warn "giving up\n" if ($v);
	exit 255;
}
warn "** load try $tries, socket try $stries, last status $status **\n"
	if ($v);
sleep 2 if ($sockaddr);
$stries++;

$port=80 unless $port;
$sockaddr = 'S n a4 x8';

if ($page) {
$xport = ($tproto ne 'gopher' && $PPCONFIG{'proxyport'}) || $port;
$xthem = ($tproto ne 'gopher' && $PPCONFIG{'proxyhost'}) || $them;
$xpage = ($tproto ne 'gopher' &&
		$PPCONFIG{'proxyport'} && $PPCONFIG{'proxyhost'}) ?
		"http://$them:$port/$page" : $page;
($name, $aliases, $xport) = getservbyname($xport, 'tcp')
	unless $xport =~ /^\d+$/;
warn "looking up $xthem ...\n" if ($v);
($name, $aliases, $type, $len, $thataddr) = gethostbyname($xthem);
exit 255 if (!$thataddr);
warn "connecting to $name ..\n" if ($v);
$that = pack($sockaddr, $AF_INET, $xport, $thataddr, 0);

socket(S, $AF_INET, $SOCK_STREAM, $IPPROTO_TCP || 6) || goto RETRY;
connect(S, $that) || goto RETRY;
select(S); $| = 1;

warn "requesting $xpage ...\n" if ($v);

if ($tproto ne 'gopher') {
	$z = sprintf("GET %s HTTP/1.0\r\n" .
		"Host: $them\r\n" .
	"User-Agent: Lynx (compatible; HyperLink-Parsing-Proxy C64/128)\r\n" .
		"\r\n",$xpage);
	warn $z if ($v);
	print S $z;
	$ctype = "";
	$status = 500;
} else {
	if ($page eq '' || $page eq '/') {
		$page = '/1/';
	}
	($page =~
		/^\/(.)(.*)$/) && (($ctype, $xpage) = ($gophertypes{$1}, $2));
	$xpage =~ s/\?/\t/;
	$xpage =~ s/%([a-fA-F0-9]{2})/pack("H2", $1)/eg;
	$ctype ||= "gopher-unsupported";
	$clength = "not specified";
	if ($page =~ /^\/7\//) {
		$do_not_fetch = 1;
	} else {
		$z = sprintf("%s\r\n", $xpage);
		warn $z if ($v);
		print S $z;
	}
	$status = 200;
} 

} else {
	$ctype = "text/html";
	$status = 200;
	open(S, "$address");
	goto GRABFILE;
}
$loc = 0;

unless ($tproto eq 'gopher') {
	while (<S>) {
		s/[\r\l\n\s]+$//;
		(/^HTTP\/\d+.\d+ (\d+)/) && ($status == 500) && ($status = $1);
		(/^Content-type: (.+)/i) && ($ctype = $1);
		(/^Content-length: (.+)/i) && ($clength = 0+$1);
		(/^Location: (.+)/) &&
			($status > 299 && $status < 400) && ($loc = $1);
		last if (/^$/);
	}
}
goto RETRY if ($status == 500 && $stries < $MAX_SOCK_RETRIES);
goto RETRY302 if ($loc && ($address = $loc));

warn "** data connection established **\n\tstatus: $status type: $ctype\n"
	if ($v);
GRABFILE: $pproto = 'lbl';
alarm 0; $llen = $F1LEN; $fif = $suppress = 
	$wastc = $wastr = $tc = $tr = 0; $page =~ s/~/%7E/g;
($ctype, $ick) = split(/;/, $ctype, 2);
if (($uproto ne 'ldl' && $uproto ne 'd64' && $uproto ne 'lpv') &&
		!$supported_app_types{$ctype}) {
	warn "\t(unsupported)\n" if ($v);
	if ($ctype =~ m#^image/#) {
	if ((($ctype eq 'image/jpg' || $ctype eq 'image/jpeg') && ($DJPEG)) ||
		($ctype =~ m#image/vnd.wap.wbmp#i) ||
	    (($ctype eq 'image/tif' || $ctype eq 'image/tiff') &&
			($TIFTOPNM)) ||
		($ctype eq 'image/gif' && ($GIFTOPPM))) {
		$vuop = <<"EOF";
.lihlpv://_p\@$tproto\@$them$dport$page
View this image
EOF
	} else {
		$vuop = <<"EOF";
Your server does not have the
helper program to allow you to
view this image.
EOF
	}
	} else {
		$vuop = "You may:\n";
}

	if (0) { #$clength == 174848) {
		$d64op = <<"EOF";
.lihd64://$them$dport$page
Download as a .d64 disk image
EOF
	} else {
		$d64op = <<"EOF";
This file does not appear to be a
.d64 disk image.
EOF
		$d64op = '';
	}
	if ($clength > 65535*$PBPPLENGTH) {
		$dlop = <<"EOF";
This file is too large for the
Commodore client to attempt to
download and process.
EOF
	} else {
		$dlop = <<"EOF";
.lihldl://_p\@$tproto\@$them$dport$page
Download as file
EOF
	}
	$ctype = ((length($ctype) > 25) ? (substr($ctype, 0, 25) . "...") :
		$ctype);
	&buildcache(<<"EOF");
.fs2
10 View/Save
.fs

This file cannot be converted
into a LinkScript file.

Type: $ctype
Length (bytes): $clength

$vuop
$dlop
${d64op}${vstring}
EOF
	&selcache; goto GRABFILE;
}

unless ($do_not_fetch) {
	undef $/; $body = <S>;
}
close(S); undef $do_not_fetch;
warn ("** data connection complete **\n\tsize: ", length($body), "\n") if ($v);
open(S, ">$CACHE-type") && printf(S "%s", $ctype) && close(S);
open(S, ">$CACHE-location") && printf(S "%s\t%s\t%i\t%s", $them, $page,
	$port, $dport) && close(S);
open(S, ">$CACHE-file") && printf(S "%s", $body) && close(S);
$/ = "\n"; $rterm = $/;
# Image file download: talk in hex-encoded LBL (really still PBP)
# HR-LBL HR-LBL 
if ($uproto eq 'lpv') {
	$pproto = 'pbp';
	if ($ctype =~ m#^image/vnd.wap.wbmp#i) {

		# note that this is really a specialised case of P4 (pbm)
		# but I choose to handle it here to avoid scaling overhead
		# (since these are unlikely to be > 320x200)

		# small image, we can afford the overhead of substr()
		$null_r = "\0" x 80;
		$header = substr($body, 0, 4);
		$body = substr($body, 4);
		($type, $fheadf, $width, $height) = split(//, $header, 4);
		goto TERMLBL if (ord($type)); # should be level 0 wbmp
		$width = int(ord($width)/8+0.5);
		$height = ord($height); $height = ($height > 200) ? 200 :
			$height;
		for($i=0;$i<$height;$i++) {
			$w = unpack("H80", substr($body, 0, $width) . $null_r);
			&output(substr($w, 0, 40) . "\n", 1);
			&output(substr($w, 40, 40) . "\n", 1);
			#&output(substr($w, 40, 20) . "\n", 1);
			#&output(substr($w, 60, 20) . "\n", 1);
			$body = substr($body, $width);
		}
		goto TERMLBL;
	} elsif ($ctype eq 'image/jpg' || $ctype eq 'image/jpeg') {
		goto TERMLBL if (!$DJPEG);
		open(C, "$DJPEG 2>/dev/null $CACHE-file|");
	} elsif ($ctype eq 'image/tif' || $ctype eq 'image/tiff') {
		goto TERMLBL if (!$TIFTOPNM);
		open(C, "$TIFTOPNM 2>/dev/null $CACHE-file|");
	} elsif ($ctype eq 'image/gif') {
		goto TERMLBL if (!$GIFTOPPM);
		open(C, "$GIFTOPPM 2>/dev/null $CACHE-file|");
	} else { goto TERMLBL; } # no support yet
	undef($body); # clean up memory
	$allowcrunch = 1;
	$ppm_type = scalar(<C>);
	$ppm_type =~ s/[\r\l\n\s]$//;
	goto TERMLBL if ($ppm_type !~ /^P[456]$/);
	$ppm_buf = scalar(<C>);
	($ppm_width, $ppm_height) = split(/\s+/s, $ppm_buf, 2);
	$ppm_ccv = scalar(<C>) unless ($ppm_type eq 'P4');
	$ppm_width += 0;
	$ppm_height += 0;
	$ppm_ccv += 0;
	$intscale = 100;
	$intcut = $intscale / 2;
	# only relevant for P5, P6
	if ($ppm_type eq 'P6') {
		$bytpro = $ppm_width * 3;
		$maxccv = ($ppm_ccv * 3);
	} elsif ($ppm_type eq 'P5') {
		$bytpro = $ppm_width;
		$maxccv = $ppm_ccv;
	} else { # P4
		$bytpro = (($ppm_width & 7) ? (int($ppm_width/8) + 1) :
			($ppm_width/8));
		$maxccv = 0;
	}
	$cutoff = $maxccv / 2;
	$gcutoff = $cutoff / ($pcont * $intscale);
	$rows = 0;
	$xfactor = ($ppm_width > 320) ? (320/$ppm_width) : 1;
	$yfactor = ($ppm_height > 200) ? (200/$ppm_height) : 1;
	$factor = ($xfactor < $yfactor) ? $xfactor : $yfactor;
	$factor *= $intscale;
# build fastloop
	$yerrterm = 0;
	#print STDOUT "original dimensions $ppm_width x $ppm_height\n";
	#print STDOUT "image type $ppm_ccv ($ppm_type)\n";
	#print STDOUT "reduced to ", $ppm_width * $factor, " x ",
	#	$ppm_height * $factor, "\n";

	$loop = <<'EOF';
	use integer;
	$bshift = 9; # for P4
	@masks = (128, 64, 32, 16, 8, 4, 2, 1);
	PICTURE: while(1) { # row loop
		last PICTURE if ($lprint == -1); # break signal
		$bitbuf = '';
		$xerrterm = 0;
		$yerrterm += $factor;
		if ($yerrterm < $intscale) {
			read(C, $rgbt, $bytpro);
			next PICTURE;
		}
EOF
	if ($ppm_type eq 'P6') {
		$sloop = <<'EOF';
			last PICTURE if (!read(C, $rgbt, 3));
EOF
	} elsif ($ppm_type eq 'P5') {
		$sloop = <<'EOF';
			last PICTURE if (!read(C, $m, 1));
			$m = unpack("C", $m);
EOF
	} else { # P4 # must shift bits out, clunky but simpler coding
		$sloop = <<'EOF';
			if (!$masks[$bshift]) {
				last PICTURE if (!read(C, $bitsb, 1));
				$bitsb = (unpack("C", $bitsb)) ^ 255;
				$bshift = 0;
			}
			$rgbt = $bitsb & $masks[$bshift];
			$bshift++;
EOF
	}
	if ($ppm_width > 320) {
			$sloop .= <<'EOF';
				$xerrterm += $factor;
				if ($xerrterm >= $intscale) {
					$xerrterm -= $intscale;
EOF
	}
	if ($ppm_type eq 'P6') {
		$sloop .= <<'EOF';
			($r, $g, $b) = unpack("CCC", $rgbt);
			$m = ($r+$g+$b);
EOF
	}
	if ($ppm_type eq 'P5' || $ppm_type eq 'P6') {
		# common error diffusion code for greyscale/24-bit colour
		$sloop .= <<'EOF';
			$bitbuf .=
				((rand($intscale)+
					(($m-$cutoff)/$gcutoff)) > $intcut)
				? '1' : '0';
EOF
	} else { # P4
		$sloop .= <<'EOF';
			$bitbuf .= ($rgbt) ? "1" : "0";
EOF
	}
	if ($ppm_width > 320) {
			$sloop .= <<'EOF';
				}
EOF
	}
	if ($ppm_width > $IMAGEUNROLL) {
		$loop .= <<"EOF";
	for(1..$IMAGEUNROLL) {
EOF
		for($i=0;$i<int($ppm_width/$IMAGEUNROLL);$i++) {
			$loop .= $sloop;
		}
		$loop .= <<"EOF";
	}
EOF
	}
	if ($ppm_width % $IMAGEUNROLL) {
		for($i=0;$i<$ppm_width % $IMAGEUNROLL;$i++) {
			$loop .= $sloop;
		}
	}
	#	$bitbuf .= "0" x 320;
	#	&output(substr($w, 0, 20) . "\n", 1);
	#	&output(substr($w, 20, 20) . "\n", 1);
	#	&output(substr($w, 40, 20) . "\n", 1);
	#	&output(substr($w, 60, 20) . "\n", 1);
	$loop .= <<'EOF';
		$w = unpack("H80", pack("B320", $bitbuf));
		&output(substr($w, 0, 40) . "\n", 1);
		&output(substr($w, 40, 40) . "\n", 1);
		$rows++;
		$yerrterm -= $intscale unless ($yerrterm < $intscale);
		last if ($rows >= 200);
	}
	no integer;
EOF
	#print STDOUT $loop;
	#print STDOUT "--ok--\n";
	#exit;
	eval $loop;
	goto TERMLBL;
# Any other kind of binary file download: talk in PBP
# PBPPBPPBPPBP
} elsif ($uproto eq 'ldl') { # || $uproto eq 'd64') {
	$pproto = 'pbp';
	$upb = 2*$PBPPLENGTH;
	$j = length($body)/$PBPPLENGTH; $j = int($j)+1 if ($j != int($j));
	$k = $j/256; $j &= 255;
#	&pbpput(chr($j) . chr($k));
	&output(sprintf("%02x%02x\n", $j, $k));
	while(length($body) >= $PBPPLENGTH) {
#		&pbpput(substr($body, 0, $PBPPLENGTH));
		&output("0" . unpack("H$upb", substr($body,0,$PBPPLENGTH)) .
			"\n", 1);
		$body = substr($body, $PBPPLENGTH);
	}
#	&pbpput($body) if (length($body));
	&output(sprintf("%1x", length($body)) .
		unpack("H$upb", $body) . "\n", 1) if (length($body));
	goto TERMLBL;
} else {
# Text display file download: talk in LBL
if ($ctype eq 'text/plain') {
# LBLTEXT LBLTEXT
	foreach(split(/$rterm/, $body)) {
		last if ($lprint == -1); # break signal
		s/^\./ ./;
		$_ ||= "\n";
		&flushbuf if ($_ eq "\n" || $_ eq "\r\n" || $_ eq "\r");
		&wrapr("$_ ");
		&flushbuf if (length($_) < 60);
	}
	&flushbuf;
	goto TERMLBL;
# Raw LinkScript: send it through with only case control via LBL
} elsif ($ctype eq 'application/x-hyperlink') {
	foreach(split(/$rterm/, $body)) {
		next if (/^\.x/ && !$active);	# not allowed!
		next if (/^\.p[wk]/ && !$active);	# not allowed!
		$_ ||= " ";
		&output("$_\n");
	}
	goto TERMLBL;
# Gopher menus, process into text (LBL)
} elsif ($ctype eq 'application/x-gophermenu') {
#LBLGOPHER LBLGOPHER
	&output(".fs2\nGopher menu\n.fs1\n \n");
	$indent = "  ";
	$llen -= 2;
	foreach(split(/$rterm/, $body)) {
		undef $gtype;
		($idesc, $sel, $host, $p, $x) = split(/\t/, $_, 5);
		$p =~ s/\r//g;
		($idesc =~ /^(.)(.+)$/) && (($gtype, $idesc) = ($1, $2));
		($idesc = '', $gtype = 'i') if (!defined $gtype);
		next if ($gtype eq '.');
		$idesc =~ s/_/-/g;
		if ($gtype eq 'i') {
			&flushbuf if ($idesc eq '');
			&wrapr("$idesc ");
			&flushbuf if (length($idesc) < 60);
			next;
		}
		&flushbuf;
		$sel =~ s/%/%25/g;
		$sel =~ s/\s/%20/g;
		$sel =~ s/\?/%3F/g;
#		$sel =~ s/\//%2F/g;
		$indent = "";
		$llen += 2;
		&output(".tr\n");
		$is_url = ($sel =~ s/^GET%20//i) ? 1 : 0;
		if ($is_url) {
			&output("<Web site>\n");
		} else {
			&output("<$gopherlongtypes{$gtype}>\n");
		}
		&output(".tr\n");
		if ($is_url) {
			&output(".lihttp://$host:$p$sel\n");
		} else {
			&output(".ligopher://$host:$p/$gtype$sel\n")
				unless (!$gophertypes{$gtype});
		}
		$idesc =~ s/_/-/g;
		&wrapr("$idesc ");
		&flushbuf;
		$indent = "  ";
		$llen -= 2;
	}
	goto TERMLBL;
# Gopher search engine, just print an interface screen
} elsif ($ctype eq 'application/x-gophersearch') {
# LBLGOPHERS LBLGOPHERS
	&output(<<"EOF");
.fs2
Gopher search
.fs1

This is a searchable resource.
Press S to enter keywords.
.qegopher://$them:$port/1$xpage?
.tr
<Searchable>
.tr
.ixKeywords:
EOF
	goto TERMLBL;
# HTML: the big kahuna (LBL)
} elsif ($ctype eq 'text/html') {
#LBLHTML LBLHTML LBLHTML LBLHTML

	$need_hlpp_header = 1;
	&sgml_preload;
	&output('.bu' . substr(&reurl($address), 2) . "\n");

	GOTHROUGH: foreach(split(/\s*\n\s*/, $body)) {
		last if ($lprint == -1);
		if (/^\./ && !/^\.\s/ && !/^\.\./) { # yikes, false alarms
			s/^\.//;
			# tags to suppress
			if (m#^(/?)(title|script)#i) {
				$suppress += ($1 eq '/') ? -1 : 1;
				$suppress = 0 if ($suppress < 0);
				next;
			}
			next GOTHROUGH if ($suppress);
			# tags to preparse
			if (m#^br$#i || m#^/td$#i || m#^hr#i) {
				&flushbuf;
				if (m#^hr#i) {
					&output(("-" x $llen) . "\n");
				}
				next;
			}
			if (m#^(/?)center#i ||
				m#^p\s+align\s*=\s*["']?([^"'>]+)#i) {
				$w = $1;
				&flushbuf;
				$parablock = 1 if (/^p/i);
				if ($w eq 'left') {
					&output(".tc\n") if ($tc);
					&output(".tr\n") if ($tr);
					$tc = $tr = 0;
					next;
				}
				if (/center/i || $w eq 'center') {
					if (($w eq '/' && $tc) ||
						($w ne '/' && !$tc)) {
						&output(".tc\n");
						$tc ^= 1;
					}
					next;
				}
				# must be right
				&output(".tr\n") if (!$tr);
				$tr ^= 1;
				next;
			}
			if (m#^(/?)dl$#i) {
				&flushbuf;
				# this makes the rash assumption that
				# any <dl> ends on a <dd>
				if ($1 eq '/' && length($indent)) {
					$indent = (length($indent) > 2)
						? substr($indent, 2) : '';
					$llen += 2;
					&restoret;
				} else {
					&savet;
				}
				&output(" \n");
				next;
			}
			if (m#^dt$#i) {
				&flushbuf;
				if (length($indent)) {
					$indent = (length($indent) > 2)
						? substr($indent, 2) : '';
					$llen += 2;
				}
				next;
			}
			if (m#^dd$#i) {
				&flushbuf;
				$indent = "  $indent";
				$llen -= 2;
				next;
			}
			if (m#^(/?)[uo]l$#i) {
				&flushbuf;
				if ($1 eq '/' && length($indent)) {
					$indent = (length($indent) > 2)
						? substr($indent, 2) : '';
					$llen += 2;
					&restoret;
				}
				if ($1 ne '/') {
					&savet;
					$indent = "  $indent";
					$llen -= 2;
				}
				&output(" \n") unless ($blankline);
				$blankline = 1;
				next;
			}
			if (m#^(/?)li$#i) {
				next if ($1 eq '/');
				&flushbuf;
				$olddent = $indent;
				$indent =~ s/  $/\* /;
				next;
			}
			if (m#^/?p$#i) {
				&flushbuf;
				$parablock = 1 if (/^p/i);
				if (m#^/p#i) {
					if ($parablock) {
						&output(".tc\n") if ($tc);
						&output(".tr\n") if ($tr);
						$tc = $tr = 0;
					}
					$parablock = 0;
				}
				&output(" \n") unless ($blankline);
				$blankline = 1;
				next;
			}
			if (m#^/form#i) {
				undef $f_action;
				undef $f_method;
				next;
			}
			if (m#^form #i) {
				# rudimentary forms support
				next if ($no_more_forms);
				undef $f_action;
				undef $f_method;

				(/action\s*=\s*['"]?([^'" ]+)/i) &&
					($f_action = substr(&reurl($1), 2));
				(/method\s*=\s*['"]?([^'" ]+)/i) &&
					($f_method = uc($1));
				$f_method ||= "GET";
				&output(".tr\n") if ($tr);
				&output(".tc\n") if (!$tc);
				&output("<$f_method form>\n");
				&output(".tc\n") if (!$tc);
		 		&output(".tr\n") if ($tr);
				if ($f_method ne 'GET') {
					undef $f_action;
					undef $f_method;
				}
				next;
			}
			if (m#^input #i && (!/type\s*=\s*/i ||
				/type\s*=\s*['"]?text/i)) {
				undef $f_name;

				(/name\s*=\s*['"]?([^'" ]+)/i) &&
					($f_name = $1);
				next if (!$f_name || !$f_action ||
					$no_more_forms);
				&output(".qe${f_action}?${f_name}=\n");
				&output(".ixEnter request/data:\n");
				&output("<Searchable>\n");
				$no_more_forms = 1;
			}	
			if (m#^img #i) {
				&sgml_imager;
				next;
			}
			if (m#^/a$#i) {
				$in_li = 0;
				$last_url = '';
				next;
			}
			if (m#^body#i) {
				&flushbuf;
				if (/bgcolor/i || /text/i || /\slink/i) {
					$bgc = 1; $txc = 0; $llc = 14;
				#(s/\s+bgcolor\s*=\s*"?#?([a-fA-F0-9]{6})"?//i)
				(s/\s+bgcolor\s*=\s*['"]?([^"' ]+)["']?//i)
					&& ($bgc = &ccube($1));
				#(s/\s+text\s*=\s*"?#?([a-fA-F0-9]{6})?//i)
				(s/\s+text\s*=\s*['"]?([^'" ]+)["']?//i)
					&& ($txc = &ccube($1));
				#(s/\s+link\s*=\s*"?#?([a-fA-F0-9]{6})"?//i)
				(s/\s+link\s*=\s*['"]?([^" ]+)['"]?//i)
					&& ($llc = &ccube($1));
				if ($txc == $bgc || $txc == $llc) {
				$txc = (!($bgc == 0 || $llc == 0)) ? 0 :
				       (!($bgc == 1 || $llc == 1)) ? 1 :
					15;
				}
				if ($llc == $bgc || $llc == $txc) {
				$llc = (!($bgc == 0 || $txc == 0)) ? 0 :
					(!($bgc == 1 || $txc == 1)) ? 1 :
					15;
				}
					unless ($PPCONFIG{'nocolour'}) {
						&output
					(".cs" . ($txc*16+$bgc) . "\n");
						&output(".lc$llc\n");
					}
				}
				$hlpp_header_printed = 0;
				next;
			}
			# tags to translate
			$spz = ($blankline) ? '' : " \n";
			$do = 1 if (
	s#^a.*\s+href\s*=\s*["']?([^\s\"\'>]+).*$#&reurl($1)#ie ||
	(s#^frame.+src\s*=\s*["']?([^\s\"\'>]+).*$#&reurl($1)."\n[FRM-".&trimurl(&reurl($1),12)."]"#ie
		&& ($x_cst .= '.'.&reurl($1)."\n[FRM-".&trimurl(&reurl($1),12)."]\n")) ||
(s#^meta.+refresh.+URL\s*=\s*([^\s\"\'>]+).*$#&reurl($1)."\n[AUTO-".&trimurl(&reurl($1),11)."]"#ie
		&& ($x_cst .= '.'.&reurl($1)."\n[AUTO-".&trimurl(&reurl($1),11)."]\n")) ||
	((s#^font.+color\s*=\s*["']?([^"' ]+)["']?.+#"fc".&ccube($1)#ie)
		&& (++$fif)) ||
			(($fif > 0) && (s#^/font$#fc#i) && ($fif--, 1)) ||
				((s#^/h\d.*$#fs\n #i) && ($fontsize = 0,
					$blankline = 1, $null = $F1LEN)) ||
				((s#^h[12]$#$spz.fs2#i) && ($nodot = 1,
					$fontsize = 2, $blankline = 1,
					$null = $F2LEN)) ||
				((s#^h[3456]$#$spz.fs1#i) && ($nodot = 1,
					$fontsize = 1, $blankline = 1,
					$null = $F1LEN))
			);
			if ($do) {
				if (m#^li#) {
					$in_li = 1;
					s#~#%7E#g;
					s#^limailto:#lihlpp://prox-mail-err/#i;
					unless (m#^lih(tt|lp)p://# ||
						m#^ligopher://#) {
					s#^li#lihlpp://prox-prot-err/#i;
					}
				}
				&flushbuf;
				&output((($nodot) ? "" : ".") . "$_\n");
				$nodot = 0;
				if ($null) {
					$llen = $null; $null = 0; }
				$do = 0;
			}
			next;
		}
		&sgml_postload;
		if (length($olddent)) {
			$indent = $olddent;
			$olddent = ''; 
		}
	}
	&flushbuf;
	goto TERMLBL;
} elsif ($ctype eq 'text/vnd.wap.wml') {
#LBLWML LBLWML
	$need_hlpp_header = 1;
	&sgml_preload(1, 1);
	$suppress = 1;
	
	GAGTHROUGH: foreach(split(/\s*\n\s*/s, $body)) {
		last if ($lprint == -1);
		if (/^\./ && !/^\.\s/ && !/^\.\./) { # yikes, false alarms
			s/^\.//;
			%attribs = %{ &sgml_attribs($_) };
			if (m#^\?#) { next; }
			if (m#^!#) { next; }
			if (m#^(/?)template#i) {
				$suppress = ($1 eq '/') ? 1 : 0;
				next;
			}
			if (m#^(/?)card#i) {
				$suppress = 1;
				$anchor = $attribs{'id'} if (!$anchor);
				if ($anchor eq $attribs{'id'}) {
					$suppress = 0;
					next;
				}
			}
			next if ($suppress);
			if (m#^do #i) {
				$dostack = ($attribs{'label'} ||
					$attribs{'name'});
				next;
			}
			if (m#^/do$#i) { undef $dostack; next; }
			if (m#^anchor#i) {
				$grabnext = 1;
				next;
			}
			if (m#^go #i || m#^refresh/$#i) {
				next if (!defined $dostack);
				&flushbuf;
				&output("." . &reurl($attribs{'href'} || '#') .
					"\n");
				&wrapr("$dostack\n");
				next;
			}
			if (m#^prev/$#i) {
				&flushbuf;
				&output("<F7 backs up>\n") if ($ishistory);
				next;
			}
			if (m#^a #i) {
				&flushbuf;
				&output("." . &reurl($attribs{'href'}) .
					"\n");
				next;
			}
			if (m#^br/$#i) { &flushbuf; next; }
			if (m#^p #i || m#^p$#i) {
				&flushbuf; &output(" \n");
				($tc = 1, &output(".tc\n"))
					 if ($attribs{'align'} eq 'center');
				($tr = 1, &output(".tr\n"))
					 if ($attribs{'align'} eq 'right');
				next;
			}
			if (m#^/p$#i) {
				&flushbuf;
				&output(".tc\n") if ($tc);
				&output(".tr\n") if ($tr);
				$tc = $tr = 0;
				next;
			}
			if (m#^img #i) {
				# &output("img: $_\n");
				&sgml_imager;
				next;
			}
			if (m#^strong$#i) {
				&flushbuf;
				&output(".fc2\n");
				next;
			}
			if (m#^em$#i) {
				&flushbuf;
				&output(".fc12\n");
				next;
			}
			if (m#/(strong|em)$#i) {
				&flushbuf;
				&output(".fc\n");
				next;
			}	
			next;
		} else {
			if ($grabnext) {
				$dostack = $_;
				$grabnext = 0;
			} else {
				&sgml_postload;
			}
		}
	}
	&flushbuf;
	goto TERMLBL;
}
			
TERMLBL: &output(($pproto eq 'lbl' ? "\n" : "") . "##end##\n");
warn "*** end transmission. ***\n" if ($v);
}

exit $exitsig;
}

sub boundedreurl {
	my ($url) = (@_);
	return "lihlpp://prox-fatal/url-too-long-to-process"
		if(length($url) > 239);
	return $url;
}

sub reurl {
	local ($url) = (@_);
	$last_url = $url;
	return &boundedreurl("lihttp://$them$dport$page$url")
		if ($url =~ /^#/);
	$url =~ s/#.*$//;
	my ($x, $y) = split(/\?/, $url);
	return &boundedreurl("li$url")
		if ($x =~ m#://# || $x =~ m#^mailto:#i);
	my $q = $page;
	($q, $x) = split(/\?/, $q, 2) if ($q =~ /\?/);
	$q =~ s#/[^/]+$#/#;
	if ($url !~ m#^/#) {
		$q = "$q$url";
	} else {
		$q = $url;
	}
	$q =~ s#/\./#/#g;
	$q =~ s#/([^/]+)/\.\.##g;
	1 while $q =~ s#//#/#;
	$q = "$them$dport$q";
	return &boundedreurl("lihttp://$q");
}

sub ccube {
	local ($rgbt) = (@_);
	local $difr, $cn, $xcn, $x, $m;
	$difr = hex("ffffff"); $cn = 0; $xcn = -1;

	# check for known colour names
	if ($rgbt !~ /^#/) {
		return $cname{lc($rgbt)};
	}

	$rgbt = substr($rgbt, 1);
	return "" if (length($rgbt) != 6 || $rgbt =~ /[^a-fA-F0-9]/);
	local $rg1 = hex(substr($rgbt, 0, 2));
	local $rg2 = hex(substr($rgbt, 2, 2));
	local $rg3 = hex(substr($rgbt, 4, 2));

	# try exact test
	$xcn = -1;
	$cn = 0;
	foreach $m (@comcolours) {
		if ($m->[0] == $rg1 && $m->[1] == $rg2 && $m->[2] == $rg3) {
			$xcn = $cn;
			last;
		}
		$cn++;
	}
	return $xcn if ($xcn > -1);

	# midline
	$mfx = 1.3;
	$mdj = 160;
	$rg1 += ($rg1 - $mdj)*$mfx;
	$rg1 = ($rg1 < 0) ? 0 : ($rg1 > 255) ? 255 : $rg1;
	$rg2 += ($rg2 - $mdj)*$mfx;
	$rg2 = ($rg2 < 0) ? 0 : ($rg2 > 255) ? 255 : $rg2;
	$rg3 += ($rg3 - $mdj)*$mfx;
	$rg3 = ($rg3 < 0) ? 0 : ($rg3 > 255) ? 255 : $rg3;
	#print "$rg1 $rg2 $rg3\n"; # return 0;
	$cn = 0;
	foreach $m (@comcolours) {
		if ($m->[0] == $rg1 && $m->[1] == $rg2 && $m->[2] == $rg3) {
			$xcn = $cn;
			last;
		}
		$x = (($j1 = (256 + $rg1 - $m->[0]) & 255) +
			($j2 = (256 + $rg2 - $m->[1]) & 255) +
			($j3 = (256 + $rg3 - $m->[2]) & 255)) ;# ^ (1/2);
	#	print "$j1 $j2 $j3; $difr $x\n";
		if ($difr > $x) {
			$xcn = $cn;
			$difr = $x;
		}
		$cn++;
	}
	die "colour cube failure" if ($xcn == -1);
	return $xcn;
}

sub flushbuf {
	if ($wbuf) {
		while($wbuf) {
			&wrapr('');
		}
	}
}

sub buildcache {
	local($what, $type) = (@_);
	open(S, ">$CACHE-type") && printf(S "%s",
		$type || "application/x-hyperlink")
		&& close(S);
	open(S, ">$CACHE-location") && printf(S "%s\t%s\t%s\t%s",
		"prox-fatal", "escaped-null-cache", "80", "") && close(S);
	open(S, ">$CACHE-file") && printf(S "%s", $what) && close(S);
}

sub selcache {
	open(S, "$CACHE-type") && ($ctype = scalar(<S>)) && close(S);
	open(S, "$CACHE-location") && (($them, $page, $port, $dport) =
		split(/\t/, (scalar(<S>)))) && close(S);
	open(S, "$CACHE-file");
	$pproto = 'lbl';
	$uproto = 'ttp';
	$tproto = 'http'; # blatant lie
}

sub findexec {
	local (@paths) = split(/[:\s]/, $ENV{'PATH'});
	local $q, $r;

	foreach $q (@paths) {
		return "$q/@_" if (-x "$q/@_");
	}
	return 0;
}

sub savet {
	#warn "indent length ", length($indent);	
	return if (length($indent));
	$wastc = $tc;
	$wastr = $tr;
	&output(".tc\n") if ($wastc);
	&output(".tr\n") if ($wastr);
	$tc = $tr = 0;
}

sub restoret {
	#warn "indent length ", length($indent);	
	return if (length($indent));
	&output(".tc\n") if ($wastc);
	&output(".tr\n") if ($wastr);
	$tc = $wastc;
	$tr = $wastr;
}

sub sgml_attribs {
	local($tag)= shift;
	my %attrib;

	ATRLO: while(1) {
	unless(($tag =~ s/\s+([A-Za-z0-9_]+)\s*=\s*"([^"]+)"(\s|\/?$)/ /)
		&& (($key, $value) = ($1, $2))) {
	unless(($tag=~s/\s+([A-Za-z0-9_]+)\s*=([^\s]+)(\s|\/?$)/ /)
			&& (($key, $value) = ($1, $2))) {
			last ATRLO;
			}
		}
		#print STDOUT "$tag, $key, $value\n";
		$attrib{$key} = $value;
	}
	return \%attrib;
}
	
sub sgml_preload {
	local($keepselect, $keepmetaf) = (@_);

	$k8bit = ''; for($i=129;$i<256;$i++) { $k8bit .= chr($i); }
	$cray = '\]|\s|\||\*|\.|,|-|:|\?|\[|\/'; # for intelligent char removal

	# global cleanup
	# rule of thumb: are there \012s in this?
	if ($body =~ /\012/s) {
		# turn all \rs into spaces
		$body =~ s/\015/ /sg;
		# and all \ns into platform independent
		$body =~ s/\012/ \n/sg;
	} else {
		$body =~ s/\015/ \n/sg;
	}
	# unbreak html tags
	1 while ($body =~ s/(\<[^\n>]+)\n/\1/);
	$body =~ s/\&quot;/"/gi;
	$body =~ s/\&copy;/(C)/gi;
	$body =~ s/\&trade;/(tm)/gi;
	$body =~ s/\&[lr]dquo;/\"/gi;
	$body =~ s/\&[lr]squo;/\'/gi;
	$body =~ s/\&reg;/(R)/gi;
	$body =~ s/\&#169;/(C)/g;
	$body =~ s/\&nbsp;/ /gi;
	$body =~ s/\&mdash;/--/gi;
	$body =~ s/\&ndash;/-/gi;
	$body =~ s/\&szlig;/ss/gi;
	$body =~ s/\&([aeiou])(acute|grave|uml);/\1/gi;
	$body =~ s/\&ntilde;/n/gi;
	$body =~ s/\&ccedil;/c/gi;
	$body =~ s/\&#(\d+);/($1 > 127) ? '' : chr($1)/eg;
	$body =~ s/\&amp;/\&/g;
	$body =~ s/\&apos;/'/g;
	$body =~ s/\{/[/g;
	$body =~ s/\}/]/g;
	$body =~ s/([$k8bit])/-/g;

	# <pre> has to be handled at this level - fairly ugly and doesn't grok
	# embedded tags quite right. Sorry.
	1 while ($body =~
s#<pre>(.+?)</pre>#$j=$1,$j=~s/\n\s*\n/<p>/gs,$j=~s/(\n|^)(\s+)/$1.("`" x length($2))/egs,$j=~s/\n/<br>/gs,$j#sie);

	# tags that we never ever want to see
	$body =~ s#</?(b|i|sup|sub|blockquote|code|u|s|tt)>##ig;

	# meta-formatting tags we *might* want to see
	unless ($keepmetaf) {
		$body =~ s#</?(strong|em)>##ig;
	}

	$body =~ s/\n/ /sg;

	# destroy <select></select>, they're very wasteful of memory
	unless ($keepselect) {
		1 while ($body =~ s#<select.+?/select>##si);
	}

	# destroy <style></style>
		1 while ($body =~ s#<style.+?/style>##si);

	# destroy <hlpphide></hlpphide>, one of the worst mockeries
	# of standards I've ever done
		1 while ($body =~ s#<hlpphide>.+?</hlpphide>##si);

	# modality tag kludges
	undef $prom;
	if ($body =~ s/<(isindex[^>]*)>//ig) {
		$iprom = $1;
		($iprom =~ /prompt\s*=\s*['"]?([^'">]+)/i) &&
			($prom = $1);
		$prom ||= "Enter your search query:";
		$prom = substr($prom, 0, 30);
	}
	if ($body =~ /<body/i) {
		$hlpp_header_printed = 1; # saves us some overhead
	} else {
		$hlpp_header_printed = 0;
	}

	$body =~ s/>/\n/g;

	1 while ($body =~ s/  / /g);
	$body =~ s/\n +/\n/sg;
	$body =~ s/\t/        /g;

	# protect leading dots from accidental interpretation
	$body =~ s/\n\s*\.([^\s])/\n\\.\1/sg;

	$body =~ s/</\n\./g;
	$body =~ s/\&lt;/</gi;
	$body =~ s/\&gt;/>/gi;
	$body =~ s/\&laquo;/<</gi;
	$body =~ s/\&raquo;/>>/gi;

	1 while ($body =~ s/\n\n/\n/sg);
	print $body if ($v);
}

sub sgml_postload {
		s/^\.\s+//;	# for false alarms and dirty cheats
		s/^\\+/ /g;     # for escaped dot sequences
		s/[_|\\]/-/g;	# for non-URL text display
		1 while (s/\s\s/ /g);
		# clean-up kludge
		$ils = $blankline = 0;
		#if (!s/^\s*([$cray]*)\s+//) {
		#	$ils = 1 if (/^\s*([$cray]*)$/);
		#}
		s/^\s*(${cray}*)\s+//;
		$ils = 1 if (/^\s*(${cray})+$/);
		s/`/ /g;
		&wrapr("$_\n") unless ($ils || $suppress);
}

sub sgml_imager {
		$alt = $img = '';
		my $malt = '[IMAGE]';

		(/src\s*=\s*['"]?([^'" ]+)/i) &&
			($img = $1);
		(/\s+alt\s*=\s*"([^"]*)"/i) &&
			($alt = $1);
		(!length($alt)) && (/\'/) && (/\s+alt\s*=\s*'([^']*)'/i) &&
			($alt = $1);
		$alt =~ s/^\s+//;
		$alt =~ s/\s+$//;
		return
		if (!length($alt) && !$PPCONFIG{'noaltonly'} && !$in_li);
		$malt = ("[IMG-".&trimurl($last_url, 12)."]")
			if ($in_li && length($last_url));
		&wrapr(((length($alt)) ? $alt : $malt) . "\n");
		&flushbuf;
		if ($img && !$PPCONFIG{'noimages'}) {
			$jmg = $img = &reurl($img);
			$jmg =~ s/^lihttp/lihlpv/;
			&output(".tr\n") if (!$tr);
			&output(".fs\n") if ($fontsize);
			&output(".$jmg\n");
			&output("<View image>\n");
			&output(".$img\n");
			&output("<File options>\n");
			&output(".fs$fontsize\n")
				if ($fontsize);
			&output(".tr\n") if (!$tr);
		}
}

sub read_settings {
	my($myquiet) = (@_);
	my($w) = $_;

	undef %PPCONFIG;
	if (open(RS, ($rc || ((-e "$ENV{'HOME'}/.hlpprc") ?
		"$ENV{'HOME'}/.hlpprc" : 0) || '/etc/hlpprc'))) {
		while(<RS>) {
			chomp;
			next if (/^#/);
			($key, $val) = split(/:\s+/, $_, 2);
			next if (!$key);
			$PPCONFIG{$key} = $val;
			print "Configure setting '$key' now '$val'.\n"
				unless ($nointro || $nopause || $myquiet);
		}
		close(RS);
	}
	$_ = $w;
}

sub trimurl {
	my ($last_url, $trim) = (@_);
	$last_url =~ s/^.li//;
	return (
		(length($last_url) > $trim)
			? ('..'.substr(
				$last_url,
					length($last_url)-($trim-2),
					($trim-2)))
			: $last_url
		);
}