#!/usr/bin/perl -Tw
# Copyright (c) 2007, Gregory Fleischer (gfleischer@gmail.com)
#
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
#
# 1. Redistributions of source code must retain the above copyright
# notice, this list of conditions and the following disclaimer.
# 2. Redistributions in binary form must reproduce the above copyright
# notice, this list of conditions and the following disclaimer in
# the documentation and/or other materials provided with the
# distribution.
# 3. The names of the authors may not be used to endorse or promote
# products derived from this software without specific prior
# written permission.
#
# THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
# IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
use strict;
use Fcntl;
my @charsets = ('iso-8859-1', 'us-ascii', 'utf-7', 'utf-8');
my @non_printable_chars = (0xff, 0x7f, 0x03, 0x00); # 0x00 causes problems with Opera make leave for the end
my $use_full_list = 1; # use the full list of mime types
my $add_accept_charset = 0; # add the accept charset
my @mime_types;
my $debug = 0;
eval {
if ($use_full_list) {
@mime_types = @{&all_mime_types()};
} else {
@mime_types = (
'application/x-www-form-urlencoded',
'multipart/form-data',
'text/plain',
'multipart/example',
'example/form-data',
'text/example',
'example/plain',
'example/example'
);
}
my %params = ¶ms();
my $submit = $params{submit};
my $charset = lc($params{charset});
$charset ||= 'iso-8859-1';
my $found = 0;
foreach my $c (@charsets) {
if ($c eq $charset) {
$charset = $c;
$found = 1;
last;
}
}
if (!$found) {
die "unsupported charset: $charset";
}
if ($submit=~/^(\d+)$/) {
my $current = $1;
if ($submit > $#mime_types) {
die "submit out of range: $submit";
}
&log($current, $charset);
my $next = $current + 1;
&page($next, $charset, "");
} elsif ($submit=~/^start$/) {
&page(0, $charset, "");
} elsif (exists($params{'test'})) {
my $test = $params{'test'};
my $ndx = -1;
foreach my $i (0 .. $#mime_types + 1) {
if (lc($test) eq lc($mime_types[$i])) {
$ndx = $i;
last;
}
}
if (-1 == $ndx) {
die "bad test: $test";
}
&page($ndx, $charset, $test);
} elsif (exists $params{dump}) {
print "Content-Type: text/html; charset=iso-8859-1\r\n\r\n";
print "";
print "\n";
foreach my $mt (sort @{&all_mime_types()}) {
print "$mt\n";
}
print "\n";
print "";
} else {
die "bad query";
}
};
if ($@) {
if (!$debug) {
$@=~s/ at .*$//;
}
print "Content-Type: text/html; charset=iso-8859-1\r\n\r\n";
print "$@
\n";
if ($debug) {
print "<![CDATA[\n";
while (my ($k,$v) = each(%ENV)) {
print "$k: $v\n";
}
print "]]>";
}
print "\n";
}
sub log {
my $current = shift();
my $charset = shift();
my $type = $mime_types[$current];
$type=~s/\//-/g;
my $ua = $ENV{'HTTP_USER_AGENT'};
if ($ua =~ /\.\.[\\\/]/) {
die "bad user agent: $ua";
}
if ($ua =~ /^(.+)\s*$/) {
$ua = $1;
}
$ua=~s/\W+/_/g;
my $dir = "log/$charset/$ua/";
if (! -d $dir) {
mkdir($dir, 0775) or die "failed to mkdir($dir): $!";
open(OF, ">", "$dir/user-agent") or die "$type: $!";
print OF $ENV{'HTTP_USER_AGENT'}, "\n";
close(OF);
}
umask(002);
sysopen(LOG, "./$dir/$type", O_WRONLY|O_CREAT|O_APPEND, 0764) or die "$type: $!";
print LOG "=" x 32, "\n";
foreach my $e ('CONTENT_TYPE') {
print LOG "$e: " , $ENV{$e}, "\n";
}
while () {
print LOG $_;
}
print LOG "\n";
close(LOG);
}
sub params {
my $query = $ENV{QUERY_STRING};
if ($query=~/utf-/ && $ENV{'HTTP_USER_AGENT'}=~/MSIE/) {
# ghetto
$query=~s/\+AD0-/=/g;
$query=~s/\+ACY-/&/g;
}
$query=~s/\#.*$//;
my @pairs = split(/\&/, $query);
my %params = ();
foreach my $pair (@pairs) {
my ($key, $value) = split(/=/, $pair);
$key=~s/%([0-9A-Fa-f]{2})/chr(hex($1))/ge;
$value=~s/%([0-9A-Fa-f]{2})/chr(hex($1))/ge;
if (exists $params{$key}) {
$params{$key} .= "," . $value;
} else {
$params{$key} = $value;
}
}
return %params;
}
sub page {
my $next = shift();
my $charset = shift();
my $test = shift();
my $content_type = "text/html; charset=iso-8859-1";
if ($next > $#mime_types) {
my $ndx = -1;
foreach my $i (0..$#charsets + 1) {
if (lc($charset) eq lc($charsets[$i])) {
$ndx = $i;
last;
}
}
if ($ndx == -1 || $ndx >= $#charsets) {
print "Content-Type: $content_type\r\n\r\n";
print "completed
\n";
} else {
my $next_charset = $charsets[$ndx+1];
# print "Status: 302 Moved\r\n";
print "Content-Type: $content_type\r\n";
print "Location: mime-chucker.cgi?submit=start&charset=${next_charset}\r\n\r\n";
}
return;
}
my $action = "mime-chucker.cgi?submit=${next}&charset=${charset}";
if ($test) {
$action = "env.cgi";
}
print "Content-Type: $content_type\r\n";
print "Cache-Control: no-cache, no-store\r\n";
print "Max-Age: 0\r\n";
print "\r\n";
print "\n";
print "\n";
if (!$test) {
if ($ENV{HTTP_USER_AGENT} !~ /^Opera.*Windows/i) { # Opera gets confused
print "\n";
}
}
print "$action\n";
print "\n";
print "\n";
print "\n";
print "