#!/usr/bin/perl -w

# decompile the resource fork of a CodeWarrior .rsrc file
# Waider 1999/2000

$| = 1;

# Pilot resources -------------------------------------------------------------
package Pilot::Resource;
# In theory this is a private function
# Also it's incomplete.
sub unmacify {
  my $string = shift;
  $string =~ s|\xda|/|g;
  $string =~ s|\r|\\n|g;

  $string;
}

sub new {
  my $obj = shift;

  my $res = bless {}, $obj;

  return $res;
}

sub parent {
  my $obj = shift;
  my $newval = shift;
  $newval ? $obj->{'parent'} = $newval : $obj->{'parent'};
}

sub id {
  my $obj = shift;
  my $id = main::findname( $obj->{'type'}, $obj->{'id'}, $obj->{'parent'});
  $id ||= $obj->{'id'};
}

sub type {
  my $obj = shift;
  my $newval = shift;
  $newval ? $obj->{'type'} = $newval : $obj->{'type'};
}

# dump a resource based on the data it holds.
# should do this via subclassing. FIXME.
sub dump {
  my $obj = shift;
  my $indent = shift;

  $indent ||= "";

  # We need to know the object's type.
  my $type = $obj->{'type'};
  return undef unless defined( $type );

  my $id = $obj->id;
  return undef unless defined( $id );

  my $data = $obj->{'data'};
  return undef unless defined( $data );

  # Application Icon Name. Complete.
  if ( $type eq "tAIN" ) {
	print "applicationiconname id ", $obj->id;
	# Data is just a null-terminated string
	#chop( $data ); # lose the null
	$data =~ s/^(.*?)\x00.*$/$1/;  # hrm.
	$data = unmacify( $data );
	print " \"$data\"\n";
	$data = "";

	# Version tag. Complete.
  } elsif ( $type eq "tver" ) {
	print "version id ", $obj->id;
	chop( $data );
	print " \"$data\"\n";
	$data = "";

	# Alert. Mostly complete.
  } elsif ( $type eq "Talt" ) {
	print "alert id ", $obj->id, "\n";
	my ( $icon, $helpid, $defbut, $what ) =
	  unpack( "nnnn", substr( $data, 0, 8 ));
	printf "/* ?? %04x ?? */\n", $what; # I have no idea.
	my ( $title, $message, @buttons ) = split( "\0", substr( $data, 8 ));
	$title = unmacify( $title );
	$message = unmacify( $message );
	print "helpid $helpid\n" if $helpid;
	print "defaultbutton $defbut\n" if $defbut && @buttons && $#buttons > 0;
	print "information\n" if $icon == 0;
	print "confirmation\n" if $icon == 1;
	print "warning\n" if $icon == 2;
	print "error\n" if $icon == 3;
	print "begin\n    title \"$title\"\n    message \"$message\"\n    ";
	printf "buttons \"%s\"\n", join( '" "', @buttons );
	print "end\n";
	$data = "";

	# Form. Incomplete.
  } elsif ( $type eq "tFRM" ) {
	print 'form ';
	print 'id ', $obj->id, ' ';
	printf "at ( %d %d %d %d )\n", unpack( "nnnn", substr( $data, 0, 8 ));
	$data = substr( $data, 8 );

	# Don't know yet what the first 10 bytes are.
    main::hexdump( substr( $data, 0, 10 ), $indent );

	my ( $formid, $helpid, $menuid, $btnid ) =
	  unpack( "nnnn", substr( $data, 10, 8 ));

	# formid is already printed
	# FIXME may need parents for these
	printf "helpid %s\n", $helpid if $helpid;
	printf "menuid %s\n", main::findname( "MBAR", $menuid ) if $menuid;
	printf "defaultbtnid %s\n", main::findname( "tBTN", $btnid ) if $btnid;

	# unknown
	printf "/* ?? %04x */\n", unpack( "n", substr( $data, 18, 2 ));

	print "begin\n";
	$indent .= "  ";
	for my $parts ( 1 .. unpack( "N", substr( $data, 20, 4 ))) {
	  my ( $id, $type ) = 
		unpack( "nA4", substr( $data, 18 + ( 6 * $parts ), 6 ));
	  $main::resources{ "$id-$type" }->parent( $obj );
	  $main::resources{ "$id-$type" }->dump( $indent );
	}
	$indent =~ s/..$//;
	print "end\n";
	$data = ""; # See above for unknowns.

  } elsif ( $type eq "tSTR" ) {
	print "string id ", $obj->id;
	chop( $data );
	print " \"$data\"\n";
	$data = "";

  } elsif ( $type eq "tBTN" ) {
	print $indent, 'button "';
	# Label is at the end of the table
	print unmacify( substr( $data, 19, -1 ));
	$data = substr( $data, 0, 19 );
	print '" id ', $obj->id, " ";
	printf "at ( %d %d %d %d ) ", unpack( "nnnn", substr( $data, 2, 8 ));
	print "nonusable " unless unpack( "c", substr( $data, 10, 1 ));
	$data = substr( $data, 11 );
	my $f = substr( $data, -1 );
	printf "font %d", ord( $f ) if ord( $f );
	$data = substr( $data, 0, 6 );
	print "\n";
	# 6 bytes we don't know what to do with.

  } elsif ( $type eq "tCBX" ) {
	print $indent,'checkbox ', $obj->id, "\n";
    print "Data: ", length( $data ), " bytes\n";

	# Form Title. Complete.
  } elsif ( $type eq "tTTL" ) {
	print 'title ';
	chop( $data );
	print "\"$data\"\n";
	$data = "";

  } elsif ( $type eq "tPUT" ) {
	print $indent, 'popuptrigger "';

	# We've got four bytes at the end that I don't know what to do
	# with for now, so:
	chop( $data ); # lose trailing slash
	if ( substr( $data, 15, 1 ) eq "\0" ) {
	  print "";
	} else {
	  print substr( $data, 15, 1 );
	}

	print '" id ', $obj->id, ' ';
	printf "at ( %d %d %d %d )", unpack( "nnnn", substr( $data, 2, 8 ));
	print " ";
	$data = substr( $data, 10 );
	printf "%s", unpack( "c", substr( $data, 0, 1 ))?"":"nonusable ";
	printf "%s", unpack( "c", substr( $data, 1, 1 ))?"disabled ":"";
	printf "%s",
	  unpack( "c", substr( $data, 2, 1 ))?"leftanchor ":"rightanchor ";
	printf "font %d\n", unpack( "n", substr( $data, 3, 2 ));

  } elsif ( $type eq "tLST" ) {
	my $out = sprintf "list \"%s\" id %d ", join( '" "', split( "\0", substr( $data, 16 ))) ,$obj->id;
	print $indent, $out;
	$data = substr( $data, 2 );
	printf "at ( %d %d %d %d ) ", unpack( "nnnn", substr( $data, 0, 8 ));
	$data = substr( $data, 8 );
	printf "%s", unpack( "c", substr( $data, 0, 1 ))?"":"nonusable ";
	printf "%s", unpack( "c", substr( $data, 1, 1 ))?"":"disabled ";
	printf "font %d\n", unpack( "n", substr( $data, 2, 2 ));

	# Label. Complete (modulo font unpacking)
  } elsif ( $type eq "tLBL" ) {
	print $indent;
	printf "label \"%s\" id %s ",
	  unmacify( substr( $data, 9, -1 )), $obj->id, ' ';
	$data = substr( $data, 0, 9 ); # skip name
	$data = substr( $data, 2 ); # skip ID
	printf "at ( %d %d ) ", unpack( "nn", substr( $data, 0, 4 ));
	$data = substr( $data, 4 );
	printf "%s", unpack( "c", substr( $data, 0, 1 ))?"":"nonusable ";
	$data = substr( $data, 1 );
	my $f = substr( $data, -1 );
	printf "font %d", ord( $f ) if ord( $f );
	$data = ""; # except for that 0xff, which I'm ignoring
	print "\n";

  } elsif ( $type eq "tPUL" ) {
	print $indent,"popuplist id ";
	printf "%d %d\n", unpack( "nn", $data );

	# Graffiti State Indicator. Complete.
  } elsif ( $type eq "tGSI" ) {
	print $indent, "graffitistateindicator at ( ";
	printf "%d, %d", unpack( "nn", $data );
	print " )\n";
	$data = "";

	# Field. Incomplete.
  } elsif ( $type eq "tFLD" ) {
	print $indent, "field id ", $obj->id, " ";
	$data = substr( $data, 2 );
	printf "at ( %d %d %d %d )\n", unpack( "nnnn", substr( $data, 0, 8 ));
	$data = substr( $data, 8 );

	printf "$ {indent}  maxchars %d", unpack( "n", substr( $data, 14, 2 ));
	printf "\n";

	# Scrollbar. Incomplete.
  } elsif ( $type eq "tSCL" ) {
	print $indent, "scrollbar id ", $obj->id, " ";
	$data = substr( $data, 2 );
	printf "at ( %d %d %d %d )\n", unpack( "nnnn", substr( $data, 0, 8 ));
	$data = substr( $data, 8 );

	# Gadget. Incomplete.
  } elsif ( $type eq "tGDT" ) {
	print $indent, "gadget id ", $obj->id, " ";
	$data = substr( $data, 2 );
	printf "at ( %d %d %d %d )", unpack( "nnnn", substr( $data, 0, 8 ));
	$data = substr( $data, 8 );
	print " nonusable" unless substr( $data, 0, 1 ) eq "\1";
	print "\n"; $data = ""; # again with the 0xff?

	# Menu Bar. Complete.
  } elsif ( $type eq "MBAR" ) {
	print $indent, "menu id ", $obj->id, "\n";
	print "begin\n";
	$indent .= "  ";
	for my $i ( 1 .. unpack( "n", substr( $data, 0, 2 ))) {
	  my $id =  unpack( "n", substr( $data, $i * 2, 2 ));
	  $main::resources{ "$id-MENU" }->parent( $obj );
	  $main::resources{ "$id-MENU" }->dump( $indent );
	}
	$indent =~ s/..$//;
	print "end\n";
	$data = "";

	# Menu. Incomplete.
  } elsif ( $type eq "MENU" ) {
	main::hexdump( $data, $indent );
	$data = substr( $data, 2 ); # discard ID
	$data = substr( $data, 12 ); # discard things we know not of
	print "$ {indent}pulldown ";
	my $title = substr( $data, 1, unpack( "C", substr( $data, 0, 1 )));
	$data = substr( $data, 1 + unpack( "C", substr( $data, 0, 1 )));
	print '"', unmacify( $title ), '"', "\n$ {indent}begin\n";
	$indent .= "  ";
	while ( $data !~ /^\x00/ ) {
	  my $entry = 
		unmacify( substr( $data, 1, unpack( "C", substr( $data, 0, 1 ))));
	  $data = substr( $data, 1 + unpack( "C", substr( $data, 0, 1 )));
	  my $shortcut =
		unmacify( substr( $data, 1, 1 ));
	  $data = substr( $data, 2 );
	  $data = substr( $data, 2 ); # unknown
	  print "$ {indent}menuitem \"$ {entry}\" id ??";
	  if ( $shortcut ne "\0" ) {
		print " \"$shortcut\"";
	  }
	  print "\n";
	}
	$indent =~ s/^..//;
	print "$ {indent}end\n";
	$data = "";

  }	else {
	print $indent, "/* ==================================> $type */\n";
    print $indent, "/* Data: ", length( $data ), " bytes */\n";
  }

  if ( $data ) {
	print $indent, "/* Undefined data: */\n";
	main::hexdump( $data, $indent );
  }
}

