#!/usr/bin/perl -w

use strict;
use Carp;

my %OpCode = (
#	0x00
	0x01 => [ "JUMP_FW",		0, 1, 0, 0 ],
	0x02 => [ "JUMP_FW_W",		0, 2, 0, 0 ],
	0x03 => [ "JUMP_BW",		0, 1, 0, 0 ],
	0x04 => [ "JUMP_BW_W",		0, 2, 0, 0 ],
	0x05 => [ "TJUMP_FW",		0, 1, 0, 0 ],
	0x06 => [ "TJUMP_FW_W",		0, 2, 0, 0 ],
	0x07 => [ "TJUMP_BW",		0, 1, 0, 0 ],
	0x08 => [ "TJUMP_BW_W",		0, 2, 0, 0 ],
	0x09 => [ "CALL",			0, 1, 0, 0 ],
	0x0A => [ "CALL_LIB",		0, 1, 1, 0 ],
	0x0B => [ "CALL_LIB_W",		0, 1, 2, 0 ],
	0x0C => [ "CALL_URL",		0, 1, 1, 1 ],
	0x0D => [ "CALL_URL_W",		0, 2, 2, 1 ],
	0x0E => [ "LOAD_VAR",		0, 1, 0, 0 ],
	0x0F => [ "STORE_VAR",		0, 1, 0, 0 ],
	0x10 => [ "INCR_VAR",		0, 1, 0, 0 ],
	0x11 => [ "DECR_VAR",		0, 1, 0, 0 ],
	0x12 => [ "LOAD_CONST",		0, 1, 0, 0 ],
	0x13 => [ "LOAD_CONST_W",	0, 2, 0, 0 ],
	0x14 => [ "CONST_0",		0, 0, 0, 0 ],
	0x15 => [ "CONST_1",		0, 0, 0, 0 ],
	0x16 => [ "CONST_M1",		0, 0, 0, 0 ],
	0x17 => [ "CONST_ES",		0, 0, 0, 0 ],
	0x18 => [ "CONST_INVALID",	0, 0, 0, 0 ],
	0x19 => [ "CONST_TRUE",		0, 0, 0, 0 ],
	0x1A => [ "CONST_FALSE",	0, 0, 0, 0 ],
	0x1B => [ "INCR",			0, 0, 0, 0 ],
	0x1C => [ "DECR",			0, 0, 0, 0 ],
	0x1D => [ "ADD_ASG",		0, 1, 0, 0 ],
	0x1E => [ "SUB_ASG",		0, 1, 0, 0 ],
	0x1F => [ "UMINUS",			0, 0, 0, 0 ],
	0x20 => [ "ADD",			0, 0, 0, 0 ],
	0x21 => [ "SUB",			0, 0, 0, 0 ],
	0x22 => [ "MUL",			0, 0, 0, 0 ],
	0x23 => [ "DIV",			0, 0, 0, 0 ],
	0x24 => [ "IDIV",			0, 0, 0, 0 ],
	0x25 => [ "REM",			0, 0, 0, 0 ],
	0x26 => [ "B_AND",			0, 0, 0, 0 ],
	0x27 => [ "B_OR",			0, 0, 0, 0 ],
	0x28 => [ "B_XOR",			0, 0, 0, 0 ],
	0x29 => [ "B_NOT",			0, 0, 0, 0 ],
	0x2A => [ "B_LSHIFT",		0, 0, 0, 0 ],
	0x2B => [ "B_RSSHIFT",		0, 0, 0, 0 ],
	0x2C => [ "B_RSZSHIFT",		0, 0, 0, 0 ],
	0x2D => [ "EQ",				0, 0, 0, 0 ],
	0x2E => [ "LE",				0, 0, 0, 0 ],
	0x2F => [ "LT",				0, 0, 0, 0 ],
	0x30 => [ "GE",				0, 0, 0, 0 ],
	0x31 => [ "GT",				0, 0, 0, 0 ],
	0x32 => [ "NE",				0, 0, 0, 0 ],
	0x33 => [ "NOT",			0, 0, 0, 0 ],
	0x34 => [ "SCAND",			0, 0, 0, 0 ],
	0x35 => [ "SCOR",			0, 0, 0, 0 ],
	0x36 => [ "TOBOOL",			0, 0, 0, 0 ],
	0x37 => [ "POP",			0, 0, 0, 0 ],
	0x38 => [ "TYPEOF",			0, 0, 0, 0 ],
	0x39 => [ "ISVALID",		0, 0, 0, 0 ],
	0x3A => [ "RETURN",			0, 0, 0, 0 ],
	0x3B => [ "RETURN_ES",		0, 0, 0, 0 ],
	0x3C => [ "DEBUG",			0, 0, 0, 0 ],
#	0x3D
#	0x3E
#	0x3F
	0x40 => [ "STORE_VAR_S",	4, 0, 0, 0 ],
	0x41 => 0x40,
	0x42 => 0x40,
	0x43 => 0x40,
	0x44 => 0x40,
	0x45 => 0x40,
	0x46 => 0x40,
	0x47 => 0x40,
	0x48 => 0x40,
	0x49 => 0x40,
	0x4A => 0x40,
	0x4B => 0x40,
	0x4C => 0x40,
	0x4D => 0x40,
	0x4E => 0x40,
	0x4F => 0x40,
	0x50 => [ "LOAD_CONST_S",	4, 0, 0, 0 ],
	0x51 => 0x50,
	0x52 => 0x50,
	0x53 => 0x50,
	0x54 => 0x50,
	0x55 => 0x50,
	0x56 => 0x50,
	0x57 => 0x50,
	0x58 => 0x50,
	0x59 => 0x50,
	0x5A => 0x50,
	0x5B => 0x50,
	0x5C => 0x50,
	0x5D => 0x50,
	0x5E => 0x50,
	0x5F => 0x50,
	0x60 => [ "CALL_S",			3, 0, 0, 0 ],
	0x61 => 0x60,
	0x62 => 0x60,
	0x63 => 0x60,
	0x64 => 0x60,
	0x65 => 0x60,
	0x66 => 0x60,
	0x67 => 0x60,
	0x68 => [ "CALL_LIB_S",		3, 1, 0, 0 ],
	0x69 => 0x68,
	0x6A => 0x68,
	0x6B => 0x68,
	0x6C => 0x68,
	0x6D => 0x68,
	0x6E => 0x68,
	0x6F => 0x68,
	0x70 => [ "INCR_VAR_S",		3, 0, 0, 0 ],
	0x71 => 0x70,
	0x72 => 0x70,
	0x73 => 0x70,
	0x74 => 0x70,
	0x75 => 0x70,
	0x76 => 0x70,
	0x77 => 0x70,
#	0x78
#	0x79
#	0x7A
#	0x7B
#	0x7C
#	0x7D
#	0x7E
#	0x7F
	0x80 => [ "JUMP_FW_S",		5, 0, 0, 0 ],
	0x81 => 0x80,
	0x82 => 0x80,
	0x83 => 0x80,
	0x84 => 0x80,
	0x85 => 0x80,
	0x86 => 0x80,
	0x87 => 0x80,
	0x88 => 0x80,
	0x89 => 0x80,
	0x8A => 0x80,
	0x8B => 0x80,
	0x8C => 0x80,
	0x8D => 0x80,
	0x8E => 0x80,
	0x8F => 0x80,
	0x90 => 0x80,
	0x91 => 0x80,
	0x92 => 0x80,
	0x93 => 0x80,
	0x94 => 0x80,
	0x95 => 0x80,
	0x96 => 0x80,
	0x97 => 0x80,
	0x98 => 0x80,
	0x99 => 0x80,
	0x9A => 0x80,
	0x9B => 0x80,
	0x9C => 0x80,
	0x9D => 0x80,
	0x9E => 0x80,
	0x9F => 0x80,
	0xA0 => [ "JUMP_BW_S",		5, 0, 0, 0 ],
	0xA1 => 0xA0,
	0xA2 => 0xA0,
	0xA3 => 0xA0,
	0xA4 => 0xA0,
	0xA5 => 0xA0,
	0xA6 => 0xA0,
	0xA7 => 0xA0,
	0xA8 => 0xA0,
	0xA9 => 0xA0,
	0xAA => 0xA0,
	0xAB => 0xA0,
	0xAC => 0xA0,
	0xAD => 0xA0,
	0xAE => 0xA0,
	0xAF => 0xA0,
	0xB0 => 0xA0,
	0xB1 => 0xA0,
	0xB2 => 0xA0,
	0xB3 => 0xA0,
	0xB4 => 0xA0,
	0xB5 => 0xA0,
	0xB6 => 0xA0,
	0xB7 => 0xA0,
	0xB8 => 0xA0,
	0xB9 => 0xA0,
	0xBA => 0xA0,
	0xBB => 0xA0,
	0xBC => 0xA0,
	0xBD => 0xA0,
	0xBE => 0xA0,
	0xBF => 0xA0,
	0xC0 => [ "TJUMP_FW_S",		5, 0, 0, 0 ],
	0xC1 => 0xC0,
	0xC2 => 0xC0,
	0xC3 => 0xC0,
	0xC4 => 0xC0,
	0xC5 => 0xC0,
	0xC6 => 0xC0,
	0xC7 => 0xC0,
	0xC8 => 0xC0,
	0xC9 => 0xC0,
	0xCA => 0xC0,
	0xCB => 0xC0,
	0xCC => 0xC0,
	0xCD => 0xC0,
	0xCE => 0xC0,
	0xCF => 0xC0,
	0xD0 => 0xC0,
	0xD1 => 0xC0,
	0xD2 => 0xC0,
	0xD3 => 0xC0,
	0xD4 => 0xC0,
	0xD5 => 0xC0,
	0xD6 => 0xC0,
	0xD7 => 0xC0,
	0xD8 => 0xC0,
	0xD9 => 0xC0,
	0xDA => 0xC0,
	0xDB => 0xC0,
	0xDC => 0xC0,
	0xDD => 0xC0,
	0xDE => 0xC0,
	0xDF => 0xC0,
	0xE0 => [ "LOAD_VAR_S",		5, 0, 0, 0 ],
	0xE1 => 0xE0,
	0xE2 => 0xE0,
	0xE3 => 0xE0,
	0xE4 => 0xE0,
	0xE5 => 0xE0,
	0xE6 => 0xE0,
	0xE7 => 0xE0,
	0xE8 => 0xE0,
	0xE9 => 0xE0,
	0xEA => 0xE0,
	0xEB => 0xE0,
	0xEC => 0xE0,
	0xED => 0xE0,
	0xEE => 0xE0,
	0xEF => 0xE0,
	0xF0 => 0xE0,
	0xF1 => 0xE0,
	0xF2 => 0xE0,
	0xF3 => 0xE0,
	0xF4 => 0xE0,
	0xF5 => 0xE0,
	0xF6 => 0xE0,
	0xF7 => 0xE0,
	0xF8 => 0xE0,
	0xF9 => 0xE0,
	0xFA => 0xE0,
	0xFB => 0xE0,
	0xFC => 0xE0,
	0xFD => 0xE0,
	0xFE => 0xE0,
	0xFF => 0xE0
);

