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