xNBA/contrib/award_plugin_roms/award_plugin_roms.pl

#!/usr/bin/perl -w
use strict;
use FileHandle;
use integer;

sub unsigned_little_endian_to_value
{
	# Assumes the data is initially little endian
	my ($buffer) = @_;
	my $bytes = length($buffer);
	my $value = 0;
	my $i;
	for($i = $bytes -1; $i >= 0; $i--) {
		my $byte = unpack('C', substr($buffer, $i, 1));
		$value = ($value * 256) + $byte;
	}
	return $value;
}

sub decode_fixed_string
{
	my ($data, $bytes) = @_;
	return $data;
}

sub decode_pstring
{
	my ($buf_ref, $offset_ref) = @_;
	# Decode a pascal string
	my $offset = ${$offset_ref};
	my $len = unpack('C',substr(${$buf_ref}, $offset, 1));
	my $data = substr(${$buf_ref}, $offset +1,  $len);
	${$offset_ref} = $offset + $len +1;
	return $data;
}

sub decode_cstring
{
	# Decode a c string
	my ($buf_ref, $offset_ref) = @_;
	my ($data, $byte);
	my $index = ${$offset_ref};
	while(1) {
		$byte = substr(${$buf_ref}, $index, 1);
		if (!defined($byte) || ($byte eq "\0")) {
			last;
		}
		$data .= $byte;
		$index++;
	}
	${$offset_ref} = $index;
	return $data;
}

sub type_size
{
	my ($entry) = @_;
	my %type_length = (
		byte => 1,
		half => 2,
		word => 4,
		xword => 8,
		'fixed-string' => $entry->[2],
		pstring => 0,
		cstring => 0,
	);
	my $type = $entry->[0];
	if (!exists($type_length{$type})) {
		 die "unknown type $type";
	 }
	my $length = $type_length{$type};
	return $length;
}

sub decode_fixed_type
{
	my ($type, $data, $bytes) = @_;
	my %decoders = (
		'byte' => \&unsigned_little_endian_to_value,
		'half' => \&unsigned_little_endian_to_value,
		'word' => \&unsigned_little_endian_to_value,
		'xword' => \&unsigned_little_endian_to_value,
		'fixed-string' => \&decode_fixed_string,
	);
	my $decoder = $decoders{$type} or die "unknow fixed type $type";
	return $decoder->($data, $bytes);
}

sub decode_variable_type
{
	my ($type, $buf_ref, $offset_ref) = @_;
	my %decoders = (
		'pstring' => \&decode_pstring,
		'cstring' => \&decode_cstring,
	);
	my $decoder = $decoders{$type} or die "unknow variable type $type";
	return $decoder->($buf_ref, $offset_ref);
}

sub decode_struct
{
	my ($buf_ref, $offset, $layout) = @_;
	my $initial_offset = $offset;
	my ($entry, %results);
	foreach $entry (@$layout) {
		my ($type, $name) = @$entry;
		my $bytes = type_size($entry);
		if ($bytes > 0) {
			my $data = substr(${$buf_ref}, $offset, $bytes);
			$results{$name} = decode_fixed_type($type, $data, $bytes);
			$offset += $bytes;
		} else {
			$results{$name} = decode_variable_type($type, $buf_ref, \$offset);
		}
	}
	return (\%results, $offset - $initial_offset);
}

sub print_big_hex
{
	my ($min_digits, $value) = @_;
	my @digits;
	while($min_digits > 0 || ($value > 0)) {
		my $digit = $value%16;
		$value /= 16;
		unshift(@digits, $digit);
		$min_digits--;
	}
	my $digit;
	foreach $digit (@digits) {
		printf("%01x", $digit);
	}
}



my %lha_signatures = (
	'-com-' => 1,	
	'-lhd-'	=> 1,
	'-lh0-'	=> 1,
	'-lh1-'	=> 1,
	'-lh2-'	=> 1,
	'-lh3-'	=> 1,
	'-lh4-'	=> 1,
	'-lh5-'	=> 1,
	'-lzs-' => 1,
	'-lz4-' => 1,
	'-lz5-' => 1,
	'-afx-'	=> 1,
	'-lzf-'	=> 1,
);

my %lha_os = (
	'M' => 'MS-DOS',
	'2' => 'OS/2',
	'9' => 'OS9',
	'K' => 'OS/68K',
	'3' => 'OS/386',
	'H' => 'HUMAN',
	'U' => 'UNIX',
	'C' => 'CP/M',
	'F' => 'FLEX',
	'm' => 'Mac',
	'R' => 'Runser',
	'T' => 'TownOS',
	'X' => 'XOSK',
	'A' => 'Amiga',
	'a' => 'atari',
	' ' => 'Award ROM',
);