sub CodeArray {
	my ($size) = @_;
	while ($size --) {
		my $opcode =  get_uint8();
		croak "Undefined opcope $opcode.\n"
				unless (exists $OpCode{$opcode});
		my $desc = $OpCode{$opcode};
		$desc = $OpCode{$desc} unless (ref $desc);
		my $nmemo = sprintf("%-12s",${$desc}[0]);
		print $nmemo;
		my $arg = ${$desc}[1];
		if      ($arg == 0) {
		} elsif ($arg == 3) {
			print sprintf("%7u",$opcode % 0x08);
		} elsif ($arg == 4) {
			print sprintf("%7u",$opcode % 0x10);
		} elsif ($arg == 5) {
			print sprintf("%7u",$opcode % 0x20);
		} else {
			croak "INTERNAL ERROR in CodeArray ($arg).\n";
		}
		foreach (@{$desc}[2..4]) {
			if      ($_ == 0) {
				last;
			} elsif ($_ == 1) {
				print sprintf("%7u",get_uint8());
				$size -= 1;
			} elsif ($_ == 2) {
				$size -= 2;
				print sprintf("%7u",get_uint16());
			} else {
				croak "INTERNAL ERROR in CodeArray ($_).\n";
			}
		}
		print "\n";
	}
}

sub ConstantPool {
	print "## Constant Pool\n";
	print "##\n";
	my $NumberOfConstants = get_mb();
	print "NumberOfConstants ",$NumberOfConstants,"\n";
	my $CharacterSet = get_mb();
	print "CharacterSet ",$CharacterSet,"\n";
	for (my $idx = 0; $idx < $NumberOfConstants; $idx++) {
		my $ConstantType = get_uint8();
		if      ($ConstantType == 0) {
			my $value = get_int8();
			print "cst",$idx," int8 ",$value,"\n";
		} elsif ($ConstantType == 1) {
			my $value = get_int16();
			print "cst",$idx," int16 ",$value,"\n";
		} elsif ($ConstantType == 2) {
			my $value = get_int32();
			print "cst",$idx," int32 ",$value,"\n";
		} elsif ($ConstantType == 3) {
			my $value = get_float32();
			print "cst",$idx," float32 ",$value,"\n";
		} elsif ($ConstantType == 4) {
			my $size = get_mb();
			my $str = get_string($size);
			print "cst",$idx," UTF8 string [",$size,"] ",$str,"\n";
		} elsif ($ConstantType == 5) {
			print "cst",$idx," Empty String\n";
		} elsif ($ConstantType == 6) {
			my $size = get_mb();
			my $str = get_string($size);
			print "cst",$idx," string [",$size,"] ",$str,"\n";
		} else {
			croak "Invalid ConstantType $ConstantType.\n";
		}
	}
}