# -----------------------------------------------------------------------------
package main;

# file appears to work like so:
# 8 bytes block size, followed by data. lather, rinse, repeat.

$file = shift;
$file or die "No file specified.\nDied";

# Tree:
# Project -> Rsc -> $file.rsrc (empty)
#                -> .AppleDouble -> $file.rsrc (the actual meat)
#         -> Src -> ${file}Rsc.h
# This is a bit broken and needs more work.

$hdr = $ARGV[-1];

if ( $file =~ /\// ) {
  # specified a path, so we'll try the above trick
  ( $path, $file ) = $file =~ m|(.*/)(.*?$)|;
  if ( $path !~ /.AppleDouble\/$/) {
	$path .= ".AppleDouble/";
  }

  $file =~ s/\.rsrc$//;
}

if ( !defined( $hdr )) {
  $hdr = "$ {path}../../Src/$ {file}Rsc.h";

  # Sometimes...
  if ( ! -f $hdr ) {
	$hdr = "$ {path}../$ {file}Rsc.h";
  }
}

$file = "$ {path}$ {file}.rsrc";

print STDERR "File: $file\nHeader: $hdr\n";

# "Parse" the header file. This is gross.
$resourceseen = 0;
open( HDR, "< $hdr" ) or die "$hdr: $!\nDied";
while(<HDR>) {
  next if /^\s*$/;

  if ( /Resource:/i ) {
	( $type, $id ) = m/Resource:\s+(\w+)\s+(\d+)/;
	$currentresource = $type;
	$currentid = $id;
	$resourceseen = 1;
	next;
  }

  if ( /#define\s+(\w+)\s+(\d+)/) {
	( $name, $id ) = ( $1, $2 );
	my %items;
	my %parts;

	# this lot should be a map
	if ( !$resourceseen ) {
	  if ( $name =~ /Form$/ ) {
		$currentresource = "tFRM";
		$currentid = $id;
	  }

	  if ( $name =~ /Alert$/ ) {
		$currentresource = "Talt";
		$currentid = $id;
	  }

	  if ( $name =~ /Str$/ ) {
		$currentresource = "tSTR";
		$currentid = $id;
	  }
	}

	$itemsr = $bits{$currentresource} || \%items; # set one way or another
	%items = %{$itemsr};
	$partsr = $items{ $currentid } || \%parts;
	%parts = %{$partsr};
	if ( $currentid == $id ) {
	  $id = $currentresource;
	}

	$parts{ $id } = $name;
	$items{ $currentid } = \%parts;
	$bits{ $currentresource } = \%items;
  }
}
close( HDR );

