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