[REPATCH] Re: [PATCH] Re: socketpair blip on unicos/mk, too
[p5sagit/p5-mst-13.2.git] / utils / c2ph.PL
CommitLineData
4633a7c4 1#!/usr/local/bin/perl
2
3use Config;
4use File::Basename qw(&basename &dirname);
8a5546a1 5use Cwd;
4633a7c4 6
7# List explicitly here the variables you want Configure to
8# generate. Metaconfig only looks for shell variables, so you
9# have to mention them as if they were shell variables, not
10# %Config entries. Thus you write
11# $startperl
12# to ensure Configure will look for $Config{startperl}.
13
14# This forces PL files to create target in same directory as PL file.
15# This is so that make depend always knows where to find PL derivatives.
8a5546a1 16$origdir = cwd;
44a8e56a 17chdir dirname($0);
18$file = basename($0, '.PL');
774d564b 19$file .= '.com' if $^O eq 'VMS';
4633a7c4 20
21open OUT,">$file" or die "Can't create $file: $!";
22
23print "Extracting $file (with variable substitutions)\n";
24
25# In this section, perl variables will be expanded during extraction.
26# You can use $Config{...} to use Configure variables.
27
28print OUT <<"!GROK!THIS!";
5f05dabc 29$Config{startperl}
30 eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
31 if \$running_under_some_shell;
11aea360 32!GROK!THIS!
33
4633a7c4 34# In the following, perl variables are not expanded during extraction.
35
36print OUT <<'!NO!SUBS!';
37#
11aea360 38#
39# c2ph (aka pstruct)
40# Tom Christiansen, <tchrist@convex.com>
9aec1e06 41#
11aea360 42# As pstruct, dump C structures as generated from 'cc -g -S' stabs.
43# As c2ph, do this PLUS generate perl code for getting at the structures.
44#
45# See the usage message for more. If this isn't enough, read the code.
46#
47
9aec1e06 48=head1 NAME
49
1fef88e7 50c2ph, pstruct - Dump C structures as generated from C<cc -g -S> stabs
9aec1e06 51
52=head1 SYNOPSIS
53
54 c2ph [-dpnP] [var=val] [files ...]
55
56=head2 OPTIONS
57
58 Options:
59
60 -w wide; short for: type_width=45 member_width=35 offset_width=8
61 -x hex; short for: offset_fmt=x offset_width=08 size_fmt=x size_width=04
62
63 -n do not generate perl code (default when invoked as pstruct)
64 -p generate perl code (default when invoked as c2ph)
65 -v generate perl code, with C decls as comments
66
67 -i do NOT recompute sizes for intrinsic datatypes
68 -a dump information on intrinsics also
69
70 -t trace execution
71 -d spew reams of debugging output
72
73 -slist give comma-separated list a structures to dump
74
75=head1 DESCRIPTION
76
77The following is the old c2ph.doc documentation by Tom Christiansen
78<tchrist@perl.com>
79Date: 25 Jul 91 08:10:21 GMT
80
81Once upon a time, I wrote a program called pstruct. It was a perl
82program that tried to parse out C structures and display their member
83offsets for you. This was especially useful for people looking at
84binary dumps or poking around the kernel.
85
86Pstruct was not a pretty program. Neither was it particularly robust.
87The problem, you see, was that the C compiler was much better at parsing
88C than I could ever hope to be.
89
90So I got smart: I decided to be lazy and let the C compiler parse the C,
91which would spit out debugger stabs for me to read. These were much
92easier to parse. It's still not a pretty program, but at least it's more
93robust.
94
95Pstruct takes any .c or .h files, or preferably .s ones, since that's
96the format it is going to massage them into anyway, and spits out
97listings like this:
98
1fef88e7 99 struct tty {
100 int tty.t_locker 000 4
101 int tty.t_mutex_index 004 4
102 struct tty * tty.t_tp_virt 008 4
103 struct clist tty.t_rawq 00c 20
104 int tty.t_rawq.c_cc 00c 4
105 int tty.t_rawq.c_cmax 010 4
106 int tty.t_rawq.c_cfx 014 4
107 int tty.t_rawq.c_clx 018 4
108 struct tty * tty.t_rawq.c_tp_cpu 01c 4
109 struct tty * tty.t_rawq.c_tp_iop 020 4
110 unsigned char * tty.t_rawq.c_buf_cpu 024 4
111 unsigned char * tty.t_rawq.c_buf_iop 028 4
112 struct clist tty.t_canq 02c 20
113 int tty.t_canq.c_cc 02c 4
114 int tty.t_canq.c_cmax 030 4
115 int tty.t_canq.c_cfx 034 4
116 int tty.t_canq.c_clx 038 4
117 struct tty * tty.t_canq.c_tp_cpu 03c 4
118 struct tty * tty.t_canq.c_tp_iop 040 4
119 unsigned char * tty.t_canq.c_buf_cpu 044 4
120 unsigned char * tty.t_canq.c_buf_iop 048 4
121 struct clist tty.t_outq 04c 20
122 int tty.t_outq.c_cc 04c 4
123 int tty.t_outq.c_cmax 050 4
124 int tty.t_outq.c_cfx 054 4
125 int tty.t_outq.c_clx 058 4
126 struct tty * tty.t_outq.c_tp_cpu 05c 4
127 struct tty * tty.t_outq.c_tp_iop 060 4
128 unsigned char * tty.t_outq.c_buf_cpu 064 4
129 unsigned char * tty.t_outq.c_buf_iop 068 4
130 (*int)() tty.t_oproc_cpu 06c 4
131 (*int)() tty.t_oproc_iop 070 4
132 (*int)() tty.t_stopproc_cpu 074 4
133 (*int)() tty.t_stopproc_iop 078 4
134 struct thread * tty.t_rsel 07c 4
135
136etc.
9aec1e06 137
138
139Actually, this was generated by a particular set of options. You can control
140the formatting of each column, whether you prefer wide or fat, hex or decimal,
141leading zeroes or whatever.
142
143All you need to be able to use this is a C compiler than generates
1fef88e7 144BSD/GCC-style stabs. The B<-g> option on native BSD compilers and GCC
9aec1e06 145should get this for you.
146
1fef88e7 147To learn more, just type a bogus option, like B<-\?>, and a long usage message
9aec1e06 148will be provided. There are a fair number of possibilities.
149
150If you're only a C programmer, than this is the end of the message for you.
151You can quit right now, and if you care to, save off the source and run it
152when you feel like it. Or not.
153
154
155
156But if you're a perl programmer, then for you I have something much more
157wondrous than just a structure offset printer.
158
159You see, if you call pstruct by its other incybernation, c2ph, you have a code
160generator that translates C code into perl code! Well, structure and union
161declarations at least, but that's quite a bit.
162
163Prior to this point, anyone programming in perl who wanted to interact
164with C programs, like the kernel, was forced to guess the layouts of
165the C strutures, and then hardwire these into his program. Of course,
166when you took your wonderfully crafted program to a system where the
167sgtty structure was laid out differently, you program broke. Which is
168a shame.
169
170We've had Larry's h2ph translator, which helped, but that only works on
171cpp symbols, not real C, which was also very much needed. What I offer
172you is a symbolic way of getting at all the C structures. I've couched
173them in terms of packages and functions. Consider the following program:
174
175 #!/usr/local/bin/perl
176
177 require 'syscall.ph';
178 require 'sys/time.ph';
179 require 'sys/resource.ph';
180
181 $ru = "\0" x &rusage'sizeof();
182
183 syscall(&SYS_getrusage, &RUSAGE_SELF, $ru) && die "getrusage: $!";
184
185 @ru = unpack($t = &rusage'typedef(), $ru);
186
187 $utime = $ru[ &rusage'ru_utime + &timeval'tv_sec ]
188 + ($ru[ &rusage'ru_utime + &timeval'tv_usec ]) / 1e6;
189
190 $stime = $ru[ &rusage'ru_stime + &timeval'tv_sec ]
191 + ($ru[ &rusage'ru_stime + &timeval'tv_usec ]) / 1e6;
192
193 printf "you have used %8.3fs+%8.3fu seconds.\n", $utime, $stime;
194
195
196As you see, the name of the package is the name of the structure. Regular
1fef88e7 197fields are just their own names. Plus the following accessor functions are
9aec1e06 198provided for your convenience:
199
200 struct This takes no arguments, and is merely the number of first-level
201 elements in the structure. You would use this for indexing
202 into arrays of structures, perhaps like this
203
204
205 $usec = $u[ &user'u_utimer
206 + (&ITIMER_VIRTUAL * &itimerval'struct)
207 + &itimerval'it_value
208 + &timeval'tv_usec
209 ];
210
211 sizeof Returns the bytes in the structure, or the member if
212 you pass it an argument, such as
213
214 &rusage'sizeof(&rusage'ru_utime)
215
216 typedef This is the perl format definition for passing to pack and
217 unpack. If you ask for the typedef of a nothing, you get
218 the whole structure, otherwise you get that of the member
219 you ask for. Padding is taken care of, as is the magic to
220 guarantee that a union is unpacked into all its aliases.
221 Bitfields are not quite yet supported however.
222
223 offsetof This function is the byte offset into the array of that
224 member. You may wish to use this for indexing directly
225 into the packed structure with vec() if you're too lazy
226 to unpack it.
227
228 typeof Not to be confused with the typedef accessor function, this
229 one returns the C type of that field. This would allow
230 you to print out a nice structured pretty print of some
231 structure without knoning anything about it beforehand.
232 No args to this one is a noop. Someday I'll post such
233 a thing to dump out your u structure for you.
234
235
236The way I see this being used is like basically this:
237
238 % h2ph <some_include_file.h > /usr/lib/perl/tmp.ph
239 % c2ph some_include_file.h >> /usr/lib/perl/tmp.ph
240 % install
241
242It's a little tricker with c2ph because you have to get the includes right.
243I can't know this for your system, but it's not usually too terribly difficult.
244
245The code isn't pretty as I mentioned -- I never thought it would be a 1000-
246line program when I started, or I might not have begun. :-) But I would have
247been less cavalier in how the parts of the program communicated with each
248other, etc. It might also have helped if I didn't have to divine the makeup
249of the stabs on the fly, and then account for micro differences between my
250compiler and gcc.
251
252Anyway, here it is. Should run on perl v4 or greater. Maybe less.
253
254
1fef88e7 255 --tom
9aec1e06 256
257=cut
258
8e07c86e 259$RCSID = '$Id: c2ph,v 1.7 95/10/28 10:41:47 tchrist Exp Locker: tchrist $';
11aea360 260
261
262######################################################################
263
264# some handy data definitions. many of these can be reset later.
265
266$bitorder = 'b'; # ascending; set to B for descending bit fields
267
9aec1e06 268%intrinsics =
11aea360 269%template = (
270 'char', 'c',
271 'unsigned char', 'C',
272 'short', 's',
273 'short int', 's',
274 'unsigned short', 'S',
275 'unsigned short int', 'S',
276 'short unsigned int', 'S',
277 'int', 'i',
278 'unsigned int', 'I',
279 'long', 'l',
280 'long int', 'l',
281 'unsigned long', 'L',
282 'unsigned long', 'L',
283 'long unsigned int', 'L',
284 'unsigned long int', 'L',
285 'long long', 'q',
286 'long long int', 'q',
287 'unsigned long long', 'Q',
288 'unsigned long long int', 'Q',
289 'float', 'f',
290 'double', 'd',
291 'pointer', 'p',
292 'null', 'x',
293 'neganull', 'X',
294 'bit', $bitorder,
9aec1e06 295);
11aea360 296
297&buildscrunchlist;
298delete $intrinsics{'neganull'};
299delete $intrinsics{'bit'};
300delete $intrinsics{'null'};
301
302# use -s to recompute sizes
303%sizeof = (
304 'char', '1',
305 'unsigned char', '1',
306 'short', '2',
307 'short int', '2',
308 'unsigned short', '2',
309 'unsigned short int', '2',
310 'short unsigned int', '2',
311 'int', '4',
312 'unsigned int', '4',
313 'long', '4',
314 'long int', '4',
315 'unsigned long', '4',
316 'unsigned long int', '4',
317 'long unsigned int', '4',
318 'long long', '8',
319 'long long int', '8',
320 'unsigned long long', '8',
321 'unsigned long long int', '8',
322 'float', '4',
323 'double', '8',
324 'pointer', '4',
325);
326
327($type_width, $member_width, $offset_width, $size_width) = (20, 20, 6, 5);
328
329($offset_fmt, $size_fmt) = ('d', 'd');
330
331$indent = 2;
332
333$CC = 'cc';
334$CFLAGS = '-g -S';
335$DEFINES = '';
336
337$perl++ if $0 =~ m#/?c2ph$#;
338
339require 'getopts.pl';
340
341eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
342
343&Getopts('aixdpvtnws:') || &usage(0);
344
345$opt_d && $debug++;
346$opt_t && $trace++;
347$opt_p && $perl++;
348$opt_v && $verbose++;
349$opt_n && ($perl = 0);
350
351if ($opt_w) {
352 ($type_width, $member_width, $offset_width) = (45, 35, 8);
9aec1e06 353}
11aea360 354if ($opt_x) {
355 ($offset_fmt, $offset_width, $size_fmt, $size_width) = ( 'x', '08', 'x', 04 );
356}
357
358eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
359
360sub PLUMBER {
361 select(STDERR);
362 print "oops, apperent pager foulup\n";
363 $isatty++;
364 &usage(1);
9aec1e06 365}
11aea360 366
367sub usage {
368 local($oops) = @_;
369 unless (-t STDOUT) {
370 select(STDERR);
371 } elsif (!$oops) {
372 $isatty++;
373 $| = 1;
374 print "hit <RETURN> for further explanation: ";
375 <STDIN>;
376 open (PIPE, "|". ($ENV{PAGER} || 'more'));
377 $SIG{PIPE} = PLUMBER;
378 select(PIPE);
9aec1e06 379 }
11aea360 380
381 print "usage: $0 [-dpnP] [var=val] [files ...]\n";
382
383 exit unless $isatty;
384
385 print <<EOF;
386
387Options:
388
389-w wide; short for: type_width=45 member_width=35 offset_width=8
390-x hex; short for: offset_fmt=x offset_width=08 size_fmt=x size_width=04
391
392-n do not generate perl code (default when invoked as pstruct)
393-p generate perl code (default when invoked as c2ph)
394-v generate perl code, with C decls as comments
395
396-i do NOT recompute sizes for intrinsic datatypes
397-a dump information on intrinsics also
398
399-t trace execution
400-d spew reams of debugging output
401
402-slist give comma-separated list a structures to dump
403
404
405Var Name Default Value Meaning
406
407EOF
408
409 &defvar('CC', 'which_compiler to call');
410 &defvar('CFLAGS', 'how to generate *.s files with stabs');
411 &defvar('DEFINES','any extra cflags or cpp defines, like -I, -D, -U');
412
413 print "\n";
414
415 &defvar('type_width', 'width of type field (column 1)');
416 &defvar('member_width', 'width of member field (column 2)');
417 &defvar('offset_width', 'width of offset field (column 3)');
418 &defvar('size_width', 'width of size field (column 4)');
419
420 print "\n";
421
422 &defvar('offset_fmt', 'sprintf format type for offset');
423 &defvar('size_fmt', 'sprintf format type for size');
424
425 print "\n";
426
427 &defvar('indent', 'how far to indent each nesting level');
428
429 print <<'EOF';
430
431 If any *.[ch] files are given, these will be catted together into
432 a temporary *.c file and sent through:
9aec1e06 433 $CC $CFLAGS $DEFINES
11aea360 434 and the resulting *.s groped for stab information. If no files are
435 supplied, then stdin is read directly with the assumption that it
436 contains stab information. All other liens will be ignored. At
437 most one *.s file should be supplied.
438
439EOF
440 close PIPE;
441 exit 1;
9aec1e06 442}
11aea360 443
444sub defvar {
445 local($var, $msg) = @_;
446 printf "%-16s%-15s %s\n", $var, eval "\$$var", $msg;
9aec1e06 447}
11aea360 448
449$recurse = 1;
450
451if (@ARGV) {
452 if (grep(!/\.[csh]$/,@ARGV)) {
453 warn "Only *.[csh] files expected!\n";
454 &usage;
9aec1e06 455 }
11aea360 456 elsif (grep(/\.s$/,@ARGV)) {
9aec1e06 457 if (@ARGV > 1) {
11aea360 458 warn "Only one *.s file allowed!\n";
459 &usage;
460 }
9aec1e06 461 }
11aea360 462 elsif (@ARGV == 1 && $ARGV[0] =~ /\.c$/) {
463 local($dir, $file) = $ARGV[0] =~ m#(.*/)?(.*)$#;
464 $chdir = "cd $dir; " if $dir;
465 &system("$chdir$CC $CFLAGS $DEFINES $file") && exit 1;
466 $ARGV[0] =~ s/\.c$/.s/;
9aec1e06 467 }
11aea360 468 else {
469 $TMP = "/tmp/c2ph.$$.c";
470 &system("cat @ARGV > $TMP") && exit 1;
471 &system("cd /tmp; $CC $CFLAGS $DEFINES $TMP") && exit 1;
472 unlink $TMP;
473 $TMP =~ s/\.c$/.s/;
474 @ARGV = ($TMP);
9aec1e06 475 }
11aea360 476}
477
478if ($opt_s) {
479 for (split(/[\s,]+/, $opt_s)) {
480 $interested{$_}++;
9aec1e06 481 }
482}
11aea360 483
484
485$| = 1 if $debug;
486
487main: {
488
489 if ($trace) {
9aec1e06 490 if (-t && !@ARGV) {
11aea360 491 print STDERR "reading from your keyboard: ";
492 } else {
493 print STDERR "reading from " . (@ARGV ? "@ARGV" : "<STDIN>").": ";
494 }
495 }
496
497STAB: while (<>) {
498 if ($trace && !($. % 10)) {
499 $lineno = $..'';
500 print STDERR $lineno, "\b" x length($lineno);
9aec1e06 501 }
11aea360 502 next unless /^\s*\.stabs\s+/;
503 $line = $_;
9aec1e06 504 s/^\s*\.stabs\s+//;
8e07c86e 505 if (s/\\\\"[d,]+$//) {
506 $saveline .= $line;
507 $savebar = $_;
508 next STAB;
9aec1e06 509 }
8e07c86e 510 if ($saveline) {
511 s/^"//;
512 $_ = $savebar . $_;
513 $line = $saveline;
9aec1e06 514 }
515 &stab;
8e07c86e 516 $savebar = $saveline = undef;
11aea360 517 }
518 print STDERR "$.\n" if $trace;
519 unlink $TMP if $TMP;
520
521 &compute_intrinsics if $perl && !$opt_i;
522
523 print STDERR "resolving types\n" if $trace;
524
525 &resolve_types;
526 &adjust_start_addrs;
527
528 $sum = 2 + $type_width + $member_width;
9aec1e06 529 $pmask1 = "%-${type_width}s %-${member_width}s";
11aea360 530 $pmask2 = "%-${sum}s %${offset_width}${offset_fmt}%s %${size_width}${size_fmt}%s";
531
8e07c86e 532
533
11aea360 534 if ($perl) {
535 # resolve template -- should be in stab define order, but even this isn't enough.
536 print STDERR "\nbuilding type templates: " if $trace;
537 for $i (reverse 0..$#type) {
538 next unless defined($name = $type[$i]);
539 next unless defined $struct{$name};
8e07c86e 540 ($iname = $name) =~ s/\..*//;
11aea360 541 $build_recursed = 0;
542 &build_template($name) unless defined $template{&psou($name)} ||
8e07c86e 543 $opt_s && !$interested{$iname};
9aec1e06 544 }
11aea360 545 print STDERR "\n\n" if $trace;
546 }
547
548 print STDERR "dumping structs: " if $trace;
549
8e07c86e 550 local($iam);
551
552
11aea360 553
554 foreach $name (sort keys %struct) {
8e07c86e 555 ($iname = $name) =~ s/\..*//;
556 next if $opt_s && !$interested{$iname};
11aea360 557 print STDERR "$name " if $trace;
558
559 undef @sizeof;
560 undef @typedef;
561 undef @offsetof;
562 undef @indices;
563 undef @typeof;
8e07c86e 564 undef @fieldnames;
11aea360 565
566 $mname = &munge($name);
567
568 $fname = &psou($name);
569
570 print "# " if $perl && $verbose;
571 $pcode = '';
9aec1e06 572 print "$fname {\n" if !$perl || $verbose;
11aea360 573 $template{$fname} = &scrunch($template{$fname}) if $perl;
9aec1e06 574 &pstruct($name,$name,0);
11aea360 575 print "# " if $perl && $verbose;
9aec1e06 576 print "}\n" if !$perl || $verbose;
11aea360 577 print "\n" if $perl && $verbose;
578
579 if ($perl) {
580 print "$pcode";
581
582 printf("\nsub %-32s { %4d; }\n\n", "${mname}'struct", $countof{$name});
583
584 print <<EOF;
9aec1e06 585sub ${mname}'typedef {
11aea360 586 local(\$${mname}'index) = shift;
9aec1e06 587 defined \$${mname}'index
588 ? \$${mname}'typedef[\$${mname}'index]
11aea360 589 : \$${mname}'typedef;
590}
591EOF
592
593 print <<EOF;
9aec1e06 594sub ${mname}'sizeof {
11aea360 595 local(\$${mname}'index) = shift;
9aec1e06 596 defined \$${mname}'index
597 ? \$${mname}'sizeof[\$${mname}'index]
11aea360 598 : \$${mname}'sizeof;
599}
600EOF
601
602 print <<EOF;
9aec1e06 603sub ${mname}'offsetof {
11aea360 604 local(\$${mname}'index) = shift;
9aec1e06 605 defined \$${mname}index
606 ? \$${mname}'offsetof[\$${mname}'index]
11aea360 607 : \$${mname}'sizeof;
608}
609EOF
610
611 print <<EOF;
9aec1e06 612sub ${mname}'typeof {
11aea360 613 local(\$${mname}'index) = shift;
9aec1e06 614 defined \$${mname}index
615 ? \$${mname}'typeof[\$${mname}'index]
11aea360 616 : '$name';
617}
618EOF
9aec1e06 619
8e07c86e 620 print <<EOF;
9aec1e06 621sub ${mname}'fieldnames {
622 \@${mname}'fieldnames;
8e07c86e 623}
624EOF
625
626 $iam = ($isastruct{$name} && 's') || ($isaunion{$name} && 'u');
9aec1e06 627
8e07c86e 628 print <<EOF;
9aec1e06 629sub ${mname}'isastruct {
630 '$iam';
8e07c86e 631}
632EOF
11aea360 633
9aec1e06 634 print "\$${mname}'typedef = '" . &scrunch($template{$fname})
11aea360 635 . "';\n";
636
637 print "\$${mname}'sizeof = $sizeof{$name};\n\n";
638
639
640 print "\@${mname}'indices = (", &squishseq(@indices), ");\n";
641
642 print "\n";
643
644 print "\@${mname}'typedef[\@${mname}'indices] = (",
645 join("\n\t", '', @typedef), "\n );\n\n";
646 print "\@${mname}'sizeof[\@${mname}'indices] = (",
647 join("\n\t", '', @sizeof), "\n );\n\n";
648 print "\@${mname}'offsetof[\@${mname}'indices] = (",
649 join("\n\t", '', @offsetof), "\n );\n\n";
650 print "\@${mname}'typeof[\@${mname}'indices] = (",
651 join("\n\t", '', @typeof), "\n );\n\n";
8e07c86e 652 print "\@${mname}'fieldnames[\@${mname}'indices] = (",
653 join("\n\t", '', @fieldnames), "\n );\n\n";
11aea360 654
655 $template_printed{$fname}++;
656 $size_printed{$fname}++;
9aec1e06 657 }
11aea360 658 print "\n";
659 }
660
661 print STDERR "\n" if $trace;
662
9aec1e06 663 unless ($perl && $opt_a) {
8e07c86e 664 print "\n1;\n" if $perl;
11aea360 665 exit;
666 }
667
668
669
670 foreach $name (sort bysizevalue keys %intrinsics) {
671 next if $size_printed{$name};
672 print '$',&munge($name),"'sizeof = ", $sizeof{$name}, ";\n";
673 }
674
675 print "\n";
676
677 sub bysizevalue { $sizeof{$a} <=> $sizeof{$b}; }
678
679
680 foreach $name (sort keys %intrinsics) {
681 print '$',&munge($name),"'typedef = '", $template{$name}, "';\n";
682 }
683
8e07c86e 684 print "\n1;\n" if $perl;
9aec1e06 685
11aea360 686 exit;
687}
688
689########################################################################################
690
691
692sub stab {
8e07c86e 693 next unless $continued || /:[\$\w]+(\(\d+,\d+\))?=[\*\$\w]+/; # (\d+,\d+) is for sun
11aea360 694 s/"// || next;
695 s/",([x\d]+),([x\d]+),([x\d]+),.*// || next;
696
697 next if /^\s*$/;
698
699 $size = $3 if $3;
8e07c86e 700 $_ = $continued . $_ if length($continued);
701 if (s/\\\\$//) {
702 # if last 2 chars of string are '\\' then stab is continued
703 # in next stab entry
704 chop;
705 $continued = $_;
706 next;
707 }
708 $continued = '';
11aea360 709
710
711 $line = $_;
712
713 if (($name, $pdecl) = /^([\$ \w]+):[tT]((\d+)(=[rufs*](\d+))+)$/) {
714 print "$name is a typedef for some funky pointers: $pdecl\n" if $debug;
715 &pdecl($pdecl);
716 next;
717 }
718
719
720
9aec1e06 721 if (/(([ \w]+):t(\d+|\(\d+,\d+\)))=r?(\d+|\(\d+,\d+\))(;\d+;\d+;)?/) {
11aea360 722 local($ident) = $2;
723 push(@intrinsics, $ident);
724 $typeno = &typeno($3);
725 $type[$typeno] = $ident;
9aec1e06 726 print STDERR "intrinsic $ident in new type $typeno\n" if $debug;
11aea360 727 next;
728 }
729
9aec1e06 730 if (($name, $typeordef, $typeno, $extra, $struct, $_)
731 = /^([\$ \w]+):([ustT])(\d+|\(\d+,\d+\))(=[rufs*](\d+))?(.*)$/)
11aea360 732 {
733 $typeno = &typeno($typeno); # sun foolery
9aec1e06 734 }
11aea360 735 elsif (/^[\$\w]+:/) {
736 next; # variable
737 }
9aec1e06 738 else {
11aea360 739 warn "can't grok stab: <$_> in: $line " if $_;
740 next;
9aec1e06 741 }
11aea360 742
743 #warn "got size $size for $name\n";
744 $sizeof{$name} = $size if $size;
745
746 s/;[-\d]*;[-\d]*;$//; # we don't care about ranges
747
748 $typenos{$name} = $typeno;
749
750 unless (defined $type[$typeno]) {
751 &panic("type 0??") unless $typeno;
752 $type[$typeno] = $name unless defined $type[$typeno];
753 printf "new type $typeno is $name" if $debug;
754 if ($extra =~ /\*/ && defined $type[$struct]) {
755 print ", a typedef for a pointer to " , $type[$struct] if $debug;
756 }
757 } else {
758 printf "%s is type %d", $name, $typeno if $debug;
759 print ", a typedef for " , $type[$typeno] if $debug;
9aec1e06 760 }
11aea360 761 print "\n" if $debug;
762 #next unless $extra =~ /[su*]/;
763
764 #$type[$struct] = $name;
765
766 if ($extra =~ /[us*]/) {
767 &sou($name, $extra);
768 $_ = &sdecl($name, $_, 0);
769 }
770 elsif (/^=ar/) {
771 print "it's a bare array typedef -- that's pretty sick\n" if $debug;
772 $_ = "$typeno$_";
773 $scripts = '';
774 $_ = &adecl($_,1);
775
776 }
777 elsif (s/((\w+):t(\d+|\(\d+,\d+\)))?=r?(;\d+;\d+;)?//) { # the ?'s are for gcc
778 push(@intrinsics, $2);
779 $typeno = &typeno($3);
780 $type[$typeno] = $2;
9aec1e06 781 print STDERR "intrinsic $2 in new type $typeno\n" if $debug;
11aea360 782 }
8e07c86e 783 elsif (s/^=e//) { # blessed be thy compiler; mine won't do this
11aea360 784 &edecl;
9aec1e06 785 }
11aea360 786 else {
787 warn "Funny remainder for $name on line $_ left in $line " if $_;
9aec1e06 788 }
11aea360 789}
790
791sub typeno { # sun thinks types are (0,27) instead of just 27
792 local($_) = @_;
793 s/\(\d+,(\d+)\)/$1/;
794 $_;
9aec1e06 795}
11aea360 796
797sub pstruct {
9aec1e06 798 local($what,$prefix,$base) = @_;
799 local($field, $fieldname, $typeno, $count, $offset, $entry);
11aea360 800 local($fieldtype);
9aec1e06 801 local($type, $tname);
11aea360 802 local($mytype, $mycount, $entry2);
803 local($struct_count) = 0;
804 local($pad, $revpad, $length, $prepad, $lastoffset, $lastlength, $fmt);
805 local($bits,$bytes);
806 local($template);
807
808
809 local($mname) = &munge($name);
810
9aec1e06 811 sub munge {
11aea360 812 local($_) = @_;
813 s/[\s\$\.]/_/g;
814 $_;
815 }
816
817 local($sname) = &psou($what);
818
819 $nesting++;
820
821 for $field (split(/;/, $struct{$what})) {
822 $pad = $prepad = 0;
9aec1e06 823 $entry = '';
824 ($fieldname, $typeno, $count, $offset, $length) = split(/,/, $field);
11aea360 825
826 $type = $type[$typeno];
827
828 $type =~ /([^[]*)(\[.*\])?/;
829 $mytype = $1;
830 $count .= $2;
831 $fieldtype = &psou($mytype);
832
833 local($fname) = &psou($name);
834
835 if ($build_templates) {
836
9aec1e06 837 $pad = ($offset - ($lastoffset + $lastlength))/8
11aea360 838 if defined $lastoffset;
839
840 if (! $finished_template{$sname}) {
841 if ($isaunion{$what}) {
842 $template{$sname} .= 'X' x $revpad . ' ' if $revpad;
843 } else {
844 $template{$sname} .= 'x' x $pad . ' ' if $pad;
845 }
846 }
847
8e07c86e 848 $template = &fetch_template($type);
849 &repeat_template($template,$count);
11aea360 850
851 if (! $finished_template{$sname}) {
852 $template{$sname} .= $template;
853 }
854
855 $revpad = $length/8 if $isaunion{$what};
856
857 ($lastoffset, $lastlength) = ($offset, $length);
858
9aec1e06 859 } else {
11aea360 860 print '# ' if $perl && $verbose;
861 $entry = sprintf($pmask1,
862 ' ' x ($nesting * $indent) . $fieldtype,
9aec1e06 863 "$prefix.$fieldname" . $count);
11aea360 864
9aec1e06 865 $entry =~ s/(\*+)( )/$2$1/;
11aea360 866
867 printf $pmask2,
868 $entry,
869 ($base+$offset)/8,
870 ($bits = ($base+$offset)%8) ? ".$bits" : " ",
871 $length/8,
872 ($bits = $length % 8) ? ".$bits": ""
873 if !$perl || $verbose;
874
8e07c86e 875 if ($perl) {
876 $template = &fetch_template($type);
877 &repeat_template($template,$count);
878 }
11aea360 879
880 if ($perl && $nesting == 1) {
8e07c86e 881
11aea360 882 push(@sizeof, int($length/8) .",\t# $fieldname");
883 push(@offsetof, int($offset/8) .",\t# $fieldname");
8e07c86e 884 local($little) = &scrunch($template);
885 push(@typedef, "'$little', \t# $fieldname");
11aea360 886 $type =~ s/(struct|union) //;
8e07c86e 887 push(@typeof, "'$mytype" . ($count ? $count : '') .
11aea360 888 "',\t# $fieldname");
8e07c86e 889 push(@fieldnames, "'$fieldname',");
11aea360 890 }
891
892 print ' ', ' ' x $indent x $nesting, $template
893 if $perl && $verbose;
894
895 print "\n" if !$perl || $verbose;
896
9aec1e06 897 }
11aea360 898 if ($perl) {
899 local($mycount) = defined $struct{$mytype} ? $countof{$mytype} : 1;
900 $mycount *= &scripts2count($count) if $count;
901 if ($nesting==1 && !$build_templates) {
9aec1e06 902 $pcode .= sprintf("sub %-32s { %4d; }\n",
11aea360 903 "${mname}'${fieldname}", $struct_count);
904 push(@indices, $struct_count);
905 }
906 $struct_count += $mycount;
9aec1e06 907 }
11aea360 908
909
9aec1e06 910 &pstruct($type, "$prefix.$fieldname", $base+$offset)
911 if $recurse && defined $struct{$type};
11aea360 912 }
913
914 $countof{$what} = $struct_count unless defined $countof{$whati};
915
916 $template{$sname} .= '$' if $build_templates;
917 $finished_template{$sname}++;
918
919 if ($build_templates && !defined $sizeof{$name}) {
920 local($fmt) = &scrunch($template{$sname});
921 print STDERR "no size for $name, punting with $fmt..." if $debug;
922 eval '$sizeof{$name} = length(pack($fmt, ()))';
923 if ($@) {
924 chop $@;
925 warn "couldn't get size for \$name: $@";
926 } else {
927 print STDERR $sizeof{$name}, "\n" if $debUg;
928 }
9aec1e06 929 }
11aea360 930
931 --$nesting;
932}
933
934
935sub psize {
9aec1e06 936 local($me) = @_;
11aea360 937 local($amstruct) = $struct{$me} ? 'struct ' : '';
938
9aec1e06 939 print '$sizeof{\'', $amstruct, $me, '\'} = ';
940 printf "%d;\n", $sizeof{$me};
11aea360 941}
942
943sub pdecl {
944 local($pdecl) = @_;
945 local(@pdecls);
946 local($tname);
947
948 warn "pdecl: $pdecl\n" if $debug;
949
950 $pdecl =~ s/\(\d+,(\d+)\)/$1/g;
9aec1e06 951 $pdecl =~ s/\*//g;
952 @pdecls = split(/=/, $pdecl);
11aea360 953 $typeno = $pdecls[0];
954 $tname = pop @pdecls;
955
9aec1e06 956 if ($tname =~ s/^f//) { $tname = "$tname&"; }
957 #else { $tname = "$tname*"; }
11aea360 958
959 for (reverse @pdecls) {
9aec1e06 960 $tname .= s/^f// ? "&" : "*";
11aea360 961 #$tname =~ s/^f(.*)/$1&/;
962 print "type[$_] is $tname\n" if $debug;
963 $type[$_] = $tname unless defined $type[$_];
9aec1e06 964 }
11aea360 965}
966
967
968
969sub adecl {
970 ($arraytype, $unknown, $lower, $upper) = ();
971 #local($typeno);
972 # global $typeno, @type
973 local($_, $typedef) = @_;
974
8e07c86e 975 while (s/^((\d+|\(\d+,\d+\))=)?ar(\d+|\(\d+,\d+\));//) {
9aec1e06 976 ($arraytype, $unknown) = ($2, $3);
8e07c86e 977 $arraytype = &typeno($arraytype);
978 $unknown = &typeno($unknown);
11aea360 979 if (s/^(\d+);(\d+);//) {
9aec1e06 980 ($lower, $upper) = ($1, $2);
981 $scripts .= '[' . ($upper+1) . ']';
11aea360 982 } else {
9aec1e06 983 warn "can't find array bounds: $_";
984 }
11aea360 985 }
8e07c86e 986 if (s/^([(,)\d*f=]*),(\d+),(\d+);//) {
9aec1e06 987 ($start, $length) = ($2, $3);
8e07c86e 988 $whatis = $1;
989 if ($whatis =~ /^(\d+|\(\d+,\d+\))=/) {
990 $typeno = &typeno($1);
11aea360 991 &pdecl($whatis);
992 } else {
8e07c86e 993 $typeno = &typeno($whatis);
11aea360 994 }
995 } elsif (s/^(\d+)(=[*suf]\d*)//) {
9aec1e06 996 local($whatis) = $2;
11aea360 997
998 if ($whatis =~ /[f*]/) {
9aec1e06 999 &pdecl($whatis);
1000 } elsif ($whatis =~ /[su]/) { #
1001 print "$prefix.$fieldname is an array$scripts anon structs; disgusting\n"
11aea360 1002 if $debug;
1003 #$type[$typeno] = $name unless defined $type[$typeno];
1004 ##printf "new type $typeno is $name" if $debug;
1005 $typeno = $1;
1006 $type[$typeno] = "$prefix.$fieldname";
1007 local($name) = $type[$typeno];
1008 &sou($name, $whatis);
1009 $_ = &sdecl($name, $_, $start+$offset);
1010 1;
1011 $start = $start{$name};
1012 $offset = $sizeof{$name};
1013 $length = $offset;
1014 } else {
1015 warn "what's this? $whatis in $line ";
9aec1e06 1016 }
11aea360 1017 } elsif (/^\d+$/) {
1018 $typeno = $_;
1019 } else {
1020 warn "bad array stab: $_ in $line ";
1021 next STAB;
9aec1e06 1022 }
11aea360 1023 #local($wasdef) = defined($type[$typeno]) && $debug;
9aec1e06 1024 #if ($typedef) {
11aea360 1025 #print "redefining $type[$typeno] to " if $wasdef;
1026 #$type[$typeno] = "$whatis$scripts"; # unless defined $type[$typeno];
1027 #print "$type[$typeno]\n" if $wasdef;
1028 #} else {
1029 #$type[$arraytype] = $type[$typeno] unless defined $type[$arraytype];
1030 #}
1031 $type[$arraytype] = "$type[$typeno]$scripts" if defined $type[$typeno];
1032 print "type[$arraytype] is $type[$arraytype]\n" if $debug;
1033 print "$prefix.$fieldname is an array of $type[$arraytype]\n" if $debug;
1034 $_;
1035}
1036
1037
1038
1039sub sdecl {
1040 local($prefix, $_, $offset) = @_;
1041
1042 local($fieldname, $scripts, $type, $arraytype, $unknown,
1043 $whatis, $pdecl, $upper,$lower, $start,$length) = ();
1044 local($typeno,$sou);
1045
1046
1047SFIELD:
1048 while (/^([^;]+);/) {
1049 $scripts = '';
1050 warn "sdecl $_\n" if $debug;
9aec1e06 1051 if (s/^([\$\w]+)://) {
11aea360 1052 $fieldname = $1;
9aec1e06 1053 } elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { #
11aea360 1054 $typeno = &typeno($1);
1055 $type[$typeno] = "$prefix.$fieldname";
1056 local($name) = "$prefix.$fieldname";
1057 &sou($name,$2);
1058 $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
1059 $start = $start{$name};
1060 $offset += $sizeof{$name};
1061 #print "done with anon, start is $start, offset is $offset\n";
1062 #next SFIELD;
1063 } else {
1064 warn "weird field $_ of $line" if $debug;
1065 next STAB;
1066 #$fieldname = &gensym;
1067 #$_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
1068 }
1069
8e07c86e 1070 if (/^(\d+|\(\d+,\d+\))=ar/) {
11aea360 1071 $_ = &adecl($_);
1072 }
1073 elsif (s/^(\d+|\(\d+,\d+\))?,(\d+),(\d+);//) {
8e07c86e 1074 ($start, $length) = ($2, $3);
1075 &panic("no length?") unless $length;
1076 $typeno = &typeno($1) if $1;
1077 }
1078 elsif (s/^(\d+)=xs\w+:,(\d+),(\d+);//) {
9aec1e06 1079 ($start, $length) = ($2, $3);
11aea360 1080 &panic("no length?") unless $length;
1081 $typeno = &typeno($1) if $1;
1082 }
1083 elsif (s/^((\d+|\(\d+,\d+\))(=[*f](\d+|\(\d+,\d+\)))+),(\d+),(\d+);//) {
9aec1e06 1084 ($pdecl, $start, $length) = ($1,$5,$6);
1085 &pdecl($pdecl);
11aea360 1086 }
1087 elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # the dratted anon struct
1088 ($typeno, $sou) = ($1, $2);
1089 $typeno = &typeno($typeno);
1090 if (defined($type[$typeno])) {
1091 warn "now how did we get type $1 in $fieldname of $line?";
1092 } else {
1093 print "anon type $typeno is $prefix.$fieldname\n" if $debug;
1094 $type[$typeno] = "$prefix.$fieldname" unless defined $type[$typeno];
1095 };
1096 local($name) = "$prefix.$fieldname";
1097 &sou($name,$sou);
1098 print "anon ".($isastruct{$name}) ? "struct":"union"." for $prefix.$fieldname\n" if $debug;
1099 $type[$typeno] = "$prefix.$fieldname";
9aec1e06 1100 $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
11aea360 1101 $start = $start{$name};
1102 $length = $sizeof{$name};
1103 }
1104 else {
9aec1e06 1105 warn "can't grok stab for $name ($_) in line $line ";
1106 next STAB;
11aea360 1107 }
1108
1109 &panic("no length for $prefix.$fieldname") unless $length;
1110 $struct{$name} .= join(',', $fieldname, $typeno, $scripts, $start, $length) . ';';
1111 }
1112 if (s/;\d*,(\d+),(\d+);//) {
9aec1e06 1113 local($start, $size) = ($1, $2);
11aea360 1114 $sizeof{$prefix} = $size;
9aec1e06 1115 print "start of $prefix is $start, size of $sizeof{$prefix}\n" if $debug;
1116 $start{$prefix} = $start;
1117 }
11aea360 1118 $_;
1119}
1120
1121sub edecl {
1122 s/;$//;
1123 $enum{$name} = $_;
1124 $_ = '';
9aec1e06 1125}
11aea360 1126
1127sub resolve_types {
1128 local($sou);
1129 for $i (0 .. $#type) {
1130 next unless defined $type[$i];
1131 $_ = $type[$i];
1132 unless (/\d/) {
1133 print "type[$i] $type[$i]\n" if $debug;
1134 next;
1135 }
1136 print "type[$i] $_ ==> " if $debug;
1137 s/^(\d+)(\**)\&\*(\**)/"$2($3".&type($1) . ')()'/e;
9aec1e06 1138 s/^(\d+)\&/&type($1)/e;
1139 s/^(\d+)/&type($1)/e;
11aea360 1140 s/(\*+)([^*]+)(\*+)/$1$3$2/;
1141 s/\((\*+)(\w+)(\*+)\)/$3($1$2)/;
1142 s/^(\d+)([\*\[].*)/&type($1).$2/e;
1143 #s/(\d+)(\*|(\[[\[\]\d\*]+]\])+)/&type($1).$2/ge;
1144 $type[$i] = $_;
1145 print "$_\n" if $debug;
1146 }
1147}
9aec1e06 1148sub type { &psou($type[$_[0]] || "<UNDEFINED>"); }
11aea360 1149
1150sub adjust_start_addrs {
1151 for (sort keys %start) {
1152 ($basename = $_) =~ s/\.[^.]+$//;
1153 $start{$_} += $start{$basename};
1154 print "start: $_ @ $start{$_}\n" if $debug;
1155 }
1156}
1157
1158sub sou {
1159 local($what, $_) = @_;
1160 /u/ && $isaunion{$what}++;
1161 /s/ && $isastruct{$what}++;
1162}
1163
1164sub psou {
1165 local($what) = @_;
1166 local($prefix) = '';
1167 if ($isaunion{$what}) {
1168 $prefix = 'union ';
1169 } elsif ($isastruct{$what}) {
1170 $prefix = 'struct ';
1171 }
1172 $prefix . $what;
1173}
1174
1175sub scrunch {
1176 local($_) = @_;
1177
8e07c86e 1178 return '' if $_ eq '';
1179
11aea360 1180 study;
1181
1182 s/\$//g;
1183 s/ / /g;
1184 1 while s/(\w) \1/$1$1/g;
1185
1186 # i wanna say this, but perl resists my efforts:
1187 # s/(\w)(\1+)/$2 . length($1)/ge;
1188
1189 &quick_scrunch;
1190
1191 s/ $//;
1192
1193 $_;
1194}
1195
1196sub buildscrunchlist {
1197 $scrunch_code = "sub quick_scrunch {\n";
1198 for (values %intrinsics) {
4633a7c4 1199 $scrunch_code .= "\ts/(${_}{2,})/'$_' . length(\$1)/ge;\n";
9aec1e06 1200 }
11aea360 1201 $scrunch_code .= "}\n";
1202 print "$scrunch_code" if $debug;
1203 eval $scrunch_code;
1204 &panic("can't eval scrunch_code $@ \nscrunch_code") if $@;
9aec1e06 1205}
11aea360 1206
1207sub fetch_template {
1208 local($mytype) = @_;
1209 local($fmt);
1210 local($count) = 1;
1211
1212 &panic("why do you care?") unless $perl;
1213
1214 if ($mytype =~ s/(\[\d+\])+$//) {
1215 $count .= $1;
9aec1e06 1216 }
11aea360 1217
1218 if ($mytype =~ /\*/) {
1219 $fmt = $template{'pointer'};
9aec1e06 1220 }
11aea360 1221 elsif (defined $template{$mytype}) {
1222 $fmt = $template{$mytype};
9aec1e06 1223 }
11aea360 1224 elsif (defined $struct{$mytype}) {
1225 if (!defined $template{&psou($mytype)}) {
1226 &build_template($mytype) unless $mytype eq $name;
9aec1e06 1227 }
11aea360 1228 elsif ($template{&psou($mytype)} !~ /\$$/) {
1229 #warn "incomplete template for $mytype\n";
9aec1e06 1230 }
11aea360 1231 $fmt = $template{&psou($mytype)} || '?';
9aec1e06 1232 }
11aea360 1233 else {
1234 warn "unknown fmt for $mytype\n";
1235 $fmt = '?';
9aec1e06 1236 }
11aea360 1237
1238 $fmt x $count . ' ';
1239}
1240
1241sub compute_intrinsics {
1242 local($TMP) = "/tmp/c2ph-i.$$.c";
1243 open (TMP, ">$TMP") || die "can't open $TMP: $!";
1244 select(TMP);
1245
1246 print STDERR "computing intrinsic sizes: " if $trace;
1247
1248 undef %intrinsics;
1249
1250 print <<'EOF';
1251main() {
1252 char *mask = "%d %s\n";
1253EOF
1254
1255 for $type (@intrinsics) {
88793d73 1256 next if !$type || $type eq 'void' || $type =~ /complex/; # sun stuff
11aea360 1257 print <<"EOF";
1258 printf(mask,sizeof($type), "$type");
1259EOF
9aec1e06 1260 }
11aea360 1261
1262 print <<'EOF';
1263 printf(mask,sizeof(char *), "pointer");
1264 exit(0);
1265}
1266EOF
1267 close TMP;
1268
1269 select(STDOUT);
1270 open(PIPE, "cd /tmp && $CC $TMP && /tmp/a.out|");
1271 while (<PIPE>) {
1272 chop;
1273 split(' ',$_,2);;
1274 print "intrinsic $_[1] is size $_[0]\n" if $debug;
1275 $sizeof{$_[1]} = $_[0];
1276 $intrinsics{$_[1]} = $template{$_[0]};
9aec1e06 1277 }
11aea360 1278 close(PIPE) || die "couldn't read intrinsics!";
1279 unlink($TMP, '/tmp/a.out');
1280 print STDERR "done\n" if $trace;
9aec1e06 1281}
11aea360 1282
1283sub scripts2count {
1284 local($_) = @_;
1285
1286 s/^\[//;
1287 s/\]$//;
1288 s/\]\[/*/g;
1289 $_ = eval;
1290 &panic("$_: $@") if $@;
1291 $_;
1292}
1293
1294sub system {
1295 print STDERR "@_\n" if $trace;
1296 system @_;
9aec1e06 1297}
11aea360 1298
9aec1e06 1299sub build_template {
11aea360 1300 local($name) = @_;
1301
1302 &panic("already got a template for $name") if defined $template{$name};
1303
1304 local($build_templates) = 1;
1305
1306 local($lparen) = '(' x $build_recursed;
1307 local($rparen) = ')' x $build_recursed;
1308
1309 print STDERR "$lparen$name$rparen " if $trace;
1310 $build_recursed++;
1311 &pstruct($name,$name,0);
1312 print STDERR "TEMPLATE for $name is ", $template{&psou($name)}, "\n" if $debug;
1313 --$build_recursed;
1314}
1315
1316
1317sub panic {
1318
1319 select(STDERR);
1320
1321 print "\npanic: @_\n";
1322
1323 exit 1 if $] <= 4.003; # caller broken
1324
1325 local($i,$_);
1326 local($p,$f,$l,$s,$h,$a,@a,@sub);
1327 for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
1328 @a = @DB'args;
1329 for (@a) {
1330 if (/^StB\000/ && length($_) == length($_main{'_main'})) {
1331 $_ = sprintf("%s",$_);
1332 }
1333 else {
1334 s/'/\\'/g;
1335 s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
1336 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1337 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1338 }
1339 }
1340 $w = $w ? '@ = ' : '$ = ';
1341 $a = $h ? '(' . join(', ', @a) . ')' : '';
1342 push(@sub, "$w&$s$a from file $f line $l\n");
1343 last if $signal;
1344 }
1345 for ($i=0; $i <= $#sub; $i++) {
1346 last if $signal;
1347 print $sub[$i];
1348 }
1349 exit 1;
9aec1e06 1350}
11aea360 1351
1352sub squishseq {
1353 local($num);
1354 local($last) = -1e8;
1355 local($string);
1356 local($seq) = '..';
1357
1358 while (defined($num = shift)) {
1359 if ($num == ($last + 1)) {
1360 $string .= $seq unless $inseq++;
1361 $last = $num;
1362 next;
1363 } elsif ($inseq) {
1364 $string .= $last unless $last == -1e8;
1365 }
1366
1367 $string .= ',' if defined $string;
1368 $string .= $num;
1369 $last = $num;
1370 $inseq = 0;
1371 }
1372 $string .= $last if $inseq && $last != -e18;
1373 $string;
1374}
8e07c86e 1375
1376sub repeat_template {
1377 # local($template, $scripts) = @_; have to change caller's values
1378
9aec1e06 1379 if ( $_[1] ) {
8e07c86e 1380 local($ncount) = &scripts2count($_[1]);
1381 if ($_[0] =~ /^\s*c\s*$/i) {
1382 $_[0] = "A$ncount ";
1383 $_[1] = '';
1384 } else {
1385 $_[0] = $template x $ncount;
1386 }
1387 }
1388}
4633a7c4 1389!NO!SUBS!
1390
1391close OUT or die "Can't close $file: $!";
1392chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
1393unlink 'pstruct';
9aec1e06 1394print "Linking c2ph to pstruct.\n";
3a8dc7fa 1395if (defined $Config{d_link}) {
1396 link 'c2ph', 'pstruct';
1397} else {
1398 unshift @INC, '../lib';
1399 require File::Copy;
1400 File::Copy::syscopy('c2ph', 'pstruct');
1401}
4633a7c4 1402exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
8a5546a1 1403chdir $origdir;