#!/usr/bin/perl
# Windows Scripting Decoder
#
# 16/11/2000, Stephanie Wehner, _@r4k.net 
#
# Note that this does not attempt to be a nice decoder and produce
# nicely formatted output. It's just a demo, your milage may vary.
# 
# Usage: dec.pl [infile] [outfile]
#
# $Id: dec.pl,v 1.3 2001/04/06 11:25:23 _ Exp _ $

use strict;

# pattern, auto generated by make_pat
my @pat = (1,2,0,1,2,0,2,0,0,2,0,2,1,0,2,0,1,0,2,0,1,1,2,0,0,2,1,0,2,0,0,2,1,1,0,2,0,2,0,1,0,1,1,2,0,1,0,2,1,0,2,0,1,1,2,0,0,1,1,2,0,1,0,2);

# list auto generated by make_list, some of this probably newer occurs
# but oh well
my %code = (
0 => [0,0,0],
1 => [1,1,1],
2 => [2,2,2],
3 => [3,3,3],
4 => [4,4,4],
5 => [5,5,5],
6 => [6,6,6],
7 => [7,7,7],
8 => [8,8,8],
9 => [123,87,110],
10 => [0,0,0],
11 => [11,11,11],
12 => [12,12,12],
13 => [0,0,0],
14 => [14,14,14],
15 => [15,15,15],
16 => [16,16,16],
17 => [17,17,17],
18 => [18,18,18],
19 => [19,19,19],
20 => [20,20,20],
21 => [21,21,21],
22 => [22,22,22],
23 => [23,23,23],
24 => [24,24,24],
25 => [25,25,25],
26 => [26,26,26],
27 => [27,27,27],
28 => [28,28,28],
29 => [29,29,29],
30 => [30,30,30],
31 => [31,31,31],
32 => [50,46,45],
33 => [48,71,117],
34 => [33,122,82],
35 => [41,86,96],
36 => [91,66,113],
37 => [56,106,94],
38 => [51,47,73],
39 => [61,38,92],
40 => [88,73,98],
41 => [58,65,125],
42 => [53,52,41],
43 => [101,50,54],
44 => [57,91,32],
45 => [92,118,124],
46 => [86,114,122],
47 => [115,67,0],
48 => [102,56,107],
49 => [78,57,99],
50 => [69,112,51],
51 => [107,69,43],
52 => [98,104,104],
53 => [89,113,81],
54 => [120,79,102],
55 => [94,9,118],
56 => [125,98,49],
57 => [74,68,100],
58 => [109,35,84],
59 => [113,117,67],
60 => [0,0,0],
61 => [96,126,58],
62 => [0,0,0],
63 => [83,94,126],
64 => [0,0,0],
65 => [66,119,69],
66 => [39,74,44],
67 => [72,97,42],
68 => [114,93,116],
69 => [117,34,39],
70 => [49,75,55],
71 => [55,111,68],
72 => [77,78,121],
73 => [82,59,89],
74 => [34,76,47],
75 => [84,80,111],
76 => [106,103,38],
77 => [71,42,114],
78 => [100,125,106],
79 => [45,116,57],
80 => [32,84,123],
81 => [0,43,63],
82 => [46,45,56],
83 => [76,44,119],
84 => [93,48,103],
85 => [126,110,83],
86 => [108,107,71],
87 => [111,102,52],
88 => [121,53,120],
89 => [116,37,93],
90 => [67,33,48],
91 => [38,100,35],
92 => [118,77,90],
93 => [37,82,91],
94 => [36,99,108],
95 => [43,63,72],
96 => [40,123,85],
97 => [35,120,112],
98 => [65,41,105],
99 => [52,40,46],
100 => [9,115,76],
101 => [42,89,33],
102 => [68,51,36],
103 => [63,0,78],
104 => [119,109,80],
105 => [59,85,9],
106 => [85,83,86],
107 => [105,124,115],
108 => [97,58,53],
109 => [99,95,97],
110 => [80,101,75],
111 => [103,70,88],
112 => [81,88,59],
113 => [73,49,87],
114 => [79,105,34],
115 => [70,108,109],
116 => [104,90,77],
117 => [124,72,37],
118 => [54,39,40],
119 => [112,92,70],
120 => [110,61,74],
121 => [122,36,50],
122 => [47,121,65],
123 => [95,55,61],
124 => [75,96,95],
125 => [90,81,79],
126 => [44,32,66],
127 => [87,54,101]
);

# some state indicators
my $encode = 0;
my $get_name = 0;
my $decoding = 0;
my $to_decode = "";
my($l);

# print banner
print "Windows Scripting Decoder v0.3 <_\@r4k.net>\n";

# first of all check if the arguments are ok
if($#ARGV < 1) {
	print STDERR "\nUsage: dec.pl [infile] [outfile]\n";
	exit(-1);
}

# open the desired files
unless(open(IN,"<$ARGV[0]")) {
	print STDERR "Unable to input file " . $ARGV[0] . ": " . $! . "\n";
	exit(-1);
}

