contrib/award_plugin_roms/award_plugin_roms.pl

   1 #!/usr/bin/perl -w
   2 use strict;
   3 use FileHandle;
   4 use integer;
   5
   6 sub unsigned_little_endian_to_value
   7 {
   8         # Assumes the data is initially little endian
   9         my ($buffer) = @_;
  10         my $bytes = length($buffer);
  11         my $value = 0;
  12         my $i;
  13         for($i = $bytes -1; $i >= 0; $i--) {
  14                 my $byte = unpack('C', substr($buffer, $i, 1));
  15                 $value = ($value * 256) + $byte;
  16         }
  17         return $value;
  18 }
  19
  20 sub decode_fixed_string
  21 {
  22         my ($data, $bytes) = @_;
  23         return $data;
  24 }
  25
  26 sub decode_pstring
  27 {
  28         my ($buf_ref, $offset_ref) = @_;
  29         # Decode a pascal string
  30         my $offset = ${$offset_ref};
  31         my $len = unpack('C',substr(${$buf_ref}, $offset, 1));
  32         my $data = substr(${$buf_ref}, $offset +1,  $len);
  33         ${$offset_ref} = $offset + $len +1;
  34         return $data;
  35 }
  36
  37 sub decode_cstring
  38 {
  39         # Decode a c string
  40         my ($buf_ref, $offset_ref) = @_;
  41         my ($data, $byte);
  42         my $index = ${$offset_ref};
  43         while(1) {
  44                 $byte = substr(${$buf_ref}, $index, 1);
  45                 if (!defined($byte) || ($byte eq "\0")) {
  46                         last;
  47                 }
  48                 $data .= $byte;
  49                 $index++;
  50         }
  51         ${$offset_ref} = $index;
  52         return $data;
  53 }
  54
  55 sub type_size
  56 {
  57         my ($entry) = @_;
  58         my %type_length = (
  59                 byte => 1,
  60                 half => 2,
  61                 word => 4,
  62                 xword => 8,
  63                 'fixed-string' => $entry->[2],
  64                 pstring => 0,
  65                 cstring => 0,
  66         );
  67         my $type = $entry->[0];
  68         if (!exists($type_length{$type})) {
  69                  die "unknown type $type";
  70          }
  71         my $length = $type_length{$type};
  72         return $length;
  73 }
  74
  75 sub decode_fixed_type
  76 {
  77         my ($type, $data, $bytes) = @_;
  78         my %decoders = (
  79                 'byte' => \&unsigned_little_endian_to_value,
  80                 'half' => \&unsigned_little_endian_to_value,
  81                 'word' => \&unsigned_little_endian_to_value,
  82                 'xword' => \&unsigned_little_endian_to_value,
  83                 'fixed-string' => \&decode_fixed_string,
  84         );
  85         my $decoder = $decoders{$type} or die "unknow fixed type $type";
  86         return $decoder->($data, $bytes);
  87 }
  88
  89 sub decode_variable_type
  90 {
  91         my ($type, $buf_ref, $offset_ref) = @_;
  92         my %decoders = (
  93                 'pstring' => \&decode_pstring,
  94                 'cstring' => \&decode_cstring,
  95         );
  96         my $decoder = $decoders{$type} or die "unknow variable type $type";
  97         return $decoder->($buf_ref, $offset_ref);
  98 }
  99
 100 sub decode_struct
 101 {
 102         my ($buf_ref, $offset, $layout) = @_;
 103         my $initial_offset = $offset;
 104         my ($entry, %results);
 105         foreach $entry (@$layout) {
 106                 my ($type, $name) = @$entry;
 107                 my $bytes = type_size($entry);
 108                 if ($bytes > 0) {
 109                         my $data = substr(${$buf_ref}, $offset, $bytes);
 110                         $results{$name} = decode_fixed_type($type, $data, $bytes);
 111                         $offset += $bytes;
 112                 } else {
 113                         $results{$name} = decode_variable_type($type, $buf_ref, \$offset);
 114                 }
 115         }
 116         return (\%results, $offset - $initial_offset);
 117 }
 118
 119 sub print_big_hex
 120 {
 121         my ($min_digits, $value) = @_;
 122         my @digits;
 123         while($min_digits > 0 || ($value > 0)) {
 124                 my $digit = $value%16;
 125                 $value /= 16;
 126                 unshift(@digits, $digit);
 127                 $min_digits--;
 128         }
 129         my $digit;
 130         foreach $digit (@digits) {
 131                 printf("%01x", $digit);
 132         }
 133 }
 134
 135
 136
 137 my %lha_signatures = (
 138         '-com-' => 1,
 139         '-lhd-' => 1,
 140         '-lh0-' => 1,
 141         '-lh1-' => 1,
 142         '-lh2-' => 1,
 143         '-lh3-' => 1,
 144         '-lh4-' => 1,
 145         '-lh5-' => 1,
 146         '-lzs-' => 1,
 147         '-lz4-' => 1,
 148         '-lz5-' => 1,
 149         '-afx-' => 1,
 150         '-lzf-' => 1,
 151 );
 152
 153 my %lha_os = (
 154         'M' => 'MS-DOS',
 155         '2' => 'OS/2',
 156         '9' => 'OS9',
 157         'K' => 'OS/68K',
 158         '3' => 'OS/386',
 159         'H' => 'HUMAN',
 160         'U' => 'UNIX',
 161         'C' => 'CP/M',
 162         'F' => 'FLEX',
 163         'm' => 'Mac',
 164         'R' => 'Runser',
 165         'T' => 'TownOS',
 166         'X' => 'XOSK',
 167         'A' => 'Amiga',
 168         'a' => 'atari',
 169         ' ' => 'Award ROM',
 170 );
 171
 172
 173 my @lha_level_1_header = (
 174         [ 'byte',         'header_size' ],    # 1
 175         [ 'byte',         'header_sum', ],    # 2
 176         [ 'fixed-string', 'method_id', 5 ],   # 7
 177         [ 'word',         'skip_size', ],     # 11
 178         [ 'word',         'original_size' ],  # 15
 179         [ 'half',         'dos_time' ],       # 17
 180         [ 'half',         'dos_date' ],       # 19
 181         [ 'byte',         'fixed'   ],        # 20
 182         [ 'byte',         'level'   ],        # 21
 183         [ 'pstring',      'filename' ],       # 22
 184         [ 'half',         'crc' ],
 185         [ 'fixed-string', 'os_id', 1 ],
 186         [ 'half',         'ext_size' ],
 187 );
 188
 189 # General lha_header
 190 my @lha_header = (
 191         [ 'byte',         'header_size' ],
 192         [ 'byte',         'header_sum', ],
 193         [ 'fixed-string', 'method_id', 5 ],
 194         [ 'word',         'skip_size', ],
 195         [ 'word',         'original_size' ],
 196         [ 'half',         'dos_time' ],
 197         [ 'half',         'dos_date' ],
 198         [ 'half',         'rom_addr' ],
 199         [ 'half',         'rom_flags' ],
 200         [ 'byte',         'fixed'   ],
 201         [ 'byte',         'level'   ],
 202         [ 'pstring',      'filename' ],
 203         [ 'half',         'crc' ],
 204         [ 'lha_os',       'os_id', 1 ],
 205         [ 'half',         'ext_size' ],
 206         [ 'byte',         'zero' ],
 207         [ 'byte',         'total_checksum' ],
 208         [ 'half',         'total_size' ],
 209 );
 210
 211 sub print_struct
 212 {
 213         my ($layout, $self) = @_;
 214         my $entry;
 215         my $width = 0;
 216         foreach $entry(@$layout) {
 217                 my ($type, $name) = @$entry;
 218                 if (length($name) > $width) {
 219                         $width = length($name);
 220                 }
 221         }
 222         foreach $entry (@$layout) {
 223                 my ($type, $name) = @$entry;
 224                 printf("%*s = ", $width, $name);
 225                 my $value = $self->{$name};
 226                 if (!defined($value)) {
 227                         print "undefined";
 228                 }
 229                 elsif ($type eq "lha_os") {
 230                         print "$lha_os{$value}";
 231                 }
 232                 elsif ($type =~ m/string/) {
 233                         print "$value";
 234                 }
 235                 else {
 236                         my $len = type_size($entry);
 237                         print "0x";
 238                         print_big_hex($len *2, $value);
 239                 }
 240                 print "\n";
 241         }
 242 }
 243
 244 sub checksum
 245 {
 246         my ($buf_ref, $offset, $length) = @_;
 247         my ($i, $sum);
 248         $sum = 0;
 249         for($i = 0; $i < $length; $i++) {
 250                 my $byte = unpack('C', substr($$buf_ref, $offset + $i, 1));
 251                 $sum = ($sum + $byte) %256;
 252         }
 253         return $sum;
 254 }
 255
 256 sub decode_lha_header
 257 {
 258         my ($buf_ref, $offset) = @_;
 259         my $level = unpack('C',substr(${$buf_ref}, $offset + 20, 1));
 260
 261         my %self;
 262         my ($struct, $bytes);
 263         if ($level == 1) {
 264                 ($struct, $bytes)
 265                         = decode_struct($buf_ref, $offset, \@lha_level_1_header);
 266                 %self = %$struct;
 267                 if ($self{fixed} != 0x20) {
 268                          die "bad fixed value";
 269                 }
 270                 $self{total_size} = $self{header_size} + 2 + $self{skip_size};
 271                 if ($bytes != $self{header_size} +2) {
 272                         die "$bytes != $self{header_size} +2";
 273                 }
 274                 my $checksum = checksum($buf_ref, $offset +2, $self{header_size});
 275                 if ($checksum != $self{header_sum}) {
 276                         printf("WARN: Header bytes checksum to %02lx\n",
 277                                      $checksum);
 278                 }
 279                 # If we are an award rom...
 280                 if ($self{os_id} eq ' ') {
 281                         @self{qw(zero total_checksum)} =
 282                             unpack('CC', substr($$buf_ref,
 283                                 $offset + $self{total_size}, 2));
 284                         if ($self{zero} != 0) {
 285                                 warn "Award ROM without trailing zero";
 286                         }
 287                         else {
 288                                 $self{total_size}++;
 289                         }
 290                         my $checksum =
 291                                 checksum($buf_ref, $offset, $self{total_size});
 292                         if ($self{total_checksum} != $checksum) {
 293                                 printf("WARN: Image bytes checksum to %02lx\n",
 294                                         $checksum);
 295                         }
 296                         else {
 297                                 $self{total_size}++;
 298                         }
 299                         $self{rom_addr} = $self{dos_time};
 300                         $self{rom_flags} = $self{dos_date};
 301                         delete @self{qw(dos_time dos_date)};
 302                 }
 303         }
 304         else {
 305                 die "Unknown header type";
 306         }
 307         return \%self;
 308 }
 309
 310 sub main
 311 {
 312         my ($filename, $rom_length) = @_;
 313         my $fd = new FileHandle;
 314         if (!defined($rom_length)) {
 315                 my ($dev, $ino, $mode, $nlink, $uid, $gid,$rdev,$size,
 316                         $atime, $mtime, $ctime, $blksize, $blocks)
 317                         = stat($filename);
 318                 $rom_length = $size;
 319         }
 320         $fd->open("<$filename") or die "Cannot ope $filename";
 321         my $data;
 322         $fd->read($data, $rom_length);
 323         $fd->close();
 324
 325         my $i;
 326         for($i = 0; $i < $rom_length; $i++) {
 327                 my $sig = substr($data, $i, 5);
 328                 if (exists($lha_signatures{$sig})) {
 329                         my $start = $i -2;
 330                         my $header = decode_lha_header(\$data, $start);
 331
 332                         my $length = $header->{total_size};
 333                         print "AT:  $start - @{[$start + $length -1]},  $length bytes\n";
 334                         print_struct(\@lha_header, $header);
 335                         print "\n";
 336
 337                 }
 338         }
 339 }
 340
 341 main(@ARGV);