mirror of
https://github.com/libretro/scummvm.git
synced 2024-12-15 22:28:10 +00:00
472 lines
13 KiB
Perl
472 lines
13 KiB
Perl
#!/usr/bin/perl
|
|
|
|
###############################################################################
|
|
# #
|
|
# Copyright (C) 2006 by Mark J. Tilford #
|
|
# #
|
|
# This file is part of Geas. #
|
|
# #
|
|
# Geas is free software; you can redistribute it and/or modify #
|
|
# it under the terms of the GNU General Public License as published by #
|
|
# the Free Software Foundation; either version 2 of the License, or #
|
|
# (at your option) any later version. #
|
|
# #
|
|
# Geas is distributed in the hope that it will be useful, #
|
|
# but WITHOUT ANY WARRANTY; without even the implied warranty of #
|
|
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the #
|
|
# GNU General Public License for more details. #
|
|
# #
|
|
# You should have received a copy of the GNU General Public License #
|
|
# along with Geas; if not, write to the Free Software #
|
|
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA #
|
|
# #
|
|
###############################################################################
|
|
|
|
use strict;
|
|
|
|
sub mtext {
|
|
my $str = shift;
|
|
my $rv = chr(254);
|
|
foreach (split //, $str) {
|
|
$rv . = chr(255 - ord $_);
|
|
}
|
|
return $rv . chr(0);
|
|
}
|
|
|
|
|
|
sub obfus {
|
|
my $str = shift;
|
|
my $rv = chr(10);
|
|
foreach (split //, $str) {
|
|
$rv . = chr(255 - ord $_);
|
|
}
|
|
return $rv . chr(0);
|
|
}
|
|
|
|
my $is_raw = 0;
|
|
|
|
my @hash_data =
|
|
([1, 'game'], [2, 'procedure'], [3, 'room'], [4, 'object'],
|
|
[5, 'character'], [6, 'text'], [7, 'selection'], [8, 'define'],
|
|
[9, 'end'], [11, 'asl-version'], [12, 'game'], [13, 'version'],
|
|
[14, 'author'], [15, 'copyright'], [16, 'info'], [17, 'start'],
|
|
[18, 'possitems'], [19, 'startitems'], [20, 'prefix'], [21, 'look'],
|
|
[22, 'out'], [23, 'gender'], [24, 'speak'], [25, 'take'], [26, 'alias'],
|
|
[27, 'place'], [28, 'east'], [29, 'north'], [30, 'west'], [31, 'south'],
|
|
[32, 'give'], [33, 'hideobject'], [34, 'hidechar'], [35, 'showobject'],
|
|
[36, 'showchar'], [37, 'collectable'], [38, 'collecatbles'],
|
|
[39, 'command'], [40, 'use'], [41, 'hidden'], [42, 'script'],
|
|
[43, 'font'], [44, 'default'], [45, 'fontname'], [46, 'fontsize'],
|
|
[47, 'startscript'], [48, 'nointro'], [49, 'indescription'],
|
|
[50, 'description'], [51, 'function'], [52, 'setvar'], [53, 'for'],
|
|
[54, 'error'], [55, 'synonyms'], [56, 'beforeturn'], [57, 'afterturn'],
|
|
[58, 'invisible'], [59, 'nodebug'], [60, 'suffix'], [61, 'startin'],
|
|
[62, 'northeast'], [63, 'northwest'], [64, 'southeast'],
|
|
[65, 'southwest'], [66, 'items'], [67, 'examine'], [68, 'detail'],
|
|
[69, 'drop'], [70, 'everywhere'], [71, 'nowhere'], [72, 'on'],
|
|
[73, 'anything'], [74, 'article'], [75, 'gain'], [76, 'properties'],
|
|
[77, 'type'], [78, 'action'], [79, 'displaytype'], [80, 'override'],
|
|
[81, 'enabled'], [82, 'disabled'], [83, 'variable'], [84, 'value'],
|
|
[85, 'display'], [86, 'nozero'], [87, 'onchange'], [88, 'timer'],
|
|
[89, 'alt'], [90, 'lib'], [91, 'up'], [92, 'down'], [93, 'gametype'],
|
|
[94, 'singleplayer'], [95, 'multiplayer'], [150, 'do'], [151, 'if'],
|
|
[152, 'got'], [153, 'then'], [154, 'else'], [155, 'has'], [156, 'say'],
|
|
[157, 'playwav'], [158, 'lose'], [159, 'msg'], [160, 'not'],
|
|
[161, 'playerlose'], [162, 'playerwin'], [163, 'ask'], [164, 'goto'],
|
|
[165, 'set'], [166, 'show'], [167, 'choice'], [168, 'choose'],
|
|
[169, 'is'], [170, 'setstring'], [171, 'displaytext'], [172, 'exec'],
|
|
[173, 'pause'], [174, 'clear'], [175, 'debug'], [176, 'enter'],
|
|
[177, 'movechar'], [178, 'moveobject'], [179, 'revealchar'],
|
|
[180, 'revealobject'], [181, 'concealchar'], [182, 'concealobject'],
|
|
[183, 'mailto'], [184, 'and'], [185, 'or'], [186, 'outputoff'],
|
|
[187, 'outputon'], [188, 'here'], [189, 'playmidi'], [190, 'drop'],
|
|
[191, 'helpmsg'], [192, 'helpdisplaytext'], [193, 'helpclear'],
|
|
[194, 'helpclose'], [195, 'hide'], [196, 'show'], [197, 'move'],
|
|
[198, 'conceal'], [199, 'reveal'], [200, 'numeric'], [201, 'string'],
|
|
[202, 'collectable'], [203, 'property'], [204, 'create'], [205, 'exit'],
|
|
[206, 'doaction'], [207, 'close'], [208, 'each'], [209, 'in'],
|
|
[210, 'repeat'], [211, 'while'], [212, 'until'], [213, 'timeron'],
|
|
[214, 'timeroff'], [215, 'stop'], [216, 'panes'], [217, 'on'],
|
|
[218, 'off'], [219, 'return'], [220, 'playmod'], [221, 'modvolume'],
|
|
[222, 'clone'], [223, 'shellexe'], [224, 'background'],
|
|
[225, 'foreground'], [226, 'wait'], [227, 'picture'], [228, 'nospeak'],
|
|
[229, 'animate'], [230, 'persist'], [231, 'inc'], [232, 'dec'],
|
|
[233, 'flag'], [234, 'dontprocess'], [235, 'destroy'],
|
|
[236, 'beforesave'], [237, 'onload']);
|
|
|
|
my % tokens = ();
|
|
my % rtokens = ();
|
|
foreach (@hash_data) {
|
|
if ($_->[0] >= 0 && $_->[0] < 256) {
|
|
if ($_->[1] eq '') {
|
|
$_->[1] = "[?" . $_->[0] . "?]";
|
|
}
|
|
$rtokens{chr($_->[0])} = $_->[1];
|
|
$tokens{$_->[1]} = chr($_->[0]);
|
|
}
|
|
}
|
|
|
|
#print "{";
|
|
#for (my $i = 0; $i < 256; $i ++) {
|
|
# print "\"", $rtokens{chr($i)}, "\", ";
|
|
#}
|
|
#print "}\n";
|
|
#die;
|
|
|
|
|
|
my % text_block_starters = map { $_ => 1 } qw / text synonyms type /;
|
|
|
|
sub uncompile_fil {
|
|
my $IFH;
|
|
open($IFH, "<", $_[0]);
|
|
binmode $IFH;
|
|
$ / = undef;
|
|
my $dat = < $IFH >;
|
|
#print "uncompile_fil : ";
|
|
#print "\$IFH == '$IFH',";
|
|
#print "\$dat == '$dat'\n";
|
|
my @dat = split //, $dat;
|
|
|
|
|
|
my $OFH;
|
|
if (@_ == 1) {
|
|
push @_, "&STDOUT";
|
|
}
|
|
open $OFH, ">$_[1]" or die "Can't open '$_[1]' for output: $!";
|
|
|
|
my @output = ();
|
|
my $curline = "";
|
|
|
|
|
|
my $obfus = 0;
|
|
my $expect_text == 0;
|
|
my($ch, $chn, $tok);
|
|
for (my $n = 8; $n < @dat; $n ++) {
|
|
$ch = $dat[$n];
|
|
$chn = ord $ch;
|
|
$tok = $rtokens{$ch};
|
|
if ($obfus == 1 && $chn == 0) {
|
|
#print $OFH "> ";
|
|
$curline . = "> ";
|
|
$obfus = 0;
|
|
}
|
|
elsif($obfus == 1) {
|
|
#print $OFH chr (255 - $chn);
|
|
$curline . = chr(255 - $chn);
|
|
}
|
|
elsif($obfus == 2 && $chn == 254) {
|
|
$obfus = 0;
|
|
#print $OFH " ";
|
|
$curline . = " ";
|
|
}
|
|
elsif($obfus == 2) {
|
|
#print $OFH chr ($chn);
|
|
$curline . = chr($chn);
|
|
}
|
|
elsif($expect_text == 2) {
|
|
if ($chn == 253) {
|
|
$expect_text = 0;
|
|
##print $OFH "\n";
|
|
push @output, $curline;
|
|
$curline = "";
|
|
}
|
|
elsif($chn == 0) {
|
|
#print $OFH "\n";
|
|
push @output, $curline;
|
|
$curline = "";
|
|
}
|
|
else {
|
|
#print $OFH chr (255 - $chn);
|
|
$curline . = chr(255 - $chn);
|
|
}
|
|
}
|
|
elsif($obfus == 0 && $chn == 10) {
|
|
#print $OFH "<";
|
|
$curline . = "<";
|
|
$obfus = 1;
|
|
}
|
|
elsif($obfus == 0 && $chn == 254) {
|
|
$obfus = 2;
|
|
}
|
|
elsif($chn == 255) {
|
|
if ($expect_text == 1) {
|
|
$expect_text = 2;
|
|
}
|
|
#print $OFH "\n";
|
|
push @output, $curline;
|
|
$curline = "";
|
|
}
|
|
else {
|
|
if (($tok eq 'text' || $tok eq 'synonyms' || $tok eq 'type') &&
|
|
$dat[$n - 1] eq chr(8)) {
|
|
$expect_text = 1;
|
|
}
|
|
#print $OFH "$tok ";
|
|
$curline . = "$tok ";
|
|
}
|
|
}
|
|
push @output, $curline;
|
|
$curline = "";
|
|
|
|
if (!$is_raw) {
|
|
@output = pretty_print(reinline(@output));
|
|
}
|
|
|
|
foreach (@output) {
|
|
print $OFH $_, "\r\n";
|
|
}
|
|
}
|
|
|
|
sub list_grab_file {
|
|
my $IFH;
|
|
open($IFH, "<:crlf", $_[0]);
|
|
my @rv = < $IFH >;
|
|
chomp @rv;
|
|
return @rv;
|
|
}
|
|
|
|
|
|
sub compile_fil {
|
|
my @dat = list_grab_file($ARGV[0]);
|
|
my $OFH;
|
|
open $OFH, ">$ARGV[1]";
|
|
|
|
print $OFH "QCGF200".chr(0);
|
|
|
|
# Mode 0 == normal, mode 1 == block text
|
|
my $mode = 0;
|
|
for (my $n = 0; $n < @dat; $n ++) {
|
|
my $l = $dat[$n];
|
|
while (substr($l, length($l) - 1, 1) eq '_' && $n < @dat) {
|
|
$n ++;
|
|
$l = substr($l, 0, length($l) - 1) . $dat[$n];
|
|
}
|
|
if ($l = ~ / ^ !include *<([\S] *)> /) {
|
|
@dat = (@dat[0..$n], list_grab_file($1), @dat[$n + 1..$#dat]);
|
|
}
|
|
elsif($l = ~ / ^ !addto.* /) {
|
|
# TODO
|
|
}
|
|
else {
|
|
my $i = 0;
|
|
my $max = length $l;
|
|
my @l = split //, $l;
|
|
|
|
if ($mode == 1) {
|
|
if ($l = ~ / ^\s * end\s * define\s*$ /) {
|
|
print $OFH chr(253);
|
|
$mode = 0;
|
|
# FALL THROUGH
|
|
} else {
|
|
#print $OFH chr(0);
|
|
foreach (split //, $l) {
|
|
print $OFH chr(255 - ord $_);
|
|
}
|
|
next;
|
|
}
|
|
}
|
|
if ($l = ~ / ^\s*$ /) {
|
|
next;
|
|
}
|
|
if ($l = ~ / ^\s * define\s * (text | synonyms | type) /) {
|
|
#[\s$]
|
|
$mode = 1;
|
|
}
|
|
while ($i < $max) {
|
|
while ($i <= $max && $l[$i] = ~ / \s /) {
|
|
++ $i;
|
|
}
|
|
if ($i == $max) {
|
|
next;
|
|
}
|
|
|
|
my $j = $i + 1;
|
|
if ($l[$i] eq '<') {
|
|
while ($j < $max && $l[$j] ne '>') {
|
|
++ $j;
|
|
}
|
|
if ($l[$j] eq '>') {
|
|
print $OFH obfus(substr($l, $i + 1, $j - $i - 1));
|
|
$i = $j + 1;
|
|
next;
|
|
}
|
|
$j = $i + 1;
|
|
while ($j < $max && $l[$j] ne ' ') {
|
|
++ $j;
|
|
}
|
|
print $OFH chr(254). substr($l, $i + 1, $j - $i - 1). chr(0);
|
|
$i = $j + 1;
|
|
next;
|
|
}
|
|
while ($j < $max && $l[$j] ne ' ') {
|
|
++ $j;
|
|
}
|
|
my $str = substr($l, $i, $j - $i);
|
|
if (defined $tokens{$str}) {
|
|
print $OFH $tokens{$str};
|
|
}
|
|
else {
|
|
print $OFH chr(254). $str. chr(254);
|
|
}
|
|
$i = $j + 1;
|
|
}
|
|
}
|
|
print $OFH chr(255);
|
|
}
|
|
}
|
|
|
|
sub is_define_t {
|
|
my($line, $type) = (@_);
|
|
return ($line = ~ / ^ *define[\s] + $type + /);
|
|
}
|
|
sub is_define {
|
|
my($line) = (@_);
|
|
return ($line = ~ / ^ *define[\s] + [^\s] /);
|
|
}
|
|
sub is_end_define { return (shift = ~ / ^ *end + define *$ /); }
|
|
|
|
sub trim {
|
|
my $tmp = trim1($_[0]);
|
|
#print "trimming ($_[0]) -> ($tmp)\n";
|
|
return $tmp;
|
|
}
|
|
|
|
sub trim1 {
|
|
if ($_[0] = ~ / ^[\s] * (.* ?)[\s]*$ /) {
|
|
return $1;
|
|
}
|
|
print "* * * Huh on trimming '$_[0]' * * *\n";
|
|
}
|
|
|
|
sub reinline {
|
|
my % reinlined = ();
|
|
my @head_prog = ();
|
|
my @rest_prog = ();
|
|
while (@_) {
|
|
push @rest_prog, (pop @_);
|
|
}
|
|
|
|
while (@rest_prog) {
|
|
my $line = pop @rest_prog;
|
|
#print "processing $line\n";
|
|
if ($line = ~ / ^ (.* |)do ( < !intproc[0 - 9] * >) * (.*)$ /) {
|
|
#print " reinlining...\n";
|
|
my($prefix, $func_name, $suffix) = ($1, $2, $3);
|
|
$prefix = trim($prefix);
|
|
$suffix = trim($suffix);
|
|
$reinlined{$func_name} = 1;
|
|
for (my $line_num = 0; $line_num < @rest_prog; $line_num ++) {
|
|
if ($rest_prog[$line_num] = ~ / ^ *define + procedure + $func_name *$ /) {
|
|
my $end_line = $line_num;
|
|
while (!is_end_define($rest_prog[$end_line])) {
|
|
#print " checking $rest_prog[$end_line]\n";
|
|
-- $end_line;
|
|
}
|
|
++ $end_line;
|
|
#print " backpushing } ".$suffix."\n";
|
|
#push @rest_prog, trim ("} " . $suffix);
|
|
if ($suffix ne '') {
|
|
push @rest_prog, $suffix;
|
|
}
|
|
push @rest_prog, "}";
|
|
while ($end_line < $line_num) {
|
|
push @rest_prog, $rest_prog[$end_line];
|
|
#print " backpushing $rest_prog[$end_line]\n";
|
|
$end_line ++;
|
|
}
|
|
#print " backpushing $prefix {\n";
|
|
push @rest_prog, trim($prefix." {");
|
|
$line_num = scalar @rest_prog;
|
|
}
|
|
}
|
|
}
|
|
else {
|
|
push @head_prog, $line;
|
|
}
|
|
}
|
|
my @rv = ();
|
|
for (my $n = 0; $n < @head_prog; $n ++) {
|
|
if ($head_prog[$n] = ~ / ^define procedure(<.*>) *$ / &&
|
|
$reinlined{$1}) {
|
|
while (!is_end_define($head_prog[$n])) {
|
|
++ $n;
|
|
}
|
|
}
|
|
else {
|
|
push @rv, $head_prog[$n];
|
|
}
|
|
}
|
|
#for (my $n = 0; $n < @rv; $n ++) {
|
|
# print "$n: $rv[$n]\n";
|
|
#}
|
|
return @rv;
|
|
}
|
|
|
|
sub pretty_print {
|
|
my $indent = 0;
|
|
my $not_in_text_mode = 1;
|
|
|
|
my @rv = ();
|
|
|
|
for (my $n = 0; $n < @_; $n ++) {
|
|
my $line = $_[$n];
|
|
if (is_end_define($line)) {
|
|
-- $indent;
|
|
$not_in_text_mode = 1;
|
|
}
|
|
/ { /; if ($line = ~ / ^} /) {
|
|
-- $indent;
|
|
}
|
|
###if (is_define ($line) && ($n == 0 || !is_define ($_[$n-1]))) { print "\n"; }
|
|
if (is_define($line) && ($n == 0 || !is_define($_[$n - 1]))) {
|
|
push @rv, "";
|
|
}
|
|
###if ($in_text_mode == 0) { print " "x$indent; }
|
|
push @rv, (" "x($indent*$not_in_text_mode)).trim($line);
|
|
###print $line, " line $n, indent $indent, text $in_text_mode\n";
|
|
###print $line, "\n";
|
|
if (is_end_define($line) && $n < @_ && !is_end_define($_[$n + 1])
|
|
&& !is_define($_[$n + 1])) {
|
|
###print "\n";
|
|
push @rv, "";
|
|
}
|
|
if (is_define($line)) {
|
|
++ $indent;
|
|
}
|
|
if ($line = ~ / {$ /) {
|
|
++ $indent;
|
|
} /
|
|
} /;
|
|
if ($line = ~ / ^ *define + text /) {
|
|
$not_in_text_mode = 0;
|
|
}
|
|
}
|
|
return @rv;
|
|
}
|
|
|
|
|
|
sub error_msg {
|
|
die "Usage: 'perl uncas.pl file.asl file2.cas' to compile to file\n".
|
|
" 'perl uncas.pl file.cas' to decompile to console\n".
|
|
" 'perl uncas.pl file.cas file2.asl' to decompile to file\n";
|
|
}
|
|
|
|
if ($ARGV[0] eq '-raw') {
|
|
$is_raw = 1;
|
|
shift @ARGV;
|
|
}
|
|
|
|
if ($ARGV[0] = ~ / \.asl$ /) {
|
|
if (@ARGV != 2) {
|
|
error_msg();
|
|
}
|
|
compile_fil(@ARGV);
|
|
}
|
|
elsif($ARGV[0] = ~ / \.cas$ /) {
|
|
#print "compile_fil (", join (", ", @ARGV), ")\n";
|
|
if (@ARGV != 1 && @ARGV != 2) {
|
|
error_msg();
|
|
}
|
|
uncompile_fil(@ARGV);
|
|
}
|