MottaTheHutt/gist:35c7fe610a5189ad7ee8

## gistfile1.pl
#!perl

use utf8;

#Motta Chat, modified from:
#>---------------------------------------<#
#| EveryChat 3.61 (rev. 1/20/01)         |#
#| Copyright (C) 1999 Matt Hahnfeld      |#
#>---------------------------------------<#

#>---------------------------------------<#
#| CONFIGURATION (MODIFY THIS SECTION)   |#
#>---------------------------------------<#

	my $filepath='C:/wamp/www/messages/';
	my $filext='.html';
	my $iecompatible=1;

#>---------------------------------------<#
#| Main Program                          |#
#| (all it does is call subprograms)     |#
#>---------------------------------------<#

print "Content-type: text/html\nPragma: no-cache\n\n";
print "<BODY BGCOLOR=#000000 TEXT=#FFFFFF>\n";
&getform;
if (&getoldfile) {
	#if (not &spamblock) {
	&printform;
	#}
	if ($form{'message'} ne "") { &printnewfile; }
}
else
{
	print "The room you entered <I>$form{'room'}</I> does not exist.<BR>\n";
	print "Tell the server administrator to check the file: <I>$filepath$form{'room'}$filext</I>\n";
}
print "</font></body></html>\n";
exit(0);

#>---------------------------------------<#
#| Sub getform - reads form data pairs   |#
#|               into %form              |#
#>---------------------------------------<#

sub getform {
	our $ip = $ENV{REMOTE_ADDR};

	my $buffer = "";
	read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'});
	my @pairs=split(/&/,$buffer);
	foreach my $pair (@pairs)
	{
		my @a = split(/=/,$pair);
		my $name=$a[0];
		my $value=$a[1];
		# Sanitation
		$value =~ s/\+/ /g;
		$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
		$value =~ s/~!/ ~!/g;
		$value =~ s/\</\&lt\;/g;
		$value =~ s/\>/\&gt\;/g;
		$value =~ s/[\r\n]//g;
		$value =~ s/\&\#0//g;
		# Links and font
		$value =~ s/(https?\:\/\/\S+)\s?/\<a href\=\"$1\" target=\"\_blank\" \>$1\<\/a\> /g;
		$value =~ s/\[i\](.*)\[\/i\]/\<i\>$1\<\/i\>/g;
		$value =~ s/\[u\](.*)\[\/u\]/\<u\>$1\<\/u\>/g;
		$value =~ s/\[size\=(1|2|3|4|5|6){1}\](.*?)\[\/size\]/\<font size\=\"$1\"\>$2\<\/font\>/g;
		$value =~ s/\[color\=([a-fA-F0-9]{3})\](.*?)\[\/color\]/\<font color\=\"\#$1\"\>$2\<\/font\>/g;
		# Emoticons
		$value =~ s/\:\)/\<img src\=\"\/smilies\/smile\.png\" \/\>/g;
		$value =~ s/\;\)/\<img src\=\"\/smilies\/wink\.png\" \/\>/g;
		$value =~ s/\:\(/\<img src\=\"\/smilies\/frown\.png\" \/\>/g;
		$value =~ s/\:p/\<img src\=\"\/smilies\/tongue\.png\" \/\>/g;
		$value =~ s/\:D/\<img src\=\"\/smilies\/biggrin\.gif\" \/\>/g;
		$value =~ s/\:rolleyes\:/\<img src\=\"\/smilies\/rolleyes\.png\" \/\>/g;
		$value =~ s/\:confused\:/\<img src\=\"\/smilies\/confused\.gif\" \/\>/g;
		$value =~ s/\:eek\:/\<img src\=\"\/smilies\/eek\.gif\" \/\>/g;
		$value =~ s/\:mad\:/\<img src\=\"\/smilies\/mad\.gif\" \/\>/g;
		$value =~ s/\:starwars\:/\<img src\=\"\/smilies\/starwars\.gif\" \/\>/g;
		$value =~ s/\:cool\:/\<img src\=\"\/smilies\/cool\.png\" \/\>/g;
		$value =~ s/\:catfight\:/\<img src\=\"\/smilies\/catfight\.gif\" \/\>/g;
		push (@data,$name);
		push (@data,$value);
	}
	our %form=@data;
	#%form;
}

#>---------------------------------------<#
#| Sub getoldfile - reads old HTML       |#
#| messages file and returns 0 if not    |#
#| found or 1 if found                   |#
#>---------------------------------------<#