open( FILE, "< $file" ) || die "$file: $!\nDied";

# Start of file is start, end, length of datablock1, length of datablock2
sysread( FILE, $buf, 16 );
my ($start, $end, $length, $len2 ) = unpack( "NNNN", $buf );

# Skip to block 1
seek( FILE, $start, 0 );
sysread( FILE, $filebuf, $length );
$fullblock = $filebuf;

while ( length( $filebuf ) ) {
  $b1 = length( $fullblock ) - length( $filebuf );
  $buf = substr( $filebuf, 0, 4 );
  $filebuf = substr( $filebuf, 4 );
  $blen = unpack( "N", $buf );
  $buf = substr( $filebuf, 0, $blen );
  $filebuf = substr( $filebuf, $blen );
  $memory{ $b1 } = $buf;
}

# Decoding block 2
sysread( FILE, $filebuf, $len2 );
$fullblock = $filebuf;

warn "End of file not reached!" if !eof( FILE );

# Identical header, 16 bytes.
$filebuf = substr( $filebuf, 16 );

# 6 unknown bytes
printf STDERR "Unknown data: %04x %04x %04x\n",
  unpack( "nnn", substr( $filebuf, 0, 6 ));
$filebuf = substr( $filebuf, 6 );

# 4 bytes, 0000 001c?
printf STDERR "Should be 0x1c: %04x %04x\n",
  unpack( "nn", substr( $filebuf, 0, 4 ));
