#!/usr/bin/perl -w

######################
#
# PerlMonks' Proxy w/ Syntax Highlighting
# v2.0.1
#
# May 30, 2001
#
# Ever wanted to view perlmonks.org w/ your own formatting? Ever wanted to
# view all those code snippets in all the colours and fonts you use in your
# editor? Ever wanted that incredible looking girl who sits near you in Chem
# class to c... err.. Well the first two you can have!
#
#
# Change Log:
#
# v2.0.1 - May 30 2001 [arguile]
#           Added syntax highlighting to code segments
#           Added permanent cookie support (saves as .pmcookie)
#
# v2.0.0 - Apr 02 2001 [nashdj]
#            Cookie support added (doesn't store perm)
#            POST support added
#            Still no Error Control
#          See http://localhost:99/index.pl?node=pmproxy2 for details
#
# v1.0.0 - Dec 04 2000 [nashdj]
#            Createded, allows CSS replacement for viewing Perl Monks
#            No Error Control
#            No Cookie Support
#            No POST Support
#          See http://localhost:99/index.pl?node=pmproxy for details
#
######################


use strict;
use LWP::Simple;
use HTTP::Daemon;
use HTTP::Status;
use HTTP::Cookies;
use LWP::UserAgent;
use Syntax::Highlight::Perl;

# Address and port to run daemon on.

my ($addr, $port) = qw(localhost 99);

# Create a new user agent for fetches.

my $usr_agent = new LWP::UserAgent;

# Create a cookie jar and assign it for the user agents use. This stores
# the perlmonk user login. For win32 systems that don't define HOME the
# cookie is stored in the calling proccess dir. Very much meant for
# single user calling. :)

$ENV{HOME} = '.' if not defined $ENV{HOME};

my $cookie_jar = HTTP::Cookies->new(
	file => "$ENV{HOME}/.pmcookie",
	autosave => 1
);

$cookie_jar->load() || warn "The Cookie monster has eaten your cache.\n";
$usr_agent->cookie_jar($cookie_jar);

# Start the HTTP Daemon with specified bindings.

my $daemon = HTTP::Daemon->new(
	LocalAddr => $addr,
	LocalPort => $port,
	Reuse => '1'
) || die "Cant Spawn: $!";

# Create and init formatter.

my $formatter = new Syntax::Highlight::Perl;
&initFormatter();

# Grab the Cascading Style Sheet.

open(CSS,"style.css") || die "CSS Error: $!";
my $css = join("",<CSS>);
close(CSS);


# Main daemon process.

while(1)
{
	my $connection = $daemon->accept;
	my $r = $connection->get_request();
	my $url = $r->uri->as_string;
	my $content;

	if ($url !~ /style.css$/i) {
        print $url."\n\n";
		$url = 'http://localhost:99'.$url;
        my $req;

		if ($r->method eq 'GET') {
			$req = new HTTP::Request GET => $url;
		}
		else {
			$req = new HTTP::Request POST => $url;
			$req->content_type($r->content_type);
			$req->content($r->content);
		}
	
		my $result = $usr_agent->request($req);
		$content = $result->content;
		$content = &doSubs($content);
		$cookie_jar->save();
	}
	else {
		$content = $css;
	}

	my $response = HTTP::Response->new();
	$response->content($content);

	$connection->send_response($response);
	$connection->close;
}


sub doSubs
{
	# Given a perlmonks page; instert stylesheet, syntax highligh code,
	# and apply cosmetic changes.
	
	$_ = shift;
	
	# Redirect to proxy addr/port. I set up a DNS entry for the local net
	# to do this invisibly. Much nicer if that's an option for you.
	
	s|www\.perlmonks\.org|$addr:$port|gi;
	
	# Insert stylesheet.
	
	s|<body|<link rel=stylesheet type="text/css" href="/style.css">\n<body|i;

	# Syntax highlight string between "code" tags (call subroutine).
	
	s|<PRE>(?:<TT>)?<FONT.*?>(.*?)</FONT>(?:</TT>)?</PRE>|'<PRE class="code">'.&syntaxHighlight($1).'</PRE>'|geis;
	
	# Custom cosmetic changes (feel free to insert/update here).
	
	s|#?silver|silver|gi;
	s|||gi;
	s|("checkbox")|$1 class="noborder"|gi;
	s|(INPUT type=radio class="noborder")|$1 class="noborder"|gi;
	s|("radio")|$1 class="noborder"|gi;
	s|<font size=2|<font style="text"|gi;
	s|(<TEXTAREA.*?cols=)\d+|$1 120|gi;

	return $_;
}


sub syntaxHighlight
{
	# Given some text and a hash of special replacemendts, highlight the Perl code
		
	my $text = pop;

	# Replace html special characters and any stray monestary tags. The formatter obj
	# will automatically throw html chars back in after format.
	
	my %reps = (
		'&amp;' => '&',
		'&lt;' => '<',
		'&gt;' => '>',
		'&#91;' => '[',
		'&#93;' => ']',
		'<FONT color="red">(?:.*?)</FONT>' => '+'
	);
	$text =~ s/$_/$reps{$_}/gis for keys %reps;
	
	# Format the string.
		
	$text = $formatter->format_string($text);

	# If the prev. code block ends in an unclosed string, POD, _DATA_, or other
	# structure, the formatter carries over and will start as _still in that block_.
	# So make sure to reset() the objects condition.

	$formatter->reset();
		
	return $text;
}


sub initFormatter
{
	# Initialise the formatter object
	
	# Run in stable mode. Stability means that the prev. state persists such as in
	# HTML tags.

	$formatter->unstable(0);
	
	# Substitutions keys get replaced by values _before_ formatting but _after_ being
	# interpretted for meaning (so we still have to replace beforehand manually).

	my %sub_html = (
		'&' => '&amp;',
		'<' => '&lt;',
		'>' => '&gt;'
	);
	$formatter->define_substitution(\%sub_html);
	
	# Using a list of all FORMAT elements supported by the object (I wish it had a method
	# to return this), create the start/end tags to use for the output. The format names
	# become the CSS class names.	

	my @formats = qw(
		Comment_Normal     Comment_POD          Directive
		Label              Quote                String
		Subroutine         Variable_Scalar      Variable_Array
		Variable_Hash      Variable_Typeglob    Character
		Keyword            Builtin_Function     Builtin_Operator
		Operator           Bareword             Package
		Number             Symbol               CodeTerm
		DATA
	);

	# NS4.x doesn't like underscores in CSS class names, but I couldn't get the s/_//
	# working properly (it kept renaming $formats($_) too). Not too worried as I use
	# a browser that supports it ;) Anyone who wants it please post an update.
	
	my %formats; $formats{$_} = ['<font class="'.$_.'">', '</font>'] for @formats;
	$formatter->set_format(%formats);
}