sub getoldfile {
	$form{'room'} =~ s/\W//g;
	return 0 unless open(HTMLOLD, "$filepath$form{'room'}$filext");
	our @lines=<HTMLOLD>;
	close(HTMLOLD);
	return 1;
}

#>---------------------------------------<#
#| Sub printform - prints new form       |#
#>---------------------------------------<#

sub printform {
	print << "EOF";
	<br>
	<center><form action="$ENV{'SCRIPT_NAME'}" method="POST">
	<input name=username type=hidden value="$form{'username'}">
	<input name=room type=hidden value="$form{'room'}">
	<input name=color type=hidden value="$form{'color'}">
	<input type=text name=message autocomplete=OFF size="50,1" maxlength=255>
	<input type=submit value="Post This">
	</form></center>
EOF
}

#>---------------------------------------<#
#| Sub printnewfile - prints new HTML    |#
#| messages file                         |#
#>---------------------------------------<#

sub printnewfile {
	my $newmessage = "<b><font color\=\"\#$form{'color'}\">$ip $form{'username'}: $form{'message'}</font></b><br>\n";
	open (NEW, ">$filepath$form{'room'}$filext");
	print NEW "<META HTTP-EQUIV=\"Refresh\" CONTENT=\"4\"></HEAD><BODY bgcolor=\"000000\" text=\"ffffff\" link=\"00ff00\" vlink=\"ffab00\"><H2>Pokemon Chat</H2>\n";
	#print NEW "<p><H4>The newest messages are at the top.</p><H4>";
	if ($iecompatible) {
		print NEW $newmessage;
		for ($i = 1; $i < 25; $i++) {print NEW "$lines[$i]"}
	}
	else {
		for ($i = 2; $i < 26; $i++) {print NEW "$lines[$i]"}
		print NEW $newmessage;
	}
	close NEW;
}

#>---------------------------------------<#
#| Sub spamblock - WIP                   |#
#|                                       |#
#>---------------------------------------<#