$filebuf = substr( $filebuf, 4 );

# -----------------------------------------------------------------------------
# START address of string table in block [2 bytes]
# This is in fullblock, not an offest from here.
$string_table_base = unpack( "n", substr( $filebuf, 0, 2 ));
$filebuf = substr( $filebuf, 2 );

# STRING table
#  Length (1 byte)
#  Text
$string_table = substr( $fullblock, $string_table_base );

# COMPONENT table
# Number of entries - 1 [2 bytes]
$component_table = $filebuf;
$count = unpack( "n", substr( $filebuf, 0, 2 ));
$off = 2;

# Entries:
#  Type (4 bytes)
#  Count - 1 (2 bytes)
#  Offset to details ( 2 bytes ) [offset from start of component table]
for $c ( 0 .. $count ) {
  $chunk = substr( $component_table, $off + ( $c * 8 ), 8 );
  ( $type, $cnt, $offset ) = ( unpack( "A4nn", $chunk));

# Details
#  ID (2 bytes)
#  Detail (10 bytes) (???)
  for $i ( 0 .. $cnt ) {
	$chunk = substr( $component_table, $offset + ( $i * 12 ), 12 );
	my ( $ID, $stringoff, $dataoff, $detail ) =
	  ( unpack ( "nnNN", $chunk ));

	if ( $stringoff != 0xffff ) {
	  $slen = unpack( "c", substr( $string_table, $stringoff, 1 ));
	  $string = substr( $string_table, $stringoff + 1, $slen );
	}

	# Push it into the resource table
	$key = "$ID-$type";
	if ( !defined( $resources{ $key })) {
	  $resources{ $key } = new Pilot::Resource;
	}

	$resources{ $key }->{'type'} = $type;
	$resources{ $key }->{'id'} = $ID;
	$resources{ $key }->{'description'} = $string;
	$resources{ $key }->{'leftover'} = $detail;
	if ( defined( $memory{ $dataoff })) {
	  $resources{ $key }->{'data'} = $memory{ $dataoff };
	  delete $memory{ $dataoff };
	} else {
	  print STDERR "    Spang! memory at $dataoff empty!\n";
	}
  }
}