sub PragmaPool {
	print "## Pragma Pool\n";
	print "##\n";
	my $NumberOfPragmas = get_mb();
	print "NumberOfPragmas ",$NumberOfPragmas,"\n";
	while ($NumberOfPragmas --) {
		my $PragmaType = get_uint8();
		if      ($PragmaType == 0) {
			my $AccessDomainIndex = get_mb();
			print "Acces Domain ",$AccessDomainIndex,"\n";
		} elsif ($PragmaType == 1) {
			my $AccessPathIndex = get_mb();
			print "Acces Path ",$AccessPathIndex,"\n";
		} elsif ($PragmaType == 2) {
			my $PropertyNameIndex = get_mb();
			my $ContentIndex = get_mb();
			print "User Agent Property ",$PropertyNameIndex," ",$ContentIndex,"\n";
		} elsif ($PragmaType == 3) {
			my $PropertyNameIndex = get_mb();
			my $ContentIndex = get_mb();
			my $SchemeIndex = get_mb();
			print "User Agent Property and Scheme ",$PropertyNameIndex," ",$ContentIndex," ",$SchemeIndex,"\n";
		} else {
			croak "Invalid PragmaType $PragmaType.\n";
		}
	}
}

sub FunctionPool {
	print "## Function Pool\n";
	print "##\n";
	my $NumberOfFunctions = get_uint8();
	print "NumberOfFunctions ",$NumberOfFunctions,"\n";
	print "## Function Name Table\n";
	my $NumberOfFunctionNames = get_uint8();
	print "NumberOfFunctionNames ",$NumberOfFunctionNames,"\n";
	for (my $idx = 0; $idx < $NumberOfFunctionNames; $idx ++) {
		my $FunctionIndex = get_uint8();
		my $FunctionNameSize = get_uint8();
		my $str = get_string($FunctionNameSize);
		print $FunctionIndex," ",$FunctionNameSize," ",$str,"\n";
	}
	for (my $idx = 0; $idx < $NumberOfFunctions; $idx++) {
		print "## function ",$idx,"\n";
		my $NumberOfArguments = get_uint8();
		print "NumberOfArgument ",$NumberOfArguments,"\n";
		my $NumberOfLocalVariables = get_uint8();
		print "NumberOfLocalVariables ",$NumberOfLocalVariables,"\n";
		my $FunctionSize = get_mb();
		print "FunctionSize ",$FunctionSize,"\n";
		CodeArray($FunctionSize);
	}
}