sub spamblock {
	open (NEW, "<$filepath$form{'room'}$filext");
	if ( $lines[0] =~ m/^\<b\>\<font color\=\"\#([a-fA-F0-9]{6})\"\>$ip /g) {
		return true;
	}
	else {
		return false;
	}
}
	#!perl

	use utf8;

	#Motta Chat, modified from:
	#>---------------------------------------<#
	#\| EveryChat 3.61 (rev. 1/20/01) \|#
	#\| Copyright (C) 1999 Matt Hahnfeld \|#
	#>---------------------------------------<#

	#>---------------------------------------<#
	#\| CONFIGURATION (MODIFY THIS SECTION) \|#
	#>---------------------------------------<#

	my $filepath='C:/wamp/www/messages/';
	my $filext='.html';
	my $iecompatible=1;

	#>---------------------------------------<#
	#\| Main Program \|#
	#\| (all it does is call subprograms) \|#
	#>---------------------------------------<#

	print "Content-type: text/html\nPragma: no-cache\n\n";
	print "<BODY BGCOLOR=#000000 TEXT=#FFFFFF>\n";
	&getform;
	if (&getoldfile) {
	#if (not &spamblock) {
	&printform;
	#}
	if ($form{'message'} ne "") { &printnewfile; }
	}
	else
	{
	print "The room you entered <I>$form{'room'}</I> does not exist.<BR>\n";
	print "Tell the server administrator to check the file: <I>$filepath$form{'room'}$filext</I>\n";
	}
	print "</font></body></html>\n";
	exit(0);

	#>---------------------------------------<#
	#\| Sub getform - reads form data pairs \|#
	#\| into %form \|#
	#>---------------------------------------<#

	sub getform {
	our $ip = $ENV{REMOTE_ADDR};

	my $buffer = "";
	read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'});
	my @pairs=split(/&/,$buffer);
	foreach my $pair (@pairs)
	{
	my @a = split(/=/,$pair);
	my $name=$a[0];
	my $value=$a[1];
	# Sanitation
	$value =~ s/\+/ /g;
	$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
	$value =~ s/~!/ ~!/g;
	$value =~ s/\</\&lt\;/g;
	$value =~ s/\>/\&gt\;/g;
	$value =~ s/[\r\n]//g;
	$value =~ s/\&\#0//g;
	# Links and font
	$value =~ s/(https?\:\/\/\S+)\s?/\<a href\=\"$1\" target=\"\_blank\" \>$1\<\/a\> /g;
	$value =~ s/\[i\](.*)\[\/i\]/\<i\>$1\<\/i\>/g;
	$value =~ s/\[u\](.*)\[\/u\]/\<u\>$1\<\/u\>/g;
	$value =~ s/\[size\=(1\|2\|3\|4\|5\|6){1}\](.*?)\[\/size\]/\<font size\=\"$1\"\>$2\<\/font\>/g;
	$value =~ s/\[color\=([a-fA-F0-9]{3})\](.*?)\[\/color\]/\<font color\=\"\#$1\"\>$2\<\/font\>/g;
	# Emoticons
	$value =~ s/\:\)/\<img src\=\"\/smilies\/smile\.png\" \/\>/g;
	$value =~ s/\;\)/\<img src\=\"\/smilies\/wink\.png\" \/\>/g;
	$value =~ s/\:\(/\<img src\=\"\/smilies\/frown\.png\" \/\>/g;
	$value =~ s/\:p/\<img src\=\"\/smilies\/tongue\.png\" \/\>/g;
	$value =~ s/\:D/\<img src\=\"\/smilies\/biggrin\.gif\" \/\>/g;
	$value =~ s/\:rolleyes\:/\<img src\=\"\/smilies\/rolleyes\.png\" \/\>/g;
	$value =~ s/\:confused\:/\<img src\=\"\/smilies\/confused\.gif\" \/\>/g;
	$value =~ s/\:eek\:/\<img src\=\"\/smilies\/eek\.gif\" \/\>/g;
	$value =~ s/\:mad\:/\<img src\=\"\/smilies\/mad\.gif\" \/\>/g;
	$value =~ s/\:starwars\:/\<img src\=\"\/smilies\/starwars\.gif\" \/\>/g;
	$value =~ s/\:cool\:/\<img src\=\"\/smilies\/cool\.png\" \/\>/g;
	$value =~ s/\:catfight\:/\<img src\=\"\/smilies\/catfight\.gif\" \/\>/g;
	push (@data,$name);
	push (@data,$value);
	}
	our %form=@data;
	#%form;
	}

	#>---------------------------------------<#
	#\| Sub getoldfile - reads old HTML \|#
	#\| messages file and returns 0 if not \|#
	#\| found or 1 if found \|#
	#>---------------------------------------<#

	sub getoldfile {
	$form{'room'} =~ s/\W//g;
	return 0 unless open(HTMLOLD, "$filepath$form{'room'}$filext");
	our @lines=<HTMLOLD>;
	close(HTMLOLD);
	return 1;
	}

	#>---------------------------------------<#
	#\| Sub printform - prints new form \|#
	#>---------------------------------------<#

	sub printform {
	print << "EOF";
	<br>
	<center><form action="$ENV{'SCRIPT_NAME'}" method="POST">
	<input name=username type=hidden value="$form{'username'}">
	<input name=room type=hidden value="$form{'room'}">
	<input name=color type=hidden value="$form{'color'}">
	<input type=text name=message autocomplete=OFF size="50,1" maxlength=255>
	<input type=submit value="Post This">
	</form></center>
	EOF
	}

	#>---------------------------------------<#
	#\| Sub printnewfile - prints new HTML \|#
	#\| messages file \|#
	#>---------------------------------------<#

	sub printnewfile {
	my $newmessage = "<b><font color\=\"\#$form{'color'}\">$ip $form{'username'}: $form{'message'}</font></b><br>\n";
	open (NEW, ">$filepath$form{'room'}$filext");
	print NEW "<META HTTP-EQUIV=\"Refresh\" CONTENT=\"4\"></HEAD><BODY bgcolor=\"000000\" text=\"ffffff\" link=\"00ff00\" vlink=\"ffab00\"><H2>Pokemon Chat</H2>\n";
	#print NEW "<p><H4>The newest messages are at the top.</p><H4>";
	if ($iecompatible) {
	print NEW $newmessage;
	for ($i = 1; $i < 25; $i++) {print NEW "$lines[$i]"}
	}
	else {
	for ($i = 2; $i < 26; $i++) {print NEW "$lines[$i]"}
	print NEW $newmessage;
	}
	close NEW;
	}

	#>---------------------------------------<#
	#\| Sub spamblock - WIP \|#
	#\| \|#
	#>---------------------------------------<#

	sub spamblock {
	open (NEW, "<$filepath$form{'room'}$filext");
	if ( $lines[0] =~ m/^\<b\>\<font color\=\"\#([a-fA-F0-9]{6})\"\>$ip /g) {
	return true;
	}
	else {
	return false;
	}
	}