unless(open(OUT,">$ARGV[1]")) {
	print STDERR "Unable to output file " . $ARGV[0] . ": " . $! . "\n";
	exit(-1);
}

print "Decoding...\n";

# walk through the file and look for encoded sections to be replaced
while(<IN>) {

	# if only <% on line, don't look further
	if(/^\s*<%\s*$/) {
		next;
	}

	# Check for the encoding mark/tag
	if((/<script\s*language\s*=\s*(\S+)\.encode"*\s*>/i) ||
		(/<%@*\s*language\s*=\s*(\S+)\.encode"*\s*%>/i)) {

		# encoding header found, start to look for encoded parts
		$encode = 1;

		# make a new header
		print OUT "<script language=\"" . $1 . "\">\n";

	} elsif ((/<script\s*(language)*\s*=*\s*"*\s*$/i)) {

		# start seen, expect name on the start of the next line
		$get_name = 1;

	} elsif (($get_name == 1) && (/.*?(\S+).encode\s*"*\s*%*>/i)) {

		# encoding header finally found
		$get_name = 0;
		$encode = 1;
	}


	# Check if this line contains things that need decoding
	if(($encode == 1) && ((/<%/) || (/Start Encode/) || (/#@~/)) && ($decoding == 0)){

		# Cut out all actual encoded parts
		$l = $_;

		# If it's all on one line, just decode it
		while($l =~ /^(.*?)<*%*('\*\*Start Encode\*\*)*(=)*#@~\^[\/0-9a-zA-Z]+==(.*?).{3}A*AA==\^#~@%*>*(.*)$/) {
			print OUT $1  . "<%" . $3;
			decode_string($4);	
			print OUT "%>";
			$l = $5;
		} 

		# check if the rest still contains the start of a new encoded string
		if($l =~ /^(.*?)(<%)*('\*\*Start Encode\*\*)*(=*)#@~\^[\/0-9a-zA-Z]+==(.*?)$/) {
			print OUT $1 . "<%" . $4;
			$to_decode = $to_decode . $5;
			$decoding = 1;
		} else {	
			print OUT $l . "\n";
		}
		
	} elsif ($decoding == 1) {

		$l = $_;

		# if this line doesn't bring the end, keep collecting
		if(!(/(.{3})*A*AA==\^#~@%*>*/)) {
			$to_decode = $to_decode . $_;
			next;
		} elsif(/^(.*?)(.{3})*A*AA==\^#~@%*>*(.*)$/) {
			$to_decode = $to_decode .  $1;
			decode_string($to_decode);
			$to_decode = "";
			print OUT "%>";
			$l = $3;
			$decoding = 0;
		}

		# If it's all on one line, just decode it
		while($l =~ /^(.*?)<*%*('\*\*Start Encode\*\*)*(=)*#@~\^[\/0-9a-zA-Z]+==(.*?).{3}A*AA==\^#~@%*>*(.*)$/) {
			print OUT $1  . "<%" . $3;
			decode_string($4);	
			print OUT "%>";
			$l = $5;
		} 

                # check if the rest still contains the start of a new encoded string
                if($l =~ /^(.*?)(<%)*('\*\*Start Encode\*\*)*(=*)#@~\^[\/0-9a-zA-Z]+==(.*?)$/) {
                        print OUT $1 . "<%" . $4;
                        $to_decode = $to_decode . $5 . "\n";
                        $decoding = 1;
                } else {
                        print OUT $l . "\n";
                }

	} else {

		# if this line doesn't contain encoded things, just print it
		print OUT $_;
	}

	# if this line contains a </script> end looking for encoded parts
	if(/<\/script>/) {
		$encode = 0;
	}
}

close(IN);
close(OUT);

print "Done\n";

exit(0);

# This function does the actual decoding. For each char found, determine
# which char it needs to be decoded to, depending on the current position 
# in the pattern

sub
decode_string
{
	my($in) = @_;
	my($i, $c, $pos, $mod);
 	my $length = length($in);
	my $s = 0;
	my $new;

	if($in eq "") {
		print "Regexp Failed\n";
		return;
	}

	# cut out all new lines, since they don't count 
	$in =~ s/\n//g;

	for($i = 0;$i < $length;$i++) {
		
		$c = substr($in,$i,1);

		# check which char it is
		if($s == 0) {
			
			if ($c eq "@") {
				$s = 1;
                        } elsif (ord($c) < 128) {
				$mod = $pos % 64;
				print OUT chr($code{ord($c)}[$pat[$mod]]);
				$pos++;
			} else {
                          $mod = $pos % 64;
                          print OUT $c;
                        }

		} elsif ($s == 1) {

			if($c eq "#") {
				print OUT "\r";
			} elsif($c eq "&") {
				print OUT "\n";
			} elsif($c eq "!") {
				print OUT "<";
			} elsif($c eq "*") {
				print OUT ">";
			}
			# other @ not of interest
			$s = 0;
			$pos++;
				
		} 
	}
}