sub disassembler {
	use integer;
	print "## Bytecode Header\n";
	print "##\n";
	my $VersionNumber = get_uint8();
	my $major = 1 + $VersionNumber / 16;
	my $minor = $VersionNumber % 16;
	print "VersionNumber ",$major,".",$minor,"\n";
	my $CodeSize = get_mb();
	print "CodeSize ",$CodeSize,"\n";
	ConstantPool();
	PragmaPool();
	FunctionPool();
}

###############################################################################

sub get_int8 {
	my $str;
	read IN, $str, 1;
	return unpack "c", $str;
}

sub get_uint8 {
	my $str;
	read IN, $str, 1;
	return unpack "C", $str;
}

sub get_int16 {
	my $str;
	read IN, $str, 2;
	return unpack "s", pack "v", unpack "n", $str;
}

sub get_uint16 {
	my $str;
	read IN, $str, 2;
	return unpack "n", $str;
}

sub get_int32 {
	my $str;
	read IN, $str, 4;
	return unpack "l", pack "V", unpack "N", $str;
}

sub get_float32 {
	my $str;
	read IN, $str, 4;
	return unpack "f", $str;
}

sub get_string {
	my ($len) = @_;
	my $str;
	read IN, $str, $len;
	return $str;
}

sub get_mb {
	my $byte;
	my $val = 0;
	my $nb = 0;
	do {
		$nb ++;
#		return undef unless ($nb < 6);
#		my $ch = getc(IN);
#		return undef unless (defined $ch);
#		$byte = ord $ch;
		$byte = get_uint8();
		$val <<= 7;
		$val += ($byte & 0x7f);
	}
	while (0 != ($byte & 0x80));
	return $val
}

###############################################################################

my $filename = $ARGV[0];
die "Usage: wmlsd file.wmlsc\n"
		unless (defined $filename);
open IN,"<$filename"
		or die "can't open $filename ($!).\n";
binmode IN,":raw";
print "## file:",$filename,"\n";
print "##\n";
disassembler();
close IN;

__END__

=head1 NAME

wmlsd - WMLScript Disassembler

=head1 SYNOPSYS

wmlsd I<file>

=head1 DESCRIPTION

B<wmlsd> disassembles binary form of WMLScript file.

WAP Specifications are available on E<lt>http://www.wapforum.org/E<gt>.

=head1 SEE ALSO

 perl, wmlsc

=head1 COPYRIGHT

(c) 2002 Francois PERRAD, France. All rights reserved.

This program is distributed
under the terms of the Artistic Licence.

The WAP Specification are copyrighted by the Wireless Application Protocol Forum Ltd.
See E<lt>http://www.wapforum.org/what/copyright.htmE<gt>.

=head1 AUTHOR

Francois PERRAD E<lt>perrad@besancon.sema.slb.comE<gt>

=cut

