![[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.