4 use File::Basename qw(&basename &dirname);
8 sub link { # This is a cut-down version of installperl:link().
13 CORE::link($from, $to)
15 : ($from =~ m#^/afs/# || $to =~ m#^/afs/#)
16 ? die "AFS" # okay inside eval {}
17 : die "Couldn't link $from to $to: $!\n";
22 File::Copy::copy($from, $to)
24 : warn "Couldn't copy $from to $to: $!\n";
29 # List explicitly here the variables you want Configure to
30 # generate. Metaconfig only looks for shell variables, so you
31 # have to mention them as if they were shell variables, not
32 # %Config entries. Thus you write
34 # to ensure Configure will look for $Config{startperl}.
36 # This forces PL files to create target in same directory as PL file.
37 # This is so that make depend always knows where to find PL derivatives.
40 $file = basename($0, '.PL');
41 $file .= '.com' if $^O eq 'VMS';
43 open OUT,">$file" or die "Can't create $file: $!";
45 print "Extracting $file (with variable substitutions)\n";
47 # In this section, perl variables will be expanded during extraction.
48 # You can use $Config{...} to use Configure variables.
50 print OUT <<"!GROK!THIS!";
52 eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
53 if \$running_under_some_shell;
56 # In the following, perl variables are not expanded during extraction.
58 print OUT <<'!NO!SUBS!';
62 # Tom Christiansen, <tchrist@convex.com>
64 # As pstruct, dump C structures as generated from 'cc -g -S' stabs.
65 # As c2ph, do this PLUS generate perl code for getting at the structures.
67 # See the usage message for more. If this isn't enough, read the code.
72 c2ph, pstruct - Dump C structures as generated from C<cc -g -S> stabs
76 c2ph [-dpnP] [var=val] [files ...]
82 -w wide; short for: type_width=45 member_width=35 offset_width=8
83 -x hex; short for: offset_fmt=x offset_width=08 size_fmt=x size_width=04
85 -n do not generate perl code (default when invoked as pstruct)
86 -p generate perl code (default when invoked as c2ph)
87 -v generate perl code, with C decls as comments
89 -i do NOT recompute sizes for intrinsic datatypes
90 -a dump information on intrinsics also
93 -d spew reams of debugging output
95 -slist give comma-separated list a structures to dump
99 The following is the old c2ph.doc documentation by Tom Christiansen
101 Date: 25 Jul 91 08:10:21 GMT
103 Once upon a time, I wrote a program called pstruct. It was a perl
104 program that tried to parse out C structures and display their member
105 offsets for you. This was especially useful for people looking at
106 binary dumps or poking around the kernel.
108 Pstruct was not a pretty program. Neither was it particularly robust.
109 The problem, you see, was that the C compiler was much better at parsing
110 C than I could ever hope to be.
112 So I got smart: I decided to be lazy and let the C compiler parse the C,
113 which would spit out debugger stabs for me to read. These were much
114 easier to parse. It's still not a pretty program, but at least it's more
117 Pstruct takes any .c or .h files, or preferably .s ones, since that's
118 the format it is going to massage them into anyway, and spits out
122 int tty.t_locker 000 4
123 int tty.t_mutex_index 004 4
124 struct tty * tty.t_tp_virt 008 4
125 struct clist tty.t_rawq 00c 20
126 int tty.t_rawq.c_cc 00c 4
127 int tty.t_rawq.c_cmax 010 4
128 int tty.t_rawq.c_cfx 014 4
129 int tty.t_rawq.c_clx 018 4
130 struct tty * tty.t_rawq.c_tp_cpu 01c 4
131 struct tty * tty.t_rawq.c_tp_iop 020 4
132 unsigned char * tty.t_rawq.c_buf_cpu 024 4
133 unsigned char * tty.t_rawq.c_buf_iop 028 4
134 struct clist tty.t_canq 02c 20
135 int tty.t_canq.c_cc 02c 4
136 int tty.t_canq.c_cmax 030 4
137 int tty.t_canq.c_cfx 034 4
138 int tty.t_canq.c_clx 038 4
139 struct tty * tty.t_canq.c_tp_cpu 03c 4
140 struct tty * tty.t_canq.c_tp_iop 040 4
141 unsigned char * tty.t_canq.c_buf_cpu 044 4
142 unsigned char * tty.t_canq.c_buf_iop 048 4
143 struct clist tty.t_outq 04c 20
144 int tty.t_outq.c_cc 04c 4
145 int tty.t_outq.c_cmax 050 4
146 int tty.t_outq.c_cfx 054 4
147 int tty.t_outq.c_clx 058 4
148 struct tty * tty.t_outq.c_tp_cpu 05c 4
149 struct tty * tty.t_outq.c_tp_iop 060 4
150 unsigned char * tty.t_outq.c_buf_cpu 064 4
151 unsigned char * tty.t_outq.c_buf_iop 068 4
152 (*int)() tty.t_oproc_cpu 06c 4
153 (*int)() tty.t_oproc_iop 070 4
154 (*int)() tty.t_stopproc_cpu 074 4
155 (*int)() tty.t_stopproc_iop 078 4
156 struct thread * tty.t_rsel 07c 4
161 Actually, this was generated by a particular set of options. You can control
162 the formatting of each column, whether you prefer wide or fat, hex or decimal,
163 leading zeroes or whatever.
165 All you need to be able to use this is a C compiler than generates
166 BSD/GCC-style stabs. The B<-g> option on native BSD compilers and GCC
167 should get this for you.
169 To learn more, just type a bogus option, like B<-\?>, and a long usage message
170 will be provided. There are a fair number of possibilities.
172 If you're only a C programmer, than this is the end of the message for you.
173 You can quit right now, and if you care to, save off the source and run it
174 when you feel like it. Or not.
178 But if you're a perl programmer, then for you I have something much more
179 wondrous than just a structure offset printer.
181 You see, if you call pstruct by its other incybernation, c2ph, you have a code
182 generator that translates C code into perl code! Well, structure and union
183 declarations at least, but that's quite a bit.
185 Prior to this point, anyone programming in perl who wanted to interact
186 with C programs, like the kernel, was forced to guess the layouts of
187 the C structures, and then hardwire these into his program. Of course,
188 when you took your wonderfully crafted program to a system where the
189 sgtty structure was laid out differently, your program broke. Which is
192 We've had Larry's h2ph translator, which helped, but that only works on
193 cpp symbols, not real C, which was also very much needed. What I offer
194 you is a symbolic way of getting at all the C structures. I've couched
195 them in terms of packages and functions. Consider the following program:
197 #!/usr/local/bin/perl
199 require 'syscall.ph';
200 require 'sys/time.ph';
201 require 'sys/resource.ph';
203 $ru = "\0" x &rusage'sizeof();
205 syscall(&SYS_getrusage, &RUSAGE_SELF, $ru) && die "getrusage: $!";
207 @ru = unpack($t = &rusage'typedef(), $ru);
209 $utime = $ru[ &rusage'ru_utime + &timeval'tv_sec ]
210 + ($ru[ &rusage'ru_utime + &timeval'tv_usec ]) / 1e6;
212 $stime = $ru[ &rusage'ru_stime + &timeval'tv_sec ]
213 + ($ru[ &rusage'ru_stime + &timeval'tv_usec ]) / 1e6;
215 printf "you have used %8.3fs+%8.3fu seconds.\n", $utime, $stime;
218 As you see, the name of the package is the name of the structure. Regular
219 fields are just their own names. Plus the following accessor functions are
220 provided for your convenience:
222 struct This takes no arguments, and is merely the number of first-level
223 elements in the structure. You would use this for indexing
224 into arrays of structures, perhaps like this
227 $usec = $u[ &user'u_utimer
228 + (&ITIMER_VIRTUAL * &itimerval'struct)
229 + &itimerval'it_value
233 sizeof Returns the bytes in the structure, or the member if
234 you pass it an argument, such as
236 &rusage'sizeof(&rusage'ru_utime)
238 typedef This is the perl format definition for passing to pack and
239 unpack. If you ask for the typedef of a nothing, you get
240 the whole structure, otherwise you get that of the member
241 you ask for. Padding is taken care of, as is the magic to
242 guarantee that a union is unpacked into all its aliases.
243 Bitfields are not quite yet supported however.
245 offsetof This function is the byte offset into the array of that
246 member. You may wish to use this for indexing directly
247 into the packed structure with vec() if you're too lazy
250 typeof Not to be confused with the typedef accessor function, this
251 one returns the C type of that field. This would allow
252 you to print out a nice structured pretty print of some
253 structure without knoning anything about it beforehand.
254 No args to this one is a noop. Someday I'll post such
255 a thing to dump out your u structure for you.
258 The way I see this being used is like basically this:
260 % h2ph <some_include_file.h > /usr/lib/perl/tmp.ph
261 % c2ph some_include_file.h >> /usr/lib/perl/tmp.ph
264 It's a little tricker with c2ph because you have to get the includes right.
265 I can't know this for your system, but it's not usually too terribly difficult.
267 The code isn't pretty as I mentioned -- I never thought it would be a 1000-
268 line program when I started, or I might not have begun. :-) But I would have
269 been less cavalier in how the parts of the program communicated with each
270 other, etc. It might also have helped if I didn't have to divine the makeup
271 of the stabs on the fly, and then account for micro differences between my
274 Anyway, here it is. Should run on perl v4 or greater. Maybe less.
281 $RCSID = '$Id: c2ph,v 1.7 95/10/28 10:41:47 tchrist Exp Locker: tchrist $';
284 ######################################################################
286 # some handy data definitions. many of these can be reset later.
288 $bitorder = 'b'; # ascending; set to B for descending bit fields
293 'unsigned char', 'C',
296 'unsigned short', 'S',
297 'unsigned short int', 'S',
298 'short unsigned int', 'S',
303 'unsigned long', 'L',
304 'unsigned long', 'L',
305 'long unsigned int', 'L',
306 'unsigned long int', 'L',
308 'long long int', 'q',
309 'unsigned long long', 'Q',
310 'unsigned long long int', 'Q',
320 delete $intrinsics{'neganull'};
321 delete $intrinsics{'bit'};
322 delete $intrinsics{'null'};
324 # use -s to recompute sizes
327 'unsigned char', '1',
330 'unsigned short', '2',
331 'unsigned short int', '2',
332 'short unsigned int', '2',
337 'unsigned long', '4',
338 'unsigned long int', '4',
339 'long unsigned int', '4',
341 'long long int', '8',
342 'unsigned long long', '8',
343 'unsigned long long int', '8',
349 ($type_width, $member_width, $offset_width, $size_width) = (20, 20, 6, 5);
351 ($offset_fmt, $size_fmt) = ('d', 'd');
358 if (($Config{gccversion} || '') =~ /^(\d+)\.(\d+)/
359 and ($1 > 3 or ($1 == 3 and $2 >= 2))) {
360 print OUT q/$CFLAGS = '-gstabs -S';/;
362 print OUT q/$CFLAGS = '-g -S';/;
365 print OUT <<'!NO!SUBS!';
369 $perl++ if $0 =~ m#/?c2ph$#;
371 require 'getopts.pl';
373 use File::Temp 'tempdir';
375 eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
377 &Getopts('aixdpvtnws:') || &usage(0);
382 $opt_v && $verbose++;
383 $opt_n && ($perl = 0);
386 ($type_width, $member_width, $offset_width) = (45, 35, 8);
389 ($offset_fmt, $offset_width, $size_fmt, $size_width) = ( 'x', '08', 'x', 04 );
392 eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
396 print "oops, apperent pager foulup\n";
408 print "hit <RETURN> for further explanation: ";
410 open (PIPE, "|". ($ENV{PAGER} || 'more'));
411 $SIG{PIPE} = PLUMBER;
415 print "usage: $0 [-dpnP] [var=val] [files ...]\n";
423 -w wide; short for: type_width=45 member_width=35 offset_width=8
424 -x hex; short for: offset_fmt=x offset_width=08 size_fmt=x size_width=04
426 -n do not generate perl code (default when invoked as pstruct)
427 -p generate perl code (default when invoked as c2ph)
428 -v generate perl code, with C decls as comments
430 -i do NOT recompute sizes for intrinsic datatypes
431 -a dump information on intrinsics also
434 -d spew reams of debugging output
436 -slist give comma-separated list a structures to dump
439 Var Name Default Value Meaning
443 &defvar('CC', 'which_compiler to call');
444 &defvar('CFLAGS', 'how to generate *.s files with stabs');
445 &defvar('DEFINES','any extra cflags or cpp defines, like -I, -D, -U');
449 &defvar('type_width', 'width of type field (column 1)');
450 &defvar('member_width', 'width of member field (column 2)');
451 &defvar('offset_width', 'width of offset field (column 3)');
452 &defvar('size_width', 'width of size field (column 4)');
456 &defvar('offset_fmt', 'sprintf format type for offset');
457 &defvar('size_fmt', 'sprintf format type for size');
461 &defvar('indent', 'how far to indent each nesting level');
465 If any *.[ch] files are given, these will be catted together into
466 a temporary *.c file and sent through:
468 and the resulting *.s groped for stab information. If no files are
469 supplied, then stdin is read directly with the assumption that it
470 contains stab information. All other liens will be ignored. At
471 most one *.s file should be supplied.
479 local($var, $msg) = @_;
480 printf "%-16s%-15s %s\n", $var, eval "\$$var", $msg;
486 if (grep(!/\.[csh]$/,@ARGV)) {
487 warn "Only *.[csh] files expected!\n";
490 elsif (grep(/\.s$/,@ARGV)) {
492 warn "Only one *.s file allowed!\n";
496 elsif (@ARGV == 1 && $ARGV[0] =~ /\.c$/) {
497 local($dir, $file) = $ARGV[0] =~ m#(.*/)?(.*)$#;
498 $chdir = "cd $dir; " if $dir;
499 &system("$chdir$CC $CFLAGS $DEFINES $file") && exit 1;
500 $ARGV[0] =~ s/\.c$/.s/;
503 $TMPDIR = tempdir(CLEANUP => 1);
504 $TMP = "$TMPDIR/c2ph.$$.c";
505 &system("cat @ARGV > $TMP") && exit 1;
506 &system("cd $TMPDIR; $CC $CFLAGS $DEFINES $TMP") && exit 1;
514 for (split(/[\s,]+/, $opt_s)) {
526 print STDERR "reading from your keyboard: ";
528 print STDERR "reading from " . (@ARGV ? "@ARGV" : "<STDIN>").": ";
533 if ($trace && !($. % 10)) {
535 print STDERR $lineno, "\b" x length($lineno);
537 next unless /^\s*\.stabs\s+/;
540 if (s/\\\\"[d,]+$//) {
551 $savebar = $saveline = undef;
553 print STDERR "$.\n" if $trace;
556 &compute_intrinsics if $perl && !$opt_i;
558 print STDERR "resolving types\n" if $trace;
563 $sum = 2 + $type_width + $member_width;
564 $pmask1 = "%-${type_width}s %-${member_width}s";
565 $pmask2 = "%-${sum}s %${offset_width}${offset_fmt}%s %${size_width}${size_fmt}%s";
570 # resolve template -- should be in stab define order, but even this isn't enough.
571 print STDERR "\nbuilding type templates: " if $trace;
572 for $i (reverse 0..$#type) {
573 next unless defined($name = $type[$i]);
574 next unless defined $struct{$name};
575 ($iname = $name) =~ s/\..*//;
577 &build_template($name) unless defined $template{&psou($name)} ||
578 $opt_s && !$interested{$iname};
580 print STDERR "\n\n" if $trace;
583 print STDERR "dumping structs: " if $trace;
589 foreach $name (sort keys %struct) {
590 ($iname = $name) =~ s/\..*//;
591 next if $opt_s && !$interested{$iname};
592 print STDERR "$name " if $trace;
601 $mname = &munge($name);
603 $fname = &psou($name);
605 print "# " if $perl && $verbose;
607 print "$fname {\n" if !$perl || $verbose;
608 $template{$fname} = &scrunch($template{$fname}) if $perl;
609 &pstruct($name,$name,0);
610 print "# " if $perl && $verbose;
611 print "}\n" if !$perl || $verbose;
612 print "\n" if $perl && $verbose;
617 printf("\nsub %-32s { %4d; }\n\n", "${mname}'struct", $countof{$name});
620 sub ${mname}'typedef {
621 local(\$${mname}'index) = shift;
622 defined \$${mname}'index
623 ? \$${mname}'typedef[\$${mname}'index]
624 : \$${mname}'typedef;
629 sub ${mname}'sizeof {
630 local(\$${mname}'index) = shift;
631 defined \$${mname}'index
632 ? \$${mname}'sizeof[\$${mname}'index]
638 sub ${mname}'offsetof {
639 local(\$${mname}'index) = shift;
640 defined \$${mname}index
641 ? \$${mname}'offsetof[\$${mname}'index]
647 sub ${mname}'typeof {
648 local(\$${mname}'index) = shift;
649 defined \$${mname}index
650 ? \$${mname}'typeof[\$${mname}'index]
656 sub ${mname}'fieldnames {
657 \@${mname}'fieldnames;
661 $iam = ($isastruct{$name} && 's') || ($isaunion{$name} && 'u');
664 sub ${mname}'isastruct {
669 print "\$${mname}'typedef = '" . &scrunch($template{$fname})
672 print "\$${mname}'sizeof = $sizeof{$name};\n\n";
675 print "\@${mname}'indices = (", &squishseq(@indices), ");\n";
679 print "\@${mname}'typedef[\@${mname}'indices] = (",
680 join("\n\t", '', @typedef), "\n );\n\n";
681 print "\@${mname}'sizeof[\@${mname}'indices] = (",
682 join("\n\t", '', @sizeof), "\n );\n\n";
683 print "\@${mname}'offsetof[\@${mname}'indices] = (",
684 join("\n\t", '', @offsetof), "\n );\n\n";
685 print "\@${mname}'typeof[\@${mname}'indices] = (",
686 join("\n\t", '', @typeof), "\n );\n\n";
687 print "\@${mname}'fieldnames[\@${mname}'indices] = (",
688 join("\n\t", '', @fieldnames), "\n );\n\n";
690 $template_printed{$fname}++;
691 $size_printed{$fname}++;
696 print STDERR "\n" if $trace;
698 unless ($perl && $opt_a) {
699 print "\n1;\n" if $perl;
705 foreach $name (sort bysizevalue keys %intrinsics) {
706 next if $size_printed{$name};
707 print '$',&munge($name),"'sizeof = ", $sizeof{$name}, ";\n";
712 sub bysizevalue { $sizeof{$a} <=> $sizeof{$b}; }
715 foreach $name (sort keys %intrinsics) {
716 print '$',&munge($name),"'typedef = '", $template{$name}, "';\n";
719 print "\n1;\n" if $perl;
724 ########################################################################################
728 next unless $continued || /:[\$\w]+(\(\d+,\d+\))?=[\*\$\w]+/; # (\d+,\d+) is for sun
730 s/",([x\d]+),([x\d]+),([x\d]+),.*// || next;
735 $_ = $continued . $_ if length($continued);
737 # if last 2 chars of string are '\\' then stab is continued
748 if (($name, $pdecl) = /^([\$ \w]+):[tT]((\d+)(=[rufs*](\d+))+)$/) {
749 print "$name is a typedef for some funky pointers: $pdecl\n" if $debug;
756 if (/(([ \w]+):t(\d+|\(\d+,\d+\)))=r?(\d+|\(\d+,\d+\))(;\d+;\d+;)?/) {
758 push(@intrinsics, $ident);
759 $typeno = &typeno($3);
760 $type[$typeno] = $ident;
761 print STDERR "intrinsic $ident in new type $typeno\n" if $debug;
765 if (($name, $typeordef, $typeno, $extra, $struct, $_)
766 = /^([\$ \w]+):([ustT])(\d+|\(\d+,\d+\))(=[rufs*](\d+))?(.*)$/)
768 $typeno = &typeno($typeno); # sun foolery
770 elsif (/^[\$\w]+:/) {
774 warn "can't grok stab: <$_> in: $line " if $_;
778 #warn "got size $size for $name\n";
779 $sizeof{$name} = $size if $size;
781 s/;[-\d]*;[-\d]*;$//; # we don't care about ranges
783 $typenos{$name} = $typeno;
785 unless (defined $type[$typeno]) {
786 &panic("type 0??") unless $typeno;
787 $type[$typeno] = $name unless defined $type[$typeno];
788 printf "new type $typeno is $name" if $debug;
789 if ($extra =~ /\*/ && defined $type[$struct]) {
790 print ", a typedef for a pointer to " , $type[$struct] if $debug;
793 printf "%s is type %d", $name, $typeno if $debug;
794 print ", a typedef for " , $type[$typeno] if $debug;
796 print "\n" if $debug;
797 #next unless $extra =~ /[su*]/;
799 #$type[$struct] = $name;
801 if ($extra =~ /[us*]/) {
803 $_ = &sdecl($name, $_, 0);
806 print "it's a bare array typedef -- that's pretty sick\n" if $debug;
812 elsif (s/((\w+):t(\d+|\(\d+,\d+\)))?=r?(;\d+;\d+;)?//) { # the ?'s are for gcc
813 push(@intrinsics, $2);
814 $typeno = &typeno($3);
816 print STDERR "intrinsic $2 in new type $typeno\n" if $debug;
818 elsif (s/^=e//) { # blessed be thy compiler; mine won't do this
822 warn "Funny remainder for $name on line $_ left in $line " if $_;
826 sub typeno { # sun thinks types are (0,27) instead of just 27
833 local($what,$prefix,$base) = @_;
834 local($field, $fieldname, $typeno, $count, $offset, $entry);
836 local($type, $tname);
837 local($mytype, $mycount, $entry2);
838 local($struct_count) = 0;
839 local($pad, $revpad, $length, $prepad, $lastoffset, $lastlength, $fmt);
844 local($mname) = &munge($name);
852 local($sname) = &psou($what);
856 for $field (split(/;/, $struct{$what})) {
859 ($fieldname, $typeno, $count, $offset, $length) = split(/,/, $field);
861 $type = $type[$typeno];
863 $type =~ /([^[]*)(\[.*\])?/;
866 $fieldtype = &psou($mytype);
868 local($fname) = &psou($name);
870 if ($build_templates) {
872 $pad = ($offset - ($lastoffset + $lastlength))/8
873 if defined $lastoffset;
875 if (! $finished_template{$sname}) {
876 if ($isaunion{$what}) {
877 $template{$sname} .= 'X' x $revpad . ' ' if $revpad;
879 $template{$sname} .= 'x' x $pad . ' ' if $pad;
883 $template = &fetch_template($type);
884 &repeat_template($template,$count);
886 if (! $finished_template{$sname}) {
887 $template{$sname} .= $template;
890 $revpad = $length/8 if $isaunion{$what};
892 ($lastoffset, $lastlength) = ($offset, $length);
895 print '# ' if $perl && $verbose;
896 $entry = sprintf($pmask1,
897 ' ' x ($nesting * $indent) . $fieldtype,
898 "$prefix.$fieldname" . $count);
900 $entry =~ s/(\*+)( )/$2$1/;
905 ($bits = ($base+$offset)%8) ? ".$bits" : " ",
907 ($bits = $length % 8) ? ".$bits": ""
908 if !$perl || $verbose;
911 $template = &fetch_template($type);
912 &repeat_template($template,$count);
915 if ($perl && $nesting == 1) {
917 push(@sizeof, int($length/8) .",\t# $fieldname");
918 push(@offsetof, int($offset/8) .",\t# $fieldname");
919 local($little) = &scrunch($template);
920 push(@typedef, "'$little', \t# $fieldname");
921 $type =~ s/(struct|union) //;
922 push(@typeof, "'$mytype" . ($count ? $count : '') .
924 push(@fieldnames, "'$fieldname',");
927 print ' ', ' ' x $indent x $nesting, $template
928 if $perl && $verbose;
930 print "\n" if !$perl || $verbose;
934 local($mycount) = defined $struct{$mytype} ? $countof{$mytype} : 1;
935 $mycount *= &scripts2count($count) if $count;
936 if ($nesting==1 && !$build_templates) {
937 $pcode .= sprintf("sub %-32s { %4d; }\n",
938 "${mname}'${fieldname}", $struct_count);
939 push(@indices, $struct_count);
941 $struct_count += $mycount;
945 &pstruct($type, "$prefix.$fieldname", $base+$offset)
946 if $recurse && defined $struct{$type};
949 $countof{$what} = $struct_count unless defined $countof{$whati};
951 $template{$sname} .= '$' if $build_templates;
952 $finished_template{$sname}++;
954 if ($build_templates && !defined $sizeof{$name}) {
955 local($fmt) = &scrunch($template{$sname});
956 print STDERR "no size for $name, punting with $fmt..." if $debug;
957 eval '$sizeof{$name} = length(pack($fmt, ()))';
960 warn "couldn't get size for \$name: $@";
962 print STDERR $sizeof{$name}, "\n" if $debUg;
972 local($amstruct) = $struct{$me} ? 'struct ' : '';
974 print '$sizeof{\'', $amstruct, $me, '\'} = ';
975 printf "%d;\n", $sizeof{$me};
983 warn "pdecl: $pdecl\n" if $debug;
985 $pdecl =~ s/\(\d+,(\d+)\)/$1/g;
987 @pdecls = split(/=/, $pdecl);
988 $typeno = $pdecls[0];
989 $tname = pop @pdecls;
991 if ($tname =~ s/^f//) { $tname = "$tname&"; }
992 #else { $tname = "$tname*"; }
994 for (reverse @pdecls) {
995 $tname .= s/^f// ? "&" : "*";
996 #$tname =~ s/^f(.*)/$1&/;
997 print "type[$_] is $tname\n" if $debug;
998 $type[$_] = $tname unless defined $type[$_];
1005 ($arraytype, $unknown, $lower, $upper) = ();
1007 # global $typeno, @type
1008 local($_, $typedef) = @_;
1010 while (s/^((\d+|\(\d+,\d+\))=)?ar(\d+|\(\d+,\d+\));//) {
1011 ($arraytype, $unknown) = ($2, $3);
1012 $arraytype = &typeno($arraytype);
1013 $unknown = &typeno($unknown);
1014 if (s/^(\d+);(\d+);//) {
1015 ($lower, $upper) = ($1, $2);
1016 $scripts .= '[' . ($upper+1) . ']';
1018 warn "can't find array bounds: $_";
1021 if (s/^([(,)\d*f=]*),(\d+),(\d+);//) {
1022 ($start, $length) = ($2, $3);
1024 if ($whatis =~ /^(\d+|\(\d+,\d+\))=/) {
1025 $typeno = &typeno($1);
1028 $typeno = &typeno($whatis);
1030 } elsif (s/^(\d+)(=[*suf]\d*)//) {
1031 local($whatis) = $2;
1033 if ($whatis =~ /[f*]/) {
1035 } elsif ($whatis =~ /[su]/) { #
1036 print "$prefix.$fieldname is an array$scripts anon structs; disgusting\n"
1038 #$type[$typeno] = $name unless defined $type[$typeno];
1039 ##printf "new type $typeno is $name" if $debug;
1041 $type[$typeno] = "$prefix.$fieldname";
1042 local($name) = $type[$typeno];
1043 &sou($name, $whatis);
1044 $_ = &sdecl($name, $_, $start+$offset);
1046 $start = $start{$name};
1047 $offset = $sizeof{$name};
1050 warn "what's this? $whatis in $line ";
1055 warn "bad array stab: $_ in $line ";
1058 #local($wasdef) = defined($type[$typeno]) && $debug;
1060 #print "redefining $type[$typeno] to " if $wasdef;
1061 #$type[$typeno] = "$whatis$scripts"; # unless defined $type[$typeno];
1062 #print "$type[$typeno]\n" if $wasdef;
1064 #$type[$arraytype] = $type[$typeno] unless defined $type[$arraytype];
1066 $type[$arraytype] = "$type[$typeno]$scripts" if defined $type[$typeno];
1067 print "type[$arraytype] is $type[$arraytype]\n" if $debug;
1068 print "$prefix.$fieldname is an array of $type[$arraytype]\n" if $debug;
1075 local($prefix, $_, $offset) = @_;
1077 local($fieldname, $scripts, $type, $arraytype, $unknown,
1078 $whatis, $pdecl, $upper,$lower, $start,$length) = ();
1079 local($typeno,$sou);
1083 while (/^([^;]+);/) {
1085 warn "sdecl $_\n" if $debug;
1086 if (s/^([\$\w]+)://) {
1088 } elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { #
1089 $typeno = &typeno($1);
1090 $type[$typeno] = "$prefix.$fieldname";
1091 local($name) = "$prefix.$fieldname";
1093 $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
1094 $start = $start{$name};
1095 $offset += $sizeof{$name};
1096 #print "done with anon, start is $start, offset is $offset\n";
1099 warn "weird field $_ of $line" if $debug;
1101 #$fieldname = &gensym;
1102 #$_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
1105 if (/^(\d+|\(\d+,\d+\))=ar/) {
1108 elsif (s/^(\d+|\(\d+,\d+\))?,(\d+),(\d+);//) {
1109 ($start, $length) = ($2, $3);
1110 &panic("no length?") unless $length;
1111 $typeno = &typeno($1) if $1;
1113 elsif (s/^(\d+)=xs\w+:,(\d+),(\d+);//) {
1114 ($start, $length) = ($2, $3);
1115 &panic("no length?") unless $length;
1116 $typeno = &typeno($1) if $1;
1118 elsif (s/^((\d+|\(\d+,\d+\))(=[*f](\d+|\(\d+,\d+\)))+),(\d+),(\d+);//) {
1119 ($pdecl, $start, $length) = ($1,$5,$6);
1122 elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # the dratted anon struct
1123 ($typeno, $sou) = ($1, $2);
1124 $typeno = &typeno($typeno);
1125 if (defined($type[$typeno])) {
1126 warn "now how did we get type $1 in $fieldname of $line?";
1128 print "anon type $typeno is $prefix.$fieldname\n" if $debug;
1129 $type[$typeno] = "$prefix.$fieldname" unless defined $type[$typeno];
1131 local($name) = "$prefix.$fieldname";
1133 print "anon ".($isastruct{$name}) ? "struct":"union"." for $prefix.$fieldname\n" if $debug;
1134 $type[$typeno] = "$prefix.$fieldname";
1135 $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
1136 $start = $start{$name};
1137 $length = $sizeof{$name};
1140 warn "can't grok stab for $name ($_) in line $line ";
1144 &panic("no length for $prefix.$fieldname") unless $length;
1145 $struct{$name} .= join(',', $fieldname, $typeno, $scripts, $start, $length) . ';';
1147 if (s/;\d*,(\d+),(\d+);//) {
1148 local($start, $size) = ($1, $2);
1149 $sizeof{$prefix} = $size;
1150 print "start of $prefix is $start, size of $sizeof{$prefix}\n" if $debug;
1151 $start{$prefix} = $start;
1164 for $i (0 .. $#type) {
1165 next unless defined $type[$i];
1168 print "type[$i] $type[$i]\n" if $debug;
1171 print "type[$i] $_ ==> " if $debug;
1172 s/^(\d+)(\**)\&\*(\**)/"$2($3".&type($1) . ')()'/e;
1173 s/^(\d+)\&/&type($1)/e;
1174 s/^(\d+)/&type($1)/e;
1175 s/(\*+)([^*]+)(\*+)/$1$3$2/;
1176 s/\((\*+)(\w+)(\*+)\)/$3($1$2)/;
1177 s/^(\d+)([\*\[].*)/&type($1).$2/e;
1178 #s/(\d+)(\*|(\[[\[\]\d\*]+]\])+)/&type($1).$2/ge;
1180 print "$_\n" if $debug;
1183 sub type { &psou($type[$_[0]] || "<UNDEFINED>"); }
1185 sub adjust_start_addrs {
1186 for (sort keys %start) {
1187 ($basename = $_) =~ s/\.[^.]+$//;
1188 $start{$_} += $start{$basename};
1189 print "start: $_ @ $start{$_}\n" if $debug;
1194 local($what, $_) = @_;
1195 /u/ && $isaunion{$what}++;
1196 /s/ && $isastruct{$what}++;
1201 local($prefix) = '';
1202 if ($isaunion{$what}) {
1204 } elsif ($isastruct{$what}) {
1205 $prefix = 'struct ';
1213 return '' if $_ eq '';
1219 1 while s/(\w) \1/$1$1/g;
1221 # i wanna say this, but perl resists my efforts:
1222 # s/(\w)(\1+)/$2 . length($1)/ge;
1231 sub buildscrunchlist {
1232 $scrunch_code = "sub quick_scrunch {\n";
1233 for (values %intrinsics) {
1234 $scrunch_code .= "\ts/(${_}{2,})/'$_' . length(\$1)/ge;\n";
1236 $scrunch_code .= "}\n";
1237 print "$scrunch_code" if $debug;
1239 &panic("can't eval scrunch_code $@ \nscrunch_code") if $@;
1242 sub fetch_template {
1243 local($mytype) = @_;
1247 &panic("why do you care?") unless $perl;
1249 if ($mytype =~ s/(\[\d+\])+$//) {
1253 if ($mytype =~ /\*/) {
1254 $fmt = $template{'pointer'};
1256 elsif (defined $template{$mytype}) {
1257 $fmt = $template{$mytype};
1259 elsif (defined $struct{$mytype}) {
1260 if (!defined $template{&psou($mytype)}) {
1261 &build_template($mytype) unless $mytype eq $name;
1263 elsif ($template{&psou($mytype)} !~ /\$$/) {
1264 #warn "incomplete template for $mytype\n";
1266 $fmt = $template{&psou($mytype)} || '?';
1269 warn "unknown fmt for $mytype\n";
1273 $fmt x $count . ' ';
1276 sub compute_intrinsics {
1277 $TMPDIR ||= tempdir(CLEANUP => 1);
1278 local($TMP) = "$TMPDIR/c2ph-i.$$.c";
1279 open (TMP, ">$TMP") || die "can't open $TMP: $!";
1282 print STDERR "computing intrinsic sizes: " if $trace;
1288 char *mask = "%d %s\n";
1291 for $type (@intrinsics) {
1292 next if !$type || $type eq 'void' || $type =~ /complex/; # sun stuff
1294 printf(mask,sizeof($type), "$type");
1299 printf(mask,sizeof(char *), "pointer");
1306 open(PIPE, "cd $TMPDIR && $CC $TMP && $TMPDIR/a.out|");
1310 print "intrinsic $_[1] is size $_[0]\n" if $debug;
1311 $sizeof{$_[1]} = $_[0];
1312 $intrinsics{$_[1]} = $template{$_[0]};
1314 close(PIPE) || die "couldn't read intrinsics!";
1315 unlink($TMP, '$TMPDIR/a.out');
1316 print STDERR "done\n" if $trace;
1326 &panic("$_: $@") if $@;
1331 print STDERR "@_\n" if $trace;
1335 sub build_template {
1338 &panic("already got a template for $name") if defined $template{$name};
1340 local($build_templates) = 1;
1342 local($lparen) = '(' x $build_recursed;
1343 local($rparen) = ')' x $build_recursed;
1345 print STDERR "$lparen$name$rparen " if $trace;
1347 &pstruct($name,$name,0);
1348 print STDERR "TEMPLATE for $name is ", $template{&psou($name)}, "\n" if $debug;
1357 print "\npanic: @_\n";
1359 exit 1 if $] <= 4.003; # caller broken
1362 local($p,$f,$l,$s,$h,$a,@a,@sub);
1363 for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
1366 if (/^StB\000/ && length($_) == length($_main{'_main'})) {
1367 $_ = sprintf("%s",$_);
1371 s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
1372 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1373 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1376 $w = $w ? '@ = ' : '$ = ';
1377 $a = $h ? '(' . join(', ', @a) . ')' : '';
1378 push(@sub, "$w&$s$a from file $f line $l\n");
1381 for ($i=0; $i <= $#sub; $i++) {
1390 local($last) = -1e8;
1394 while (defined($num = shift)) {
1395 if ($num == ($last + 1)) {
1396 $string .= $seq unless $inseq++;
1400 $string .= $last unless $last == -1e8;
1403 $string .= ',' if defined $string;
1408 $string .= $last if $inseq && $last != -e18;
1412 sub repeat_template {
1413 # local($template, $scripts) = @_; have to change caller's values
1416 local($ncount) = &scripts2count($_[1]);
1417 if ($_[0] =~ /^\s*c\s*$/i) {
1418 $_[0] = "A$ncount ";
1421 $_[0] = $template x $ncount;
1427 close OUT or die "Can't close $file: $!";
1428 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
1430 print "Linking c2ph to pstruct.\n";
1431 if (defined $Config{d_link}) {
1432 link 'c2ph', 'pstruct';
1434 unshift @INC, '../lib';
1436 File::Copy::syscopy('c2ph', 'pstruct');
1438 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';