#!/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);
