![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to tme-binary-struct.pl.in CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [The Machine Emulator] / tme / tools|
Return to tme-binary-struct.pl.in CVS log | Up to [The Machine Emulator] / tme / tools |
1.1 ! root 1: #! /usr/pkg/bin/perl -w ! 2: ! 3: # $Id: tme-binary-struct.pl.in,v 1.2 2005/01/14 11:40:50 fredette Exp $ ! 4: ! 5: # tools/tme-binary-struct.pl.in - common framework for scripts that ! 6: # manipulate files containing binary structures: ! 7: # ! 8: ! 9: # Copyright (c) 2004 Matt Fredette ! 10: # All rights reserved. ! 11: # ! 12: # Redistribution and use in source and binary forms, with or without ! 13: # modification, are permitted provided that the following conditions ! 14: # are met: ! 15: # 1. Redistributions of source code must retain the above copyright ! 16: # notice, this list of conditions and the following disclaimer. ! 17: # 2. Redistributions in binary form must reproduce the above copyright ! 18: # notice, this list of conditions and the following disclaimer in the ! 19: # documentation and/or other materials provided with the distribution. ! 20: # 3. All advertising materials mentioning features or use of this software ! 21: # must display the following acknowledgement: ! 22: # This product includes software developed by Matt Fredette. ! 23: # 4. The name of the author may not be used to endorse or promote products ! 24: # derived from this software without specific prior written permission. ! 25: # ! 26: # THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR ! 27: # IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ! 28: # WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE ! 29: # DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, ! 30: # INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ! 31: # (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ! 32: # SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ! 33: # HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ! 34: # STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ! 35: # ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! 36: # POSSIBILITY OF SUCH DAMAGE. ! 37: ! 38: # silence perl -w: ! 39: # ! 40: undef($bad); ! 41: undef($packed); ! 42: undef(%name_to_values); ! 43: ! 44: # globals: ! 45: # ! 46: $0 =~ /^(.*\/)?([^\/]+)$/; $PROG = $2; ! 47: ! 48: # check our command line: ! 49: # ! 50: $usage = 0; ! 51: $verbose = 0; ! 52: $all = 0; ! 53: undef($format_input); ! 54: undef($format_output); ! 55: for (; @ARGV > 0 && $ARGV[0] =~ /^-/; ) { ! 56: $option = shift(@ARGV); ! 57: if ($option eq '--verbose') { ! 58: $verbose++; ! 59: } ! 60: elsif ($option eq '--all') { ! 61: $all = 1; ! 62: } ! 63: elsif ($option =~ /^--format-input=(\S+)$/) { ! 64: $format_input = $1; ! 65: } ! 66: elsif ($option =~ /^--format-output=(\S+)$/) { ! 67: $format_output = $1; ! 68: } ! 69: else { ! 70: if ($option ne "-h" ! 71: && $option ne "--help" ! 72: && $option ne "-?") { ! 73: print STDERR "$PROG error: unknown option `$option'\n"; ! 74: } ! 75: $usage = 1; ! 76: last; ! 77: } ! 78: } ! 79: if (defined($format_input) ! 80: && $format_input ne 'text' ! 81: && $format_input ne 'binary') { ! 82: print STDERR "$PROG error: unknown input format $format_input\n"; ! 83: $usage = 1; ! 84: } ! 85: if (defined($format_output) ! 86: && $format_output ne 'text' ! 87: && $format_output ne 'binary') { ! 88: print STDERR "$PROG error: unknown input format $format_output\n"; ! 89: $usage = 1; ! 90: } ! 91: if (@ARGV > 0) { ! 92: print STDERR "$PROG error: `$ARGV[0]' unexpected\n"; ! 93: $usage = 1; ! 94: } ! 95: if ($usage) { ! 96: print STDERR <<"EOF;"; ! 97: usage: $PROG [ OPTIONS ] ! 98: where OPTIONS are: ! 99: --verbose include comments in text output ! 100: --all display normally hidden fields in text output ! 101: --format-input=FORMAT set the input format to FORMAT, one of: text binary ! 102: --format-output=FORMAT set the output format to FORMAT, one of: text binary ! 103: EOF; ! 104: exit (1); ! 105: } ! 106: ! 107: # the set of related types: ! 108: # ! 109: %types_related = split(/[\r\n\s]+/, <<'EOF;'); ! 110: generic_char_hex generic_integral ! 111: generic_char_dec generic_integral ! 112: generic_shorteb_hex generic_integral ! 113: generic_shorteb_dec generic_integral ! 114: generic_shortel_hex generic_integral ! 115: generic_shortel_dec generic_integral ! 116: generic_longeb_hex generic_integral ! 117: generic_longeb_dec generic_integral ! 118: generic_longel_hex generic_integral ! 119: generic_longel_dec generic_integral ! 120: EOF; ! 121: ! 122: # get the structure definition: ! 123: # ! 124: $struct_definition = &binary_struct(); ! 125: ! 126: # process the structure definition and make the default input: ! 127: # ! 128: $input_default = ""; ! 129: @comments = (""); ! 130: $comments_new = 0; ! 131: for ($line_start = 0; ! 132: $line_start < length($struct_definition); ) { ! 133: ! 134: # get the offset of the next line separator: ! 135: # ! 136: $line_end = index($struct_definition, "\n", $line_start); ! 137: if ($line_end < 0) { ! 138: $line_end = length($struct_definition) + 1; ! 139: } ! 140: ! 141: # get the next line: ! 142: # ! 143: $_ = substr($struct_definition, $line_start, $line_end - $line_start); ! 144: $line_start = $line_end + 1; ! 145: ! 146: # ignore comments and blank lines: ! 147: # ! 148: if ($_ !~ /\S/ || /^\s*\#/) { ! 149: if ($comments_new) { ! 150: push(@comments, ""); ! 151: $comments_new = 0; ! 152: } ! 153: $comments[$#comments] .= $_."\n"; ! 154: next; ! 155: } ! 156: ! 157: # tokenize this line: ! 158: # ! 159: ($offset, $name, $type, $values) = split(' ', $_, 4); ! 160: ! 161: # make sure this name isn't multiply-defined: ! 162: # ! 163: if (defined($name_to_offset{$name})) { ! 164: print STDERR "$PROG internal error: $name multiply defined\n"; ! 165: exit (1); ! 166: } ! 167: ! 168: # convert the offset: ! 169: # ! 170: $offset = hex($offset); ! 171: ! 172: # canonicalize the type and count: ! 173: # ! 174: if ($type =~ /^(.*\D)(\d+)$/) { ! 175: ($type, $count) = ($1, $2); ! 176: } ! 177: else { ! 178: $count = 1; ! 179: } ! 180: ! 181: # make sure this type is known: ! 182: # ! 183: $func = $types_related{$type}; ! 184: if (!defined($func)) { ! 185: $func = $type; ! 186: } ! 187: unless (eval("defined(\&type_${func}_pack);")) { ! 188: print STDERR "$PROG internal error: unknown type $func\n"; ! 189: exit (1); ! 190: } ! 191: ! 192: # remember this name: ! 193: # ! 194: push (@names, $name); ! 195: $name_to_offset{$name} = $offset; ! 196: $name_to_type{$name} = $type; ! 197: $name_to_count{$name} = $count; ! 198: $name_to_values{$name} = $values; ! 199: $name_to_func{$name} = $func; ! 200: $name_to_comments{$name} = $#comments; ! 201: ! 202: # get the default value for this field: ! 203: # ! 204: eval("(\$value) = \&type_${func}_values(\$type, \$count, \$values);"); ! 205: ! 206: # if the default value has an alias, use the alias: ! 207: # ! 208: if ($value =~ s/=([^=]+)$//) { ! 209: $value = $1; ! 210: } ! 211: ! 212: # add this value to the default input: ! 213: # ! 214: $input_default .= "$name $value\n"; ! 215: ! 216: # the next comment starts a new comment: ! 217: # ! 218: $comments_new = 1; ! 219: } ! 220: ! 221: # if our standard input is a terminal: ! 222: # ! 223: if (-t STDIN) { ! 224: ! 225: # if the user specified the input format, and it's not text, that's an error: ! 226: # ! 227: if (defined($format_input) ! 228: && $format_input ne 'text') { ! 229: print STDERR "$PROG error: the input format can't be $format_input when standard input is a terminal\n"; ! 230: exit (1); ! 231: } ! 232: $format_input = 'text'; ! 233: ! 234: # there is no standard input: ! 235: # ! 236: $input = ""; ! 237: } ! 238: ! 239: # otherwise, our standard input is not a terminal: ! 240: # ! 241: else { ! 242: ! 243: # read in standard input: ! 244: # ! 245: $input = ""; ! 246: for (;;) { ! 247: undef($_); ! 248: $size = sysread(STDIN, $_, 1024); ! 249: if (!defined($size)) { ! 250: print STDERR "fatal: could not read stdin: $!\n"; ! 251: exit (1); ! 252: } ! 253: elsif ($size == 0) { ! 254: last; ! 255: } ! 256: $input .= $_; ! 257: } ! 258: ! 259: # if we don't know if the input format is text or binary, try to ! 260: # figure it out: ! 261: # ! 262: if (!defined($format_input)) { ! 263: $format_input = ($input =~ /[\000-\011\013-\036]/ ? 'binary' : 'text'); ! 264: print STDERR "$PROG notice: input format is $format_input\n"; ! 265: } ! 266: } ! 267: ! 268: # if we don't know the output format, it's the opposite of the input format: ! 269: # ! 270: if (!defined($format_output)) { ! 271: $format_output = ($format_input eq 'text' ? 'binary' : 'text'); ! 272: print STDERR "$PROG notice: output format is $format_output\n"; ! 273: } ! 274: ! 275: # if the output format is binary, --verbose and --all don't make sense: ! 276: # ! 277: if ($format_output eq 'binary' ! 278: && ($verbose ! 279: || $all)) { ! 280: print STDERR "$PROG error: --verbose and --all don't make sense for binary output\n"; ! 281: exit (1); ! 282: } ! 283: ! 284: # if our input is text: ! 285: # ! 286: if ($format_input eq 'text') { ! 287: ! 288: # prepend the default input to the input, to provide values for ! 289: # any names that the user doesn't provide: ! 290: # ! 291: $input = $input_default."\n".$input; ! 292: ! 293: # process the lines of the input: ! 294: # ! 295: for ($line_start = 0; ! 296: $line_start < length($input); ) { ! 297: ! 298: # get the offset of the next line separator: ! 299: # ! 300: $line_end = index($input, "\n", $line_start); ! 301: if ($line_end < 0) { ! 302: $line_end = length($input) + 1; ! 303: } ! 304: ! 305: # get the next line: ! 306: # ! 307: $_ = substr($input, $line_start, $line_end - $line_start); ! 308: $line_start = $line_end + 1; ! 309: ! 310: # ignore comments and blank lines: ! 311: # ! 312: if ($_ !~ /\S/ || /^\s*\#/) { ! 313: next; ! 314: } ! 315: ! 316: # tokenize this line: ! 317: # ! 318: ($name, $value) = split(' ', $_, 2); ! 319: ! 320: # if this name is unknown: ! 321: # ! 322: if (!defined($name_to_offset{$name})) { ! 323: print STDERR "$PROG error: unknown name `$name'\n"; ! 324: exit (1); ! 325: } ! 326: ! 327: # save this value: ! 328: # ! 329: $name_to_value{$name} = $value; ! 330: } ! 331: } ! 332: ! 333: # otherwise, if our input is binary: ! 334: # ! 335: elsif ($format_input eq 'binary') { ! 336: ! 337: # extract values from the image: ! 338: # ! 339: foreach $name (@names) { ! 340: ! 341: # get this name's type, function, count, and offset: ! 342: # ! 343: $type = $name_to_type{$name}; ! 344: $func = $name_to_func{$name}; ! 345: $count = $name_to_count{$name}; ! 346: $offset = $name_to_offset{$name}; ! 347: ! 348: # unpack this value: ! 349: # ! 350: eval("\$value = \&type_${func}_unpack(\$type, \$count, substr(\$input, \$offset));"); ! 351: ! 352: # save this value: ! 353: # ! 354: $name_to_value{$name} = $value; ! 355: } ! 356: } ! 357: ! 358: # loop over the names: ! 359: # ! 360: $image = ""; ! 361: foreach $name (@names) { ! 362: ! 363: # get everything about this name: ! 364: # ! 365: $type = $name_to_type{$name}; ! 366: $func = $name_to_func{$name}; ! 367: $count = $name_to_count{$name}; ! 368: $offset = $name_to_offset{$name}; ! 369: $value = $name_to_value{$name}; ! 370: eval("\@values = \&type_${func}_values(\$type, \$count, \$name_to_values{\$name});"); ! 371: ! 372: # pack the possibilities and get any aliases: ! 373: # ! 374: @aliases = (); ! 375: @packeds = (); ! 376: undef($wild_alias); ! 377: foreach $_ (@values) { ! 378: ! 379: # strip any alias: ! 380: # ! 381: if (/^(.*)=([^=]+)$/) { ! 382: $_ = $1; ! 383: push (@aliases, $2); ! 384: } ! 385: else { ! 386: push (@aliases, ''); ! 387: } ! 388: ! 389: # if this is the wildcard: ! 390: # ! 391: if ($_ eq '*' ! 392: && $aliases[$#aliases] ne '') { ! 393: $wild_alias = $aliases[$#aliases]; ! 394: push(@packeds, ''); ! 395: } ! 396: ! 397: # otherwise, this is not the wildcard: ! 398: # ! 399: else { ! 400: ! 401: # this value must pack: ! 402: # ! 403: eval("(\$bad, \$packed) = \&type_${func}_pack(\$type, \$count, \$_);"); ! 404: if (defined($bad) ! 405: || !defined($packed)) { ! 406: print STDERR "$PROG internal error: bad value for $name ($_)\n"; ! 407: exit (1); ! 408: } ! 409: push (@packeds, $packed); ! 410: } ! 411: } ! 412: ! 413: # try to pack this value: ! 414: # ! 415: eval("(\$value_packed_bad, \$value_packed) = \&type_${func}_pack(\$type, \$count, \$value);"); ! 416: ! 417: # see if this value is on the list of possibilities, and is an ! 418: # alias or has an alias: ! 419: # ! 420: $value_ok = 0; ! 421: $value_alias = ''; ! 422: for ($value_i = 0; $value_i < @values; $value_i++) { ! 423: ! 424: # if this possibility has an alias, and the given value matches ! 425: # the alias, stop now: ! 426: # ! 427: if ($aliases[$value_i] ne '' ! 428: && $value eq $aliases[$value_i]) { ! 429: $value_ok = 1; ! 430: $value_alias = $aliases[$value_i]; ! 431: $value_packed = $packeds[$value_i]; ! 432: last; ! 433: } ! 434: ! 435: # if this value packed, and it matches this packed ! 436: # possibility, remember that this value is on the list of ! 437: # possibilities, and any alias: ! 438: # ! 439: if (!defined($value_packed_bad) ! 440: && $value_packed eq $packeds[$value_i]) { ! 441: $value_ok = 1; ! 442: $value_alias = $aliases[$value_i]; ! 443: } ! 444: } ! 445: ! 446: # if there is a list of possible values: ! 447: # ! 448: if (@values > 1) { ! 449: ! 450: # if this value isn't one of them: ! 451: # ! 452: if (!$value_ok) { ! 453: ! 454: # if the wildcard is accepted: ! 455: # ! 456: if ($wild_alias ne '') { ! 457: $value_alias = $wild_alias; ! 458: } ! 459: ! 460: # otherwise, complain: ! 461: # ! 462: else { ! 463: print STDERR "$PROG error: bad value `$value' for $name, must be one of:"; ! 464: for ($value_i = 0; $value_i < @values; $value_i++) { ! 465: print STDERR ' '.($aliases[$value_i] ne '' ? $aliases[$value_i] : $values[$value_i]); ! 466: } ! 467: if (defined($value_packed_bad)) { ! 468: print STDERR " (bad $value_packed_bad)"; ! 469: } ! 470: print STDERR "\n"; ! 471: exit (1); ! 472: } ! 473: } ! 474: } ! 475: ! 476: # otherwise, there isn't a list of possible values. if this value ! 477: # failed to pack: ! 478: # ! 479: elsif (defined($value_packed_bad)) { ! 480: print STDERR "$PROG error: bad value `$value' for $name\n"; ! 481: exit (1); ! 482: } ! 483: ! 484: # if our output is text: ! 485: # ! 486: if ($format_output eq 'text') { ! 487: ! 488: # display this variable if it's not normally hidden, or if ! 489: # we're displaying all variables: ! 490: # ! 491: if ($name !~ /^\./ || $all) { ! 492: ! 493: # if we're being verbose, display this variable's comment: ! 494: # ! 495: if ($verbose) { ! 496: print $comments[$name_to_comments{$name}]; ! 497: $comments[$name_to_comments{$name}] = ''; ! 498: } ! 499: ! 500: # display the variable and its alias or value: ! 501: # ! 502: print "$name ".($value_alias ne '' ? $value_alias : $value)."\n"; ! 503: } ! 504: } ! 505: ! 506: # otherwise, if our output is binary: ! 507: # ! 508: else { ! 509: ! 510: # add this packed value to the image: ! 511: # ! 512: if (length($image) < ($offset + length($value_packed))) { ! 513: $image .= pack('C', 0) x ($offset + length($value_packed) - length($image)); ! 514: } ! 515: substr($image, $offset, length($value_packed)) = $value_packed; ! 516: } ! 517: } ! 518: ! 519: # if our output is binary, output the image: ! 520: # ! 521: if ($format_output eq 'binary') { ! 522: print $image; ! 523: } ! 524: ! 525: # done: ! 526: # ! 527: exit(0); ! 528: ! 529: # this parses a set of integral values: ! 530: # ! 531: sub type_generic_integral_values { ! 532: my ($type, $count, $values) = @_; ! 533: if (!defined($values)) { ! 534: (''); ! 535: } ! 536: else { ! 537: split(' ', $values); ! 538: } ! 539: } ! 540: ! 541: # this returns the Perl pack template character for an integral type: ! 542: # ! 543: sub type_generic_integral_template { ! 544: my ($type) = @_; ! 545: ! 546: if ($type =~ /^generic_char_/) { ! 547: $type = 'C'; ! 548: } ! 549: elsif ($type =~ /^generic_shorteb_/) { ! 550: $type = 'n'; ! 551: } ! 552: elsif ($type =~ /^generic_longeb_/) { ! 553: $type = 'N'; ! 554: } ! 555: else { ! 556: print STDERR "$PROG fatal: unknown integral type $type\n"; ! 557: exit (1); ! 558: } ! 559: $type; ! 560: } ! 561: ! 562: # this packs an integral value: ! 563: # ! 564: sub type_generic_integral_pack { ! 565: my ($type, $count, $value) = @_; ! 566: my ($template, $bad, @parts); ! 567: ! 568: @parts = split(/,/, $value); ! 569: for (; @parts < $count; ) { push(@parts, '0'); } ! 570: foreach (@parts) { ! 571: if (/^0x[0-9A-Fa-f]+$/) { ! 572: $_ = hex($_) + 0; ! 573: } ! 574: elsif (/^\'(.)\'$/) { ! 575: $_ = ord($_) + 0; ! 576: } ! 577: elsif (/^\d+$/) { ! 578: $_ += 0; ! 579: } ! 580: else { ! 581: $bad = $_; ! 582: $_ = 0; ! 583: } ! 584: } ! 585: $template = &type_generic_integral_template($type); ! 586: ($bad, pack("$template$count", @parts)); ! 587: } ! 588: ! 589: # this unpacks an integral value: ! 590: # ! 591: sub type_generic_integral_unpack { ! 592: my ($type, $count, $packed) = @_; ! 593: my ($template, @parts); ! 594: ! 595: $template = &type_generic_integral_template($type); ! 596: @parts = unpack("$template$count", $packed); ! 597: for (; @parts > ($count > 1 ? 0 : 1) && $parts[$#parts] == 0; ) { pop(@parts); } ! 598: if ($type =~ /_hex$/) { ! 599: foreach (@parts) { ! 600: $_ = sprintf("0x%0".(length(pack($template, 0)) * 2)."x", $_); ! 601: } ! 602: } ! 603: else { ! 604: foreach (@parts) { ! 605: $_ = "$_"; ! 606: } ! 607: } ! 608: join(',', @parts); ! 609: } ! 610: ! 611: # this parses a set of generic string buffer values: ! 612: # ! 613: sub type_generic_string_buffer_values { ! 614: if (!defined($values)) { ! 615: $values = ''; ! 616: } ! 617: ($values); ! 618: } ! 619: ! 620: # this packs a generic string buffer value: ! 621: # ! 622: sub type_generic_string_buffer_pack { ! 623: my ($type, $count, $value) = @_; ! 624: my ($bad); ! 625: if (length($value) < $count) { ! 626: $value .= pack('C', 0) x ($count - length($value)); ! 627: } ! 628: elsif (length($value) > $count) { ! 629: $bad = $value; ! 630: } ! 631: ($bad, $value); ! 632: } ! 633: ! 634: # this unpacks a generic string buffer value: ! 635: # ! 636: sub type_generic_string_buffer_unpack { ! 637: my ($type, $count, $packed) = @_; ! 638: $lc = index($packed, pack('C', 0)); ! 639: if ($lc >= 0) { ! 640: $packed = substr($packed, 0, $lc); ! 641: } ! 642: $packed; ! 643: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.