| 1 | #!perl -w |
| 2 | use strict; |
| 3 | |
| 4 | use Pod::Usage; |
| 5 | use Getopt::Std; |
| 6 | use Config; |
| 7 | $Getopt::Std::STANDARD_HELP_VERSION = 1; |
| 8 | |
| 9 | my $trysource = "try.c"; |
| 10 | my $tryout = "try.i"; |
| 11 | |
| 12 | getopts('fF:ekvI:X', \my %opt) or pod2usage(); |
| 13 | |
| 14 | my($expr, @headers) = @ARGV ? splice @ARGV : "-"; |
| 15 | |
| 16 | pod2usage "-f and -F <tool> are exclusive\n" if $opt{f} and $opt{F}; |
| 17 | |
| 18 | foreach($trysource, $tryout) { |
| 19 | unlink $_ if $opt{e}; |
| 20 | die "You already have a $_" if -e $_; |
| 21 | } |
| 22 | |
| 23 | if ($expr eq '-') { |
| 24 | warn "reading from stdin...\n"; |
| 25 | $expr = do { local $/; <> }; |
| 26 | } |
| 27 | |
| 28 | my($macro, $args) = $expr =~ /^\s*(\w+)((?:\s*\(.*\))?)\s*;?\s*$/s |
| 29 | or pod2usage "$expr doesn't look like a macro-name or macro-expression to me"; |
| 30 | |
| 31 | if (!(@ARGV = @headers)) { |
| 32 | open my $fh, '<', 'MANIFEST' or die "Can't open MANIFEST: $!"; |
| 33 | while (<$fh>) { |
| 34 | push @ARGV, $1 if m!^([^/]+\.h)\t!; |
| 35 | } |
| 36 | push @ARGV, 'config.h' if -f 'config.h'; |
| 37 | } |
| 38 | |
| 39 | my $header; |
| 40 | while (<>) { |
| 41 | next unless /^#\s*define\s+$macro\b/; |
| 42 | my ($def_args) = /^#\s*define\s+$macro\(([^)]*)\)/; |
| 43 | if (defined $def_args && !$args) { |
| 44 | my @args = split ',', $def_args; |
| 45 | print "# macro: $macro args: @args in $_\n" if $opt{v}; |
| 46 | my $argname = "A0"; |
| 47 | $args = '(' . join (', ', map {$argname++} 1..@args) . ')'; |
| 48 | } |
| 49 | $header = $ARGV; |
| 50 | last; |
| 51 | } |
| 52 | die "$macro not found\n" unless defined $header; |
| 53 | |
| 54 | if ($^O =~ /MSWin(32|64)/) { |
| 55 | # The Win32 (and Win64) build process expects to be run from |
| 56 | # bleadperl/Win32 |
| 57 | chdir "Win32" |
| 58 | or die "Couldn't chdir to win32: $!"; |
| 59 | }; |
| 60 | |
| 61 | open my $out, '>', $trysource or die "Can't open $trysource: $!"; |
| 62 | |
| 63 | my $sentinel = "$macro expands to"; |
| 64 | |
| 65 | # These two are included from perl.h, and perl.h sometimes redefines their |
| 66 | # macros. So no need to include them. |
| 67 | my %done_header = ('embed.h' => 1, 'embedvar.h' => 1); |
| 68 | |
| 69 | sub do_header { |
| 70 | my $header = shift; |
| 71 | return if $done_header{$header}++; |
| 72 | print $out qq{#include "$header"\n}; |
| 73 | } |
| 74 | |
| 75 | print $out <<'EOF' if $opt{X}; |
| 76 | /* Need to do this like this, as cflags.sh sets it for us come what may. */ |
| 77 | #undef PERL_CORE |
| 78 | |
| 79 | EOF |
| 80 | |
| 81 | do_header('EXTERN.h'); |
| 82 | do_header('perl.h'); |
| 83 | do_header($header); |
| 84 | do_header('XSUB.h') if $opt{X}; |
| 85 | |
| 86 | print $out <<"EOF"; |
| 87 | #line 4 "$sentinel" |
| 88 | $macro$args |
| 89 | EOF |
| 90 | |
| 91 | close $out or die "Can't close $trysource: $!"; |
| 92 | |
| 93 | print "doing: $Config{make} $tryout\n" if $opt{v}; |
| 94 | my $cmd = "$Config{make} $tryout"; |
| 95 | system( $cmd ) == 0 |
| 96 | or die "Couldn't launch [$cmd]: $! / $?"; |
| 97 | |
| 98 | # if user wants 'indent' formatting .. |
| 99 | my $out_fh; |
| 100 | |
| 101 | if ($opt{f} || $opt{F}) { |
| 102 | # a: indent is a well behaved filter when given 0 arguments, reading from |
| 103 | # stdin and writing to stdout |
| 104 | # b: all our braces should be balanced, indented back to column 0, in the |
| 105 | # headers, hence everything before our #line directive can be ignored |
| 106 | # |
| 107 | # We can take advantage of this to reduce the work to indent. |
| 108 | |
| 109 | my $indent_command = $opt{f} ? 'indent' : $opt{F}; |
| 110 | |
| 111 | if (defined $opt{I}) { |
| 112 | $indent_command .= " $opt{I}"; |
| 113 | } |
| 114 | open $out_fh, '|-', $indent_command or die $?; |
| 115 | } else { |
| 116 | $out_fh = \*STDOUT; |
| 117 | } |
| 118 | |
| 119 | { |
| 120 | open my $fh, '<', $tryout or die "Can't open $tryout: $!"; |
| 121 | |
| 122 | while (<$fh>) { |
| 123 | print $out_fh $_ if /$sentinel/o .. 1; |
| 124 | } |
| 125 | }; |
| 126 | |
| 127 | unless ($opt{k}) { |
| 128 | foreach($trysource, $tryout) { |
| 129 | die "Can't unlink $_: $!" unless unlink $_; |
| 130 | } |
| 131 | } |
| 132 | |
| 133 | __END__ |
| 134 | |
| 135 | =head1 NAME |
| 136 | |
| 137 | expand-macro.pl - expand C macros using the C preprocessor |
| 138 | |
| 139 | =head1 SYNOPSIS |
| 140 | |
| 141 | expand-macro.pl [options] [ < macro-name | macro-expression | - > [headers] ] |
| 142 | |
| 143 | options: |
| 144 | -f use 'indent' to format output |
| 145 | -F <tool> use <tool> to format output (instead of -f) |
| 146 | -e erase try.[ic] instead of failing when they're present (errdetect) |
| 147 | -k keep them after generating (for handy inspection) |
| 148 | -v verbose |
| 149 | -I <indent-opts> passed into indent |
| 150 | -X include "XSUB.h" (and undefine PERL_CORE) |
| 151 | |
| 152 | =cut |