1
package ModPerl::CScan;
6
use Data::Flow qw(0.05);
7
use strict; # Earlier it catches ISA and EXPORT.
9
@ModPerl::CScan::ISA = qw(Exporter Data::Flow);
11
# Items to export into callers namespace by default. Note: do not export
12
# names by default without a very good reason. Use EXPORT_OK instead.
13
# Do not simply export all your public functions/methods/constants.
15
@ModPerl::CScan::EXPORT = qw(
17
@ModPerl::CScan::EXPORT_OK = qw(
19
# this flag tells cpp to only output macros
20
$ModPerl::CScan::MACROS_ONLY = '-dM';
22
$ModPerl::CScan::VERSION = '0.75';
24
my (%keywords,%style_keywords);
25
for (qw(asm auto break case char continue default do double else enum
26
extern float for fortran goto if int long register return short
27
sizeof static struct switch typedef union unsigned signed while void volatile)) {
30
for (qw(bool class const delete friend inline new operator overload private
31
protected public virtual)) {
32
$style_keywords{'C++'}{$_}++;
34
for (qw(__func__ _Complex _Imaginary _Bool inline restrict)) {
35
$style_keywords{'C9X'}{$_}++;
37
for (qw(inline const asm noreturn section
38
constructor destructor unused weak)) {
39
$style_keywords{'GNU'}{$_}++;
40
$style_keywords{'GNU'}{"__$ {_}__"}++;
42
$style_keywords{'GNU'}{__attribute__}++;
43
$style_keywords{'GNU'}{__extension__}++;
44
$style_keywords{'GNU'}{__consts}++;
45
$style_keywords{'GNU'}{__const}++;
46
$style_keywords{'GNU'}{__restrict}++;
49
= { Defines => { default => '' },
50
cppstdin => { default => $Config{cppstdin} },
51
cppflags => { default => $Config{cppflags} },
52
cppminus => { default => $Config{cppminus} },
53
c_styles => { default => [qw(C++ GNU C9X)] },
54
add_cppflags => { default => '' },
55
keywords => { prerequisites => ['c_styles'],
59
for ( @{ shift->{c_styles} } ) {
60
%add = %{ $style_keywords{$_} };
65
'undef' => { default => undef },
66
filename_filter => { default => undef },
67
full_text => { class_filter => [ 'text', 'C::Preprocessed',
68
qw(undef filename Defines includeDirs Cpp)] },
69
text => { class_filter => [ 'text', 'C::Preprocessed',
70
qw(filename_filter filename Defines includeDirs Cpp)] },
71
text_only_from => { class_filter => [ 'text_only_from', 'C::Preprocessed',
72
qw(filename_filter filename Defines includeDirs Cpp)] },
73
includes => { filter => [ \&includes,
74
qw(filename Defines includeDirs Cpp) ], },
75
includeDirs => { prerequisites => ['filedir'],
78
[ $data->{filedir}, '/usr/local/include', '.'];
80
Cpp => { prerequisites => [qw(cppminus add_cppflags cppflags cppstdin)],
83
return { cppstdin => $data->{cppstdin},
84
cppflags => "$data->{cppflags} $data->{add_cppflags}",
85
cppminus => $data->{cppminus} };
87
filedir => { output => sub { dirname ( shift->{filename} || '.' ) } },
88
sanitized => { filter => [ \&sanitize, 'text'], },
89
toplevel => { filter => [ \&top_level, 'sanitized'], },
90
full_sanitized => { filter => [ \&sanitize, 'full_text'], },
91
full_toplevel => { filter => [ \&top_level, 'full_sanitized'], },
92
no_type_decl => { filter => [ \&remove_type_decl, 'toplevel'], },
93
typedef_chunks => { filter => [ \&typedef_chunks, 'full_toplevel'], },
94
struct_chunks => { filter => [ \&struct_chunks, 'full_toplevel'], },
95
typedefs_whited => { filter => [ \&typedefs_whited,
96
'full_sanitized', 'typedef_chunks',
98
typedef_texts => { filter => [ \&typedef_texts,
99
'full_text', 'typedef_chunks'], },
100
struct_texts => { filter => [ \&typedef_texts,
101
'full_text', 'struct_chunks'], },
102
typedef_hash => { filter => [ \&typedef_hash,
103
'typedef_texts', 'typedefs_whited'], },
104
typedef_structs => { filter => [ \&typedef_structs,
105
'typedef_hash', 'struct_texts'], },
106
typedefs_maybe => { filter => [ sub {[keys %{+shift}]},
108
defines_maybe => { filter => [ \&defines_maybe, 'filename'], },
109
defines_no_args => { prerequisites => ['defines_maybe'],
110
output => sub { shift->{defines_maybe}->[0] }, },
111
defines_args => { prerequisites => ['defines_maybe'],
112
output => sub { shift->{defines_maybe}->[1] }, },
114
defines_full => { filter => [ \&defines_full,
115
qw(filename Defines includeDirs Cpp) ], },
116
defines_no_args_full => { prerequisites => ['defines_full'],
117
output => sub { shift->{defines_full}->[0] }, },
118
defines_args_full => { prerequisites => ['defines_full'],
119
output => sub { shift->{defines_full}->[1] }, },
121
decl_inlines => { filter => [ \&functions_in, 'no_type_decl'], },
122
inline_chunks => { filter => [ sub { shift->[0] }, 'decl_inlines'], },
123
inlines => { filter => [ \&from_chunks, 'inline_chunks', 'text'], },
124
decl_chunks => { filter => [ sub { shift->[1] }, 'decl_inlines'], },
125
decls => { filter => [ \&from_chunks, 'decl_chunks', 'text'], },
126
fdecl_chunks => { filter => [ sub { shift->[4] }, 'decl_inlines'], },
127
fdecls => { filter => [ \&from_chunks, 'fdecl_chunks', 'text'], },
128
mdecl_chunks => { filter => [ sub { shift->[2] }, 'decl_inlines'], },
129
mdecls => { filter => [ \&from_chunks, 'mdecl_chunks', 'text'], },
130
vdecl_chunks => { filter => [ sub { shift->[3] }, 'decl_inlines'], },
131
vdecls => { filter => [ \&from_chunks, 'vdecl_chunks', 'text'], },
132
vdecl_hash => { filter => [ \&vdecl_hash, 'vdecls', 'mdecls' ], },
133
parsed_fdecls => { filter => [ \&do_declarations, 'fdecls',
134
'typedef_hash', 'keywords'], },
135
keywords_rex => { filter => [ sub { my @k = keys %{ shift() };
138
eval 'qr/$r/' or $r # Older Perls
147
while ($i < @$chunks) {
148
push @out, substr $txt, $chunks->[$i], $chunks->[ $i + 1 ] - $chunks->[$i];
154
#sub process { request($recipes, @_) }
155
# Preloaded methods go here.
159
my $stream = new C::Preprocessed (@_)
160
or die "Cannot open pipe from cppstdin: $!\n";
163
next unless m(^\s*\#\s* # Leading hash
164
(line\s*)? # 1: Optional line
165
([0-9]+)\s* # 2: Line number
169
$include = $1 if $include =~ /"(.*)"/; # Filename may be in quotes
170
$include =~ s,\\\\,/,g if $^O eq 'os2';
171
$seen{$include}++ if $include ne "";
178
my ($mline,$line,%macros,%macrosargs,$sym,$args);
179
open(C, $file) or die "Cannot open file $file: $!\n";
180
while (not eof(C) and $line = <C>) {
183
^ \s* \# \s* # Start of directive
187
\( (.*?) \s* \) # 2: Minimal match for arguments
188
# in parenths (without trailing
190
)? # optional, no grouping
191
\s* # rest is the definition
192
([\s\S]*) # 3: the rest
194
($sym, $args, $mline) = ($1, $2, $3);
195
$mline .= <C> while not eof(C) and $mline =~ s/\\\n/\n/;
197
#print "sym: `$sym', args: `$args', mline: `$mline'\n";
199
$macrosargs{$sym} = [ [split /\s*,\s*/, $args], $mline];
201
$macros{$sym} = $mline;
204
close(C) or die "Cannot close file $file: $!\n";
205
[\%macros, \%macrosargs];
210
my ($mline,$line,%macros,%macrosargs,$sym,$args);
212
# save the old cppflags and add the flag for only ouputting macro definitions
213
my $old_cppstdin = $Cpp->{'cppstdin'};
214
$Cpp->{'cppstdin'} = $old_cppstdin . " " . $ModPerl::CScan::MACROS_ONLY;
216
my $stream = new C::Preprocessed (@_)
217
or die "Cannot open pipe from cppstdin: $!\n";
219
while (defined ($line = <$stream>)) {
222
^ \s* \# \s* # Start of directive
226
\( (.*?) \s* \) # 2: Minimal match for arguments
227
# in parenths (without trailing
229
)? # optional, no grouping
230
\s* # rest is the definition
231
([\s\S]*) # 3: the rest
233
($sym, $args, $mline) = ($1, $2, $3);
234
$mline .= <$stream> while ($mline =~ s/\\\n/\n/);
236
#print STDERR "sym: `$sym', args: `$args', mline: `$mline'\n";
238
$macrosargs{$sym} = [ [split /\s*,\s*/, $args], $mline];
240
$macros{$sym} = $mline;
243
# restore the original cppflags
244
$Cpp->{'cppstdin'} = $old_cppstdin;
245
[\%macros, \%macrosargs];
248
sub typedef_chunks { # Input is toplevel, output: starts and ends
252
while ($txt =~ /\btypedef\b/g) {
264
while ($txt =~ /\b(?=struct\s*(\w*\s*)?\{)/g) {
272
sub typedefs_whited { # Input is sanitized text, and list of beg/end.
276
while ($b = shift @lst) {
278
push @out, whited_decl($_[2], substr $_[0], $b, $e - $b);
287
while ($b = shift @lst) {
289
$in = substr $_[0], $b, $e - $b;
290
$in =~ s/^(struct\s*(\w*\s*)?)(.*)$/$1 . " " x length($3)/es;
297
my ($txt, $chunks) = (shift, shift);
298
my ($b, $e, $in, @out);
300
while (($b, $e) = splice @in, 0, 2) {
301
$in = substr($txt, $b, $e - $b);
302
# remove any remaining directives
303
$in =~ s/^ ( \s* \# .* ( \\ $ \n .* )* ) / ' ' x length($1)/xgem;
310
my ($typedefs, $whited) = (shift,shift);
314
for my $o (0..$#$typedefs) {
315
my $wh = $whited->[$o];
316
my $td = $typedefs->[$o];
317
#my $verb = $td =~ /apr_child_errfn_t/ ? 1 : 0;
318
#warn "$wh || $td\n" if $verb;
319
if ($wh =~ /,/ or not $wh =~ /\w/) { # Hard case, guessimates ...
320
# Determine whether the new thingies are inside parens
324
if (matchingbrace($wh)) { # Inside. Easy part: just split on /,/...
330
my $c = substr $wh, $s, 1;
331
if ($c =~ /[\(\{\[]/) {
333
} elsif ($c =~ /[\)\]\}]/) {
338
if ($s < 0) { # Should not happen
339
warn("panic: could not match braces in\n\t$td\nwhited as\n\t$wh\n");
343
} else { # We are at toplevel
344
# We need to skip back all the modifiers attached to the first thingy
345
# Guesstimates: everything after the first '*' (inclusive)
349
my $pre = substr $wh, 0, $ws;
351
$s = pos $pre if $pre =~ /(?=\*)/g;
354
# Now: need to split $td based on commas in $wh!
355
# And need to split each chunk of $td based on word in the chunk of $wh!
356
my $td_decls = substr($td, $s, $e - $s);
357
my ($pre, $post) = (substr($td, 0, $s), substr($td, $e));
358
my $wh_decls = substr($wh, $s, $e - $s);
359
my @wh_decls = split /,/, $wh_decls;
361
my (@td_decl, @td_pre, @td_post, @td_word);
362
for my $wh_d (@wh_decls) {
363
my $td_d = substr $td, $td_s, length $wh_d;
364
push @td_decl, $td_d;
367
push @td_post, substr $td_d, pos($wh_d);
368
push @td_pre, substr $td_d, pos($wh_d) - length $1, length $1;
369
$td_s += 1 + length $wh_d; # Skip over ','
371
for my $i (0..$#wh_decls) {
372
my $p = "$td_post[$i]$post";
373
$p = '' unless $p =~ /\S/;
374
$out{$td_word[$i]} = ["$pre$td_pre[$i]", $p];
376
} elsif ($td =~ /\(\s* \*? \s* ([^)]+) \s* \) \s* \(.*\)/gxs){ # XXX: function pointer typedef
377
$out{$1} = ['XXX: pre_foo', 'XXX: post_bar']; # XXX: not sure what to stuff here
378
#warn "[$1] [$td]" if $verb;
379
} else { # Only one thing defined...
382
my $s = $e - length $1;
384
my $pre = substr $td, 0, $s;
385
my $post = substr $td, $e, length($td) - $e;
386
$post = '' unless $post =~ /\S/;
387
$out{$type} = [$pre, $post];
396
sub typedef_structs {
397
my($typehash, $structs) = @_;
399
for (0 .. $#$structs) {
400
my $in = $structs->[$_];
402
next unless $in =~ /^struct\s*(\w+)/;
403
next unless $in =~ s{^(struct\s*)(\w+)}{
405
$1 . " " x length($2)
407
my $name = parse_struct($in, \%structs);
408
$structs{$key} = defined($name) ? $structs{$name} : undef;
410
while (my($key, $text) = each %$typehash) {
411
my $name = parse_struct($text->[0], \%structs);
412
$structs{$key} = defined($name) ? $structs{$name} : undef;
418
my($in, $structs) = @_;
419
my($b, $e, $chunk, $vars, $struct, $structname);
420
return "$1 $2" if $in =~ /
421
^ \s* (struct | union) \s+ (\w+) \s* $
423
($structname, $in) = $in =~ /
424
^ \s* ( (?: struct | union ) (?: \s+ \w+ )? ) \s* { \s* (.*?) \s* } \s* $
426
$structname .= " _ANON" unless $structname =~ /\s/;
427
$structname .= " 0" if exists $structs->{$structname};
428
$structname =~ s/(\d+$)/$1 + 1/e while exists $structs->{$structname};
429
$structname =~ s/\s+/ /g;
431
while ($in =~ /(\{|;|$)/g) {
432
matchingbrace($in), next if $1 eq '{';
435
$chunk = substr($in, $b, $e - $b);
437
if ($chunk =~ /\G\s*(struct|union|enum).*\}/gs) {
438
my $term = pos $chunk;
439
my $name = parse_struct(substr($chunk, 0, $term), $structs);
440
$vars = parse_vars(join ' ', $name, substr $chunk, $term);
442
$vars = parse_vars($chunk);
444
push @$struct, @{$vars||[]};
446
$structs->{$structname} = $struct;
452
my($vars, $type, $word, $id, $post, $func);
454
while ($in =~ /\G\s*([\[;,(]|\*+|:\s*\d+|\S+?\b|$)\s*/gc) {
456
if ($word eq ';' || $word eq '') {
457
next unless defined $id;
458
$type = 'int' unless defined $type; # or is this an error?
459
push @$vars, [ $type, $post, $id ];
460
($type, $post, $id, $func) = (undef, undef, undef);
461
} elsif ($word eq ',') {
462
warn "panic: expecting name before comma in '$in'\n" unless defined $id;
463
$type = 'int' unless defined $type; # or is this an error?
464
push @$vars, [ $type, $post, $id ];
467
} elsif ($word eq '[') {
468
warn "panic: expecting name before '[' in '$in'\n" unless defined $id;
469
$type = 'int' unless defined $type; # or is this an error?
472
$post .= $word . substr $in, $b, pos($in) - $b;
473
} elsif ($word eq '(') {
474
# simple hack for function pointers
475
$type = join ' ', grep defined, $type, $id if defined $id;
476
$type = 'int' unless defined $type;
477
if ($in =~ /\G\s*(\*[\s\*]*?)\s*(\w+)[\[\]\d\s]*(\)\s*\()/gc) {
483
$post .= substr $in, $b, pos($in) - $b;
485
warn "panic: can't parse function pointer declaration in '$in'\n";
488
} elsif ($word =~ /^:/) {
490
$type = 'int' unless defined $type;
497
warn "panic: not expecting '$word' after array bounds in '$in'\n";
500
$type = join ' ', grep defined, $type, $id if defined $id;
506
warn sprintf "failed on <%s> with type=<%s>, id=<%s>, post=<%s> at pos=%d\n",
507
$in, $type, $id, $post, pos($in);
513
my($vdecls, $mdecls) = @_;
515
for (@$vdecls, @$mdecls) {
516
next if /[()]/; # ignore functions, and function pointers
518
next unless $copy =~ s/^\s*extern\s*//;
519
my $vars = parse_vars($copy);
520
$vdecl_hash{$_->[2]} = [ @$_[0, 1] ] for @$vars;
525
# The output is the list of list of inline chunks and list of
526
# declaration chunks.
528
sub functions_in { # The arg is text without type declarations.
529
my $in = shift; # remove_type_decl(top_level(sanitize($txt)));
530
# What remains now consists of variable and function declarations,
531
# and inline functions.
533
my ($b, $e, $b1, $e1, @inlines, @decls, @mdecls, @fdecls, @vdecls);
536
while (defined($b) && $b != length $in) {
537
$in =~ /;/g or pos $in = $b, $in =~ /.*\S|\Z/g ; # Or last non-space
539
$chunk = substr $in, $b, $e - $b;
540
# Now subdivide the chunk.
542
# What we got is one chunk, probably finished by `;'. Whoever, it
543
# may start with several inline functions.
545
# Note that inline functions contain ( ) { } in the stripped version.
547
while ($chunk =~ /\(\s*\)\s*\{\s*\}/g) {
549
push @inlines, $b + $b1, $b + $e1;
552
$b1 = length $chunk, last unless defined $b1;
554
if ($e - $b - $b1 > 0) {
555
my($isvar, $isfunc) = (1, 1);
556
substr ($chunk, 0, $b1) = '';
557
if ($chunk =~ /,/) { # Contains multiple declarations.
558
push @mdecls, $b + $b1, $e;
559
} else { # Non-multiple.
560
# Since leading \s* is not optimized, this is quadratic!
563
| __attribute__ \s* \( \s* \)
564
) \s* )* ( ; \s* )? \Z # Strip from the end
567
if ($chunk =~ /\)\Z/) { # Function declaration ends on ")"!
569
\( .* \( # Multiple parenths
571
and $chunk =~ / \w \s* \( /x) { # Most probably pointer to a function?
575
^ \s* (enum|struct|union|class) \s+ \w+ \s* $
577
$isvar = $isfunc = 0;
579
if ($isvar) { # Heuristically variable
580
push @vdecls, $b + $b1, $e;
582
push @fdecls, $b + $b1, $e;
585
push @decls, $b + $b1, $e if $isvar || $isfunc;
590
[\@inlines, \@decls, \@mdecls, \@vdecls, \@fdecls];
593
# XXXX This is heuristical in many respects...
594
# Recipe: remove all struct-ish chunks. Remove all array specifiers.
595
# Remove GCC attribute specifiers.
596
# What remains may contain function's arguments, old types, and newly
598
# Remove function arguments using heuristics methods.
599
# Now out of several words in a row the last one is a newly defined type.
601
sub whited_decl { # Input is sanitized.
602
my $keywords_rex = shift;
603
my $in = shift; # Text of a declaration
605
#typedef ret_type*(*func) -> typedef ret_type* (*func)
606
$in =~ s/\*\(\*/* \(*/;
609
my $out = $in; # Whited out $in
611
# Remove all the structs
612
while ($out =~ /(\b(struct|union|class|enum)(\s+\w+)?\s*\{)/g) {
613
my $pos_start = pos($out) - length $1;
616
my $pos_end = pos $out;
617
substr($out, $pos_start, $pos_end - $pos_start) =
618
' ' x ($pos_end - $pos_start);
622
# Deal with glibc's wierd ass __attribute__ tag. Just dump it.
623
# Maaaybe this should check to see if you're using GCC, but I don't
624
# think so since glibc is nice enough to do that for you. [MGS]
625
while ( $out =~ m/(\b(__attribute__|attribute)\s*\((?=\s*\())/g ) {
626
my $att_pos_start = pos($out) - length($1);
628
# Need to figure out where ((..)) ends.
630
my $att_pos_end = pos $out;
632
# Remove the __attribute__ tag.
633
substr($out, $att_pos_start, $att_pos_end - $att_pos_start) =
634
' ' x ($att_pos_end - $att_pos_start);
635
pos $out = $att_pos_end;
638
# Remove arguments of functions (heuristics only).
639
# These things (start) arglist of a declared function:
641
# paren word space non-paren
642
# paren keyword paren
643
# start a list of arguments. (May be "cdecl *myfunc"?) XXXXX ?????
644
while ( $out =~ /(\(\s*(\w+(,|\s*[^\)\s])|$keywords_rex\s*\)))/g ) {
645
my $pos_start = pos($out) - length($1);
646
pos $out = $pos_start + 1;
648
substr ($out, $pos_start + 1, pos($out) - 2 - $pos_start)
649
= ' ' x (pos($out) - 2 - $pos_start);
651
# Remove array specifiers
652
$out =~ s/(\[[\w\s\+]*\])/ ' ' x length $1 /ge;
654
# Several words in a row cannot be new typedefs, but the last one.
655
$out =~ s/((\w+\**\s+)+(?=[^\s,;\[\{\)]))/ ' ' x length $1 /ge;
656
unless ($out =~ /\w/) {
657
# Probably a function-type declaration: typedef int f(int);
658
# Redo scan leaving the last word of the first group of words:
659
$tout =~ /(\w+\s+)*(\w+)\s*\(/g;
660
$out = ' ' x (pos($tout) - length $2)
661
. $2 . ' ' x (length($tout) - pos($tout));
662
# warn "function typedef\n\t'$in'\nwhited-out as\n\t'$out'\n";
664
warn "panic: length mismatch\n\t'$in'\nwhited-out as\n\t'$out'\n"
665
if length($in) != length $out;
667
warn "panic: multiple types without intervening comma in\n\t$in\nwhited-out as\n\t$out\n"
668
if $out =~ /\w[^\w,]+\w/;
669
warn "panic: no types found in\n\t$in\nwhited-out as\n\t$out\n"
675
# pos($_[0]) is after the opening brace now
677
while ($_[0] =~ /([\{\[\(])|([\]\)\}])/g) {
681
# pos($_[0]) is after the closing brace now
685
sub remove_Comments_no_Strings { # We expect that no strings are around
687
$in =~ s,/(/.*|\*[\s\S]*?\*/),,g ; # C and C++
688
die "Unfinished comment" if $in =~ m,/\*, ;
692
sub sanitize { # We expect that no strings are around
694
# C and C++, strings and characters
698
\* [\s\S]*? \*/ # C style
700
| '((?:[^\\\']|\\.)+)' # (2) Character constants
701
| "((?:[^\\\"]|\\.)*)" # (3) Strings
702
| ( ^ \s* \# .* # (4) Preprocessor
703
( \\ $ \n .* )* ) # and continuation lines
705
# We want to preserve the length, so that one may go back
706
defined $1 ? ' ' x (1 + length $1) :
707
defined $4 ? ' ' x length $4 :
708
defined $2 ? "'" . ' ' x length($2) . "'" :
709
defined $3 ? '"' . ' ' x length($3) . '"' : '???'
711
die "Unfinished comment" if $in =~ m{ /\* }x;
715
sub top_level { # We expect argument is sanitized
716
# Note that this may remove the variable in declaration: int (*func)();
720
while ($in =~ /[\[\{\(]/g ) {
723
substr($out, $start, pos($in) - 1 - $start)
724
= ' ' x (pos($in) - 1 - $start);
729
sub remove_type_decl { # We suppose that the arg is top-level only.
731
$in =~ s/(\b__extension__)(\s+typedef\b)/(' ' x length $1) . $2/gse;
732
$in =~ s/(\btypedef\b.*?;)/' ' x length $1/gse;
733
# The following form may appear only in the declaration of the type itself:
735
s/(\b(enum|struct|union|class)\b[\s\w]*\{\s*\}\s*;)/' ' x length $1/gse;
741
my $out = SUPER::new $class $recipes;
746
sub do_declarations {
747
my @d = map do_declaration($_, $_[1], $_[2]), @{ $_[0] };
751
# Forth argument: if defined, there maybe no identifier. Generate one
752
# basing on this argument.
755
my ($decl, $typedefs, $keywords, $argnum) = @_;
758
my ($type, $typepre, $typepost, $ident, $args, $w, $pos, $repeater);
759
$decl =~ s/[\r\n]\s*/ /g;
760
#warn "DECLAR [$decl][$argnum]\n";
761
$decl =~ s/^\s*__extension__\b\s*//;
762
$decl =~ s/^\s*extern\b\s*//;
763
$decl =~ s/^\s*__inline\b\s*//;
765
while ($decl =~ /(\w+)/g and ($typedefs->{$1} or $keywords->{$1})) {
767
if ($w =~ /^(struct|class|enum|union)$/) {
768
$decl =~ /\G\s+\w+/g or die "`$w' is not followed by word in `$decl'";
774
$decl =~ /\G[\s*]*\*/g or pos $decl = $pos;
775
$type = substr $decl, 0, pos $decl;
776
$decl =~ /\G\s*/g or pos $decl = length $type; # ????
779
if (defined $argnum) {
780
if ($decl =~ /\G(\w+)((\s*\[[^][]*\])*)/g) { # The best we can do with [2]
785
pos $decl = $pos = length $decl;
787
$ident = "arg$argnum";
790
die "Cannot process declaration `$decl' without an identifier"
791
unless $decl =~ /\G(\w+)/g;
796
$decl =~ /\G\s*/g or pos $decl = $pos;
798
#my $st = length $decl;
799
#warn substr($decl, 0, $pos), "\n";
800
#warn "pos: $pos $st\n";
801
#warn "DECLAR [$decl][$argnum]\n";
802
if (pos $decl != length $decl) {
804
die "Expecting parenth after identifier in `$decl'\nafter `",
805
substr($decl, 0, $pos), "'"
806
unless $decl =~ /\G\(/g;
807
my $argstring = substr($decl, pos($decl) - length $decl);
808
matchingbrace($argstring) or die "Cannot find matching parenth in `$decl'";
809
$argstring = substr($argstring, 0, pos($argstring) - 1);
810
$argstring =~ s/ ^ ( \s* void )? \s* $ //x;
813
if ($argstring ne '') {
814
my $top = top_level $argstring;
817
while ($top =~ /,/g) {
818
$arg = substr($argstring, $p, pos($top) - 1 - $p);
819
$arg =~ s/^\s+|\s+$//gs;
823
$arg = substr $argstring, $p;
824
$arg =~ s/^\s+|\s+$//gs;
829
push @$args, do_declaration1($_, $typedefs, $keywords, $i++);
832
[$type, $ident, $args, $decl, $repeater];
835
sub do_declaration1 {
836
my ($decl, $typedefs, $keywords, $argnum) = @_;
838
#warn "DECLARO [$decl][$argnum]\n";
839
my ($type, $typepre, $typepost, $ident, $args, $w, $pos, $repeater);
841
while ($decl =~ /(\w+)/g and ($typedefs->{$1} or $keywords->{$1})) {
843
if ($w =~ /^(struct|class|enum|union)$/) {
844
$decl =~ /\G\s+\w+/g or die "`$w' is not followed by word in `$decl'";
850
$decl =~ /\G[\s*]*\*/g or pos $decl = $pos;
851
$type = substr $decl, 0, pos $decl;
852
$decl =~ /\G\s*/g or pos $decl = length $type; # ????
854
if (defined $argnum) {
855
if ($decl =~ /\G(\w+)((\s*\[[^][]*\])*)/g) { # The best we can do with [2]
860
pos $decl = $pos = length $decl;
862
$ident = "arg$argnum";
865
die "Cannot process declaration `$decl' without an identifier"
866
unless $decl =~ /\G(\w+)/g;
870
$decl =~ /\G\s*/g or pos $decl = $pos;
872
#warn "DECLAR1 [$decl][$argnum]\n";
873
#my $st = length $decl;
874
#warn substr($decl, 0, $pos), "\n";
875
#warn "pos: $pos $st\n";
876
if (pos $decl != length $decl) {
878
die "Expecting parenth after identifier in `$decl'\nafter `",
879
substr($decl, 0, $pos), "'"
880
unless $decl =~ /\G\(/g;
881
my $argstring = substr($decl, pos($decl) - length $decl);
882
matchingbrace($argstring) or die "Cannot find matching parenth in `$decl'";
883
$argstring = substr($argstring, 0, pos($argstring) - 1);
884
$argstring =~ s/ ^ ( \s* void )? \s* $ //x;
887
if ($argstring ne '') {
888
my $top = top_level $argstring;
891
while ($top =~ /,/g) {
892
$arg = substr($argstring, $p, pos($top) - 1 - $p);
893
$arg =~ s/^\s+|\s+$//gs;
897
$arg = substr $argstring, $p;
898
$arg =~ s/^\s+|\s+$//gs;
903
push @$args, do_declaration1($_, $typedefs, $keywords, $i++);
906
[$type, $ident, $args, $decl, $repeater];
909
############################################################
911
package C::Preprocessed;
917
die "usage: C::Preprocessed->new(filename[, defines[, includes[, cpp]]])"
919
my ($class, $filename, $Defines, $Includes, $Cpp)
920
= (shift, shift, shift, shift, shift);
921
$Cpp ||= \%Config::Config;
922
my $filedir = dirname $filename || '.';
923
$Includes ||= [$filedir, '/usr/local/include', '.'];
924
my $addincludes = "";
925
$addincludes = "-I" . join(" -I", @$Includes)
926
if defined $Includes and @$Includes;
928
my $cmd = "echo '\#include \"$filename\"' | $Cpp->{cppstdin} $Defines $addincludes $Cpp->{cppflags} $Cpp->{cppminus} |";
929
#my $cmd = "$Cpp->{cppstdin} $Defines $addincludes $Cpp->{cppflags} $Cpp->{cppminus} < $filename |";
930
#my $cmd = "echo '\#include <$filename>' | $Cpp->{cppstdin} $Defines $addincludes $Cpp->{cppflags} $Cpp->{cppminus} |";
932
(open($sym, $cmd) or die "Cannot open pipe from `$cmd': $!")
933
and bless $sym => $class;
939
if (defined $filter) {
940
return text_only_from($class, $filter, @_);
942
my $stream = $class->new(@_);
943
my $oh = select $stream;
951
my $from = shift || die "Expecting argument in `text_only_from'";
952
my $stream = $class->new(@_);
953
my $on = $from eq $_[0];
954
my $eqregexp = $on ? '\"\"|' : '';
959
$on = /$eqregexp[\"\/]\Q$from\"/ if /^\#/;
960
push @out, $_ if $on;
967
or die "Cannot close pipe from `$Config::Config{cppstdin}': err $?, $!\n";
970
# Autoload methods go after __END__, and are processed by the autosplit program.
971
# Return to the principal package.
972
package ModPerl::CScan;
979
ModPerl::CScan - scan C language files for easily recognized constructs.
985
See the C<C::Scan> manpage. This package is just a fork to fix certain
986
things that didn't work in the original C<C::Scan>, which is not
987
maintained any longer. These fixes required to make it work with the
988
Apache 2 source code.
added
removed
lib/ModPerl/CScan.pm