my @lha_level_1_header = (
	[ 'byte',         'header_size' ],    # 1
	[ 'byte',         'header_sum', ],    # 2
	[ 'fixed-string', 'method_id', 5 ],   # 7
	[ 'word',         'skip_size', ],     # 11
	[ 'word',         'original_size' ],  # 15
	[ 'half',         'dos_time' ],       # 17
	[ 'half',         'dos_date' ],       # 19
    	[ 'byte',         'fixed'   ],        # 20
	[ 'byte',         'level'   ],        # 21
	[ 'pstring',      'filename' ],       # 22
	[ 'half',         'crc' ],
	[ 'fixed-string', 'os_id', 1 ],
	[ 'half',         'ext_size' ],		  
);

# General lha_header
my @lha_header = (
	[ 'byte',         'header_size' ],
	[ 'byte',         'header_sum', ],
	[ 'fixed-string', 'method_id', 5 ],
	[ 'word',         'skip_size', ],
	[ 'word',         'original_size' ],
	[ 'half',         'dos_time' ],
	[ 'half',         'dos_date' ],
	[ 'half',         'rom_addr' ],
	[ 'half',         'rom_flags' ],
    	[ 'byte',         'fixed'   ],
	[ 'byte',         'level'   ],
	[ 'pstring',      'filename' ],
	[ 'half',         'crc' ],
	[ 'lha_os',	  'os_id', 1 ],
	[ 'half',         'ext_size' ],
	[ 'byte',         'zero' ],
	[ 'byte',         'total_checksum' ],
	[ 'half',         'total_size' ],
);

sub print_struct
{
	my ($layout, $self) = @_;
	my $entry;
	my $width = 0;
	foreach $entry(@$layout) {
		my ($type, $name) = @$entry;
		if (length($name) > $width) {
			$width = length($name);
		}
	}
	foreach $entry (@$layout) {
		my ($type, $name) = @$entry;
		printf("%*s = ", $width, $name);
		my $value = $self->{$name};
		if (!defined($value)) {
			print "undefined";
		}
		elsif ($type eq "lha_os") {
			print "$lha_os{$value}";
		}
		elsif ($type =~ m/string/) {
			print "$value";
		} 
		else {
			my $len = type_size($entry);
			print "0x";
			print_big_hex($len *2, $value);
		}
		print "\n";
	}
}

sub checksum
{
	my ($buf_ref, $offset, $length) = @_;
	my ($i, $sum);
	$sum = 0;
	for($i = 0; $i < $length; $i++) {
		my $byte = unpack('C', substr($$buf_ref, $offset + $i, 1));
		$sum = ($sum + $byte) %256;
	}
	return $sum;
}

sub decode_lha_header
{
	my ($buf_ref, $offset) = @_;
	my $level = unpack('C',substr(${$buf_ref}, $offset + 20, 1));

	my %self;
	my ($struct, $bytes);
	if ($level == 1) {
		($struct, $bytes) 
			= decode_struct($buf_ref, $offset, \@lha_level_1_header);
		%self = %$struct;
		if ($self{fixed} != 0x20) {
			 die "bad fixed value";
		}
		$self{total_size} = $self{header_size} + 2 + $self{skip_size};
		if ($bytes != $self{header_size} +2) {
			die "$bytes != $self{header_size} +2";
		}
		my $checksum = checksum($buf_ref, $offset +2, $self{header_size});
		if ($checksum != $self{header_sum}) {
			printf("WARN: Header bytes checksum to %02lx\n", 
				     $checksum);
		}
		# If we are an award rom...
		if ($self{os_id} eq ' ') {
			@self{qw(zero total_checksum)} = 
			    unpack('CC', substr($$buf_ref, 
				$offset + $self{total_size}, 2));
			if ($self{zero} != 0) {
				warn "Award ROM without trailing zero";
			}
			else {
				$self{total_size}++;
			}
			my $checksum = 
				checksum($buf_ref, $offset, $self{total_size});
			if ($self{total_checksum} != $checksum) {
				printf("WARN: Image bytes checksum to %02lx\n", 
					$checksum);
			}
			else {
				$self{total_size}++;
			}
			$self{rom_addr} = $self{dos_time};
			$self{rom_flags} = $self{dos_date};
			delete @self{qw(dos_time dos_date)};
		}
	}
	else {
		die "Unknown header type";
	}
	return \%self;
}

sub main
{
	my ($filename, $rom_length) = @_;
	my $fd = new FileHandle;
	if (!defined($rom_length)) {
		my ($dev, $ino, $mode, $nlink, $uid, $gid,$rdev,$size,
			$atime, $mtime, $ctime, $blksize, $blocks)
			= stat($filename);
		$rom_length = $size;
	}
	$fd->open("<$filename") or die "Cannot ope $filename";
	my $data;
	$fd->read($data, $rom_length);
	$fd->close();
	
	my $i;
	for($i = 0; $i < $rom_length; $i++) {
		my $sig = substr($data, $i, 5);
		if (exists($lha_signatures{$sig})) {
			my $start = $i -2;
			my $header = decode_lha_header(\$data, $start);
			
			my $length = $header->{total_size};
			print "AT:  $start - @{[$start + $length -1]},  $length bytes\n";
			print_struct(\@lha_header, $header);
			print "\n";

		}
	}
}

main(@ARGV);