#!/usr/bin/perl

use strict;
use warnings;
use Carp;

my $IN;

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";
    }
    return;
}

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";
        }
    }
    return;
}

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";
        }
    }
    return;
}

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);
    }
    return;
}

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();
    return;
}

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

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 SYNOPSIS

wmlsd I<file>

=head1 DESCRIPTION

B<wmlsd> disassembles binary form of WMLScript file.

WAP Specifications are available on L<http://www.wapforum.org/>.

=head1 SEE ALSO

 wmlsc

=head1 COPYRIGHT

(c) 2002-2006 Francois PERRAD, France.

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

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

=head1 AUTHOR

Francois PERRAD

=cut