close( FILE );

# check for unpointedto memory
for my $k ( keys %memory ) {
  printf STDERR "Unused memory @[0x%x]\n", $k;
#  hexdump( $memory{$k});
}

# Dump object file
print <<"EOH";
/******************************************************************************
 * Generated from $file
 */

EOH

# Header file
if ( -f $hdr ) {
  $hdr =~ s|.*/||;
  print "#include \"$hdr\"\n\n";
}

for my $k ( sort keys %resources ) {
  # Dump toplevel resources only, let ->dump handle the rest.
  if ( $resources{$k}->{'type'} =~
	   /tFRM|MBAR|tALT|tVER|tSTR|tAIS|tAIN|APPL|tAIB|Tbmp|TRAP|FONT/i ) {
	$resources{$k}->dump;
	print "\n";
  } else {
	print STDERR "Skipping ", $resources{$k}->{'type'}, "\n";
  }
}

# Chunk out a hexdump of the supplied data, indented appropriately.
sub hexdump {
  my $data = shift;
  my $indent = shift;
  $indent ||= "";
  my $hex = "$indent/* ";
  my $txt = "";

  while ( length( $data )) {
	my $x = ord( substr( $data, 0, 1 ));
	$data = substr( $data, 1 );
	$hex .= sprintf "%02x ", $x;
	$txt .= sprintf "%0c", (( $x >= 32 ) && ( $x <= 126 ))?$x:ord(".");
	if ( length( $hex ) == 48 ) {
	  print "$hex $txt */\n";
	  $hex = "$indent/* ";
	  $txt = "";
	}
  }

  if ( $hex ) {
	printf "%-48s %s */\n", $hex, $txt;
  }
}

# This attempts to convert a random number into a symbolic name from
# the header file. Sometimes it works, sometimes it doesn't.
# Params: TYPE of resource, ID we're looking for, PARENT er, I forget.
# Returns either the name it found or the original ID.
sub findname {
  my $type = shift;
  my $id = shift;
  my $parent = shift;
  my %items;
  my $retval = $id; # default return value is whatever was passed in.
  my $realtype = $type; # in case I get smart...

  if ( defined( $parent )) {
	$type = $parent->type;
  } else {
	$parent = "";
  }

  if ( $parent ) {
	$type = $parent->type; # XXX
  }

  if ( defined( $bits{ $type })) {
	%items = %{$bits{$type}};
  } else {
	# We don't know where to look. Give up before we've started.
	return $retval;
  }

  # Search for an appropriate name. This can be fooled, but the end
  # result is approximately the same until you start hand-tweaking
  # constants in the ...Rsc.h file.
  for my $x (keys ( %items )) {
	if ( !$parent ) {
	  if ( $x == $id ) {
		$retval = ${$items{$x}}{ $type };
		last;
	  }
	} else {
	  if (( $parent && $x == $parent->{'id'} ) ||
		  ( !$parent && $x == $id )) {
		for my $y ( keys %{$items{$x}}) {
		  if (( $parent && $y =~ /^[0-9]+$/ && $y == $id ) ||
			  ( !$parent && $y eq $type )) {
			$retval = $ {$items{$x}}{$y};
			last;
		  }
		}
	  }
	}
  }

  $retval;
}