File Coverage

File:lib/Parrot/Headerizer/Object.pm
Coverage:96.6%

linestmtbrancondsubcode
1# Copyright (C) 2004-2010, Parrot Foundation.
2# $Id$
3
4package Parrot::Headerizer::Object;
5
6 - 23
=head1 NAME

Parrot::Headerizer::Object - Parrot Header Generation functionality

=head1 SYNOPSIS

    use Parrot::Headerizer::Object;

    my $headerizer = Parrot::Headerizer::Object->new();

=head1 DESCRIPTION

C<Parrot::Headerizer::Object> knows how to extract all kinds of information out
of C-language files.

=head1 METHODS

=cut
24
25
1
1
1
1
use strict;
26
1
1
1
1
use warnings;
27
1
1
1
1
use Data::Dumper;$Data::Dumper::Indent=1;
28
1
1
1
1
use Scalar::Util qw( reftype );
29
1
1
1
1
use lib qw( lib );
30
1
1
1
1
use Parrot::Config;
31
1
use Parrot::Headerizer::Functions qw(
32    read_file
33    write_file
34    qualify_sourcefile
35    replace_pod_item
36    no_both_PARROT_EXPORT_and_PARROT_INLINE
37    validate_prototype_args
38    no_both_static_and_PARROT_EXPORT
39    handle_split_declaration
40    asserts_from_args
41    shim_test
42    handle_modified_args
43    add_newline_if_multiline
44    add_asserts_to_declarations
45    func_modifies
46    add_headerizer_markers
47
1
1
1
);
48
49 - 53
=head2 C<new()>

Constructor of headerizer objects.

=cut
54
55sub new {
56
13
13
    my ($class, $args) = @_;
57
13
100
    if (defined $args) {
58
3
100
        die "Argument to Parrot::Headerizer::Object must be hashref"
59            unless reftype($args) eq 'HASH';
60    }
61    else {
62
10
        $args = {};
63    }
64
12
100
    $args->{macro_match} = undef unless defined $args->{macro_match};
65
12
    $args->{warnings} = {};
66
12
    $args->{message} = '';
67
12
180
    $args->{valid_macros} = { map { ( $_, 1 ) } qw(
68        PARROT_EXPORT
69        PARROT_INLINE
70        PARROT_NOINLINE
71
72        PARROT_CAN_RETURN_NULL
73        PARROT_CANNOT_RETURN_NULL
74
75        PARROT_IGNORABLE_RESULT
76        PARROT_WARN_UNUSED_RESULT
77
78        PARROT_PURE_FUNCTION
79        PARROT_CONST_FUNCTION
80
81        PARROT_DOES_NOT_RETURN
82        PARROT_DOES_NOT_RETURN_WHEN_FALSE
83
84        PARROT_MALLOC
85        PARROT_OBSERVER
86
87        PARROT_HOT
88        PARROT_COLD
89        )
90    };
91
12
    return bless $args, $class;
92}
93
94sub get_sources {
95
9
9
    my $self = shift;
96
9
    my @ofiles = @_;
97
9
    my %sourcefiles;
98
9
    my %sourcefiles_with_statics;
99
9
    my %api;
100    # Walk the object files and find corresponding source (either .c or .pmc)
101
9
    for my $ofile (@ofiles) {
102
103        # Skip files in the src/ops/ subdirectory.
104
9
100
67
        next if $ofile =~ m/^\Qsrc$PConfig{slash}ops\E/ || # if run by hand...
105                $ofile =~ m{^src/ops}; # ... or by makefile
106
107
8
        $ofile =~ s/\\/\//g;
108
109
8
        my $is_yacc = ($ofile =~ /\.y$/);
110
8
50
        if ( !$is_yacc ) {
111
8
            my $sfile = $ofile;
112
8
            $sfile =~ s/\Q$PConfig{o}\E$/.s/;
113
8
100
            next if -f $sfile;
114        }
115
116
7
        my ($sourcefile, $source_code, $hfile) =
117            qualify_sourcefile( {
118                ofile => $ofile,
119                PConfig => \%PConfig,
120                is_yacc => $is_yacc,
121            } );
122
123
7
        my @decls;
124
7
100
        if ( $self->{macro_match} ) {
125
1
            @decls = $self->extract_function_declarations( $source_code );
126        }
127        else {
128
6
            @decls =
129            $self->extract_function_declarations_and_update_source( $sourcefile );
130        }
131
132
7
        for my $decl (@decls) {
133
38
            my $components =
134                $self->function_components_from_declaration( $sourcefile, $decl );
135
38
35
100
            push( @{ $sourcefiles{$hfile}->{$sourcefile} }, $components )
136                unless $hfile eq 'none';
137
38
3
100
            push( @{ $sourcefiles_with_statics{$sourcefile} }, $components )
138                if $components->{is_static};
139
38
100
            if ( $self->{macro_match} ) {
140
7
10
7
100
                if ( grep { $_ eq $self->{macro_match} } @{$components->{macros}} ) {
141
2
2
                    push( @{ $api{$sourcefile} }, $components );
142                }
143            }
144        }
145    } # for @cfiles
146
9
    $self->{sourcefiles} = \%sourcefiles;
147
9
    $self->{sourcefiles_with_statics} = \%sourcefiles_with_statics;
148
9
    $self->{api} = \%api;
149}
150
151 - 158
=head2 C<extract_function_declarations()>

    $headerizer->extract_function_declarations($text)

Extracts the function declarations from the text argument, and returns an
array of strings containing the function declarations.

=cut
159
160sub extract_function_declarations {
161
7
7
    my $self = shift;
162
7
    my $text = shift;
163
164    # Only check the YACC C code if we find what looks like YACC file
165
7
    $text =~ s/%\{(.*)%\}.*/$1/sm;
166
167    # Drop all text after HEADERIZER STOP
168
7
    $text =~ s{/\*\s*HEADERIZER STOP.+}{}s;
169
170    # Strip blocks of comments
171
7
    $text =~ s{^/\*.*?\*/}{}mxsg;
172
173    # Strip # compiler directives
174
7
    $text =~ s{^#(\\\n|.)*}{}mg;
175
176    # Strip code blocks
177
7
    $text =~ s/^{.+?^}//msg;
178
179    # Split on paragraphs
180
7
    my @funcs = split /\n{2,}/, $text;
181
182    # If it doesn't start in the left column, it's not a func
183
7
136
    @funcs = grep { /^\S/ } @funcs;
184
185    # Typedefs, enums and externs are no good
186
7
43
    @funcs = grep { !/^(?:typedef|enum|extern)\b/ } @funcs;
187
188    # Structs are OK if they're not alone on the line
189
7
43
    @funcs = grep { !/^struct.+;\n/ } @funcs;
190
191    # Structs are OK if they're not being defined
192
7
43
    @funcs = grep { !/^(?:static\s+)?struct.+{\n/ } @funcs;
193
194    # Ignore magic function name YY_DECL
195
7
43
    @funcs = grep { !/YY_DECL/ } @funcs;
196
197    # Ignore anything with magic words HEADERIZER SKIP
198
7
43
    @funcs = grep { !m{/\*\s*HEADERIZER SKIP\s*\*/} } @funcs;
199
200    # pmclass declarations in PMC files are no good
201
7
43
    @funcs = grep { !m{^pmclass } } @funcs;
202
203    # Variables are of no use to us
204
7
41
    @funcs = grep { !/=/ } @funcs;
205
206    # Get rid of any blocks at the end
207
7
7
    s/\s*{.*//s for @funcs;
208
209    # Toast anything non-whitespace
210
7
41
    @funcs = grep { /\S/ } @funcs;
211
212    # If it's got a semicolon, it's not a function header
213
7
41
    @funcs = grep { !/;/ } @funcs;
214
215    # remove any remaining }'s
216
7
38
    @funcs = grep {! /^}/} @funcs;
217
218
7
    chomp @funcs;
219
220
7
    return @funcs;
221}
222
223 - 228
=head2 extract_function_declaration_and_update_source( $cfile_name )

Extract all the function declarations from the C file specified by
I<$cfile_name>, and update the comment blocks within.

=cut
229
230sub extract_function_declarations_and_update_source {
231
6
6
    my $self = shift;
232
6
    my $cfile_name = shift;
233
234
6
50
    open( my $fhin, '<', $cfile_name ) or die "Can't open $cfile_name: $!";
235
6
    my $text = join( '', <$fhin> );
236
6
    close $fhin;
237
238
6
    my @func_declarations = $self->extract_function_declarations( $text );
239
6
    for my $decl ( @func_declarations ) {
240
31
        my $specs = $self->function_components_from_declaration( $cfile_name, $decl );
241
31
        my $name = $specs->{name};
242
243
31
        my $heading = $self->generate_documentation_signature($decl);
244
31
        $text = replace_pod_item( {
245            text => $text,
246            name => $name,
247            heading => $heading,
248            cfile_name => $cfile_name,
249        } );
250    }
251
6
50
    open( my $fhout, '>', $cfile_name ) or die "Can't create $cfile_name: $!";
252
6
6
    print {$fhout} $text;
253
6
    close $fhout;
254
255
6
    return @func_declarations;
256}
257
258 - 275
=head2 C<function_components_from_declaration($file, $proto)>

$file => the filename
$proto => the function declaration

Returns an anonymous hash of function components:

        file         => $file,
        name         => $name,
        args         => \@args,
        macros       => \@macros,
        is_static    => $is_static,
        is_inline    => $parrot_inline,
        is_api       => $parrot_api,
        is_ignorable => $is_ignorable,
        return_type  => $return_type,

=cut
276
277sub function_components_from_declaration {
278
69
69
    my $self = shift;
279
69
    my $file = shift;
280
69
    my $proto = shift;
281
282
69
    my @lines = split( /\n/, $proto );
283
69
    chomp @lines;
284
285
69
    my @macros;
286
69
    my $parrot_api;
287
69
    my $parrot_inline;
288
289
69
67
    while ( @lines && ( $lines[0] =~ /^PARROT_/ ) ) {
290
94
        my $macro = shift @lines;
291
94
100
100
        if ( $macro eq 'PARROT_EXPORT' ) {
292
63
            $parrot_api = 1;
293        }
294        elsif ( $macro eq 'PARROT_INLINE' ) {
295
2
            $parrot_inline = 1;
296        }
297
94
        push( @macros, $macro );
298    }
299
300
69
    my $return_type = shift @lines;
301
69
    my $args = join( ' ', @lines );
302
303
69
    $args =~ s/\s+/ /g;
304
69
50
    $args =~ s{([^(]+)\s*\((.+)\);?}{$2}
305        or die qq{Couldn't handle "$proto" in $file\n};
306
307
69
    my $name = $1;
308
69
    $args = $2;
309
310
69
    no_both_PARROT_EXPORT_and_PARROT_INLINE( {
311        file => $file,
312        name => $name,
313        parrot_inline => $parrot_inline,
314        parrot_api => $parrot_api,
315    } );
316
317
69
    my @args = validate_prototype_args( $args, $proto );
318
319
69
    my $is_static;
320
69
    ($return_type, $is_static) = no_both_static_and_PARROT_EXPORT( {
321        file => $file,
322        name => $name,
323        return_type => $return_type,
324        parrot_api => $parrot_api,
325    } );
326
327
69
    my $is_ignorable = 0;
328
69
    my %macros;
329
69
    for my $macro (@macros) {
330
94
        $macros{$macro} = 1;
331
94
50
        if (not $self->valid_macro($macro)) {
332
0
            $self->squawk( $file, $name, "Invalid macro $macro" );
333        }
334
94
100
        if ( $macro eq 'PARROT_IGNORABLE_RESULT' ) {
335
2
            $is_ignorable = 1;
336        }
337    }
338    $self->check_pointer_return_type( {
339
69
        return_type => $return_type,
340        macros => \%macros,
341        name => $name,
342        file => $file,
343    } );
344
345    return {
346
69
        file => $file,
347        name => $name,
348        args => \@args,
349        macros => \@macros,
350        is_static => $is_static,
351        is_inline => $parrot_inline,
352        is_api => $parrot_api,
353        is_ignorable => $is_ignorable,
354        return_type => $return_type,
355    };
356}
357
358 - 367
=head2 C<check_pointer_return_type()>

    $self->check_pointer_return_type( {
        return_type     => $return_type,
        macros          => \%macros,
        name            => $name,
        file            => $file,
    } );

=cut
368
369sub check_pointer_return_type {
370
76
76
    my ($self, $args) = @_;
371
76
100
    if ( $args->{return_type} =~ /\*/ ) {
372
33
100
100
100
100
        if ( !$args->{macros}->{PARROT_CAN_RETURN_NULL} && !$args->{macros}->{PARROT_CANNOT_RETURN_NULL} ) {
373
2
100
            if ( $args->{name} !~ /^yy/ ) { # Don't complain about lexer-created functions
374
1
                $self->squawk( $args->{file}, $args->{name},
375                    'Returns a pointer, but no PARROT_CAN(NOT)_RETURN_NULL macro found.' );
376            }
377        }
378        elsif ( $args->{macros}->{PARROT_CAN_RETURN_NULL} && $args->{macros}->{PARROT_CANNOT_RETURN_NULL} ) {
379
1
            $self->squawk( $args->{file}, $args->{name},
380                q{Can't have both PARROT_CAN_RETURN_NULL and PARROT_CANNOT_RETURN_NULL together.} );
381        }
382    }
383}
384
385 - 390
=head2 C<generate_documentation_signature>

Given an extracted function signature, return a modified
version suitable for inclusion in POD documentation.

=cut
391
392sub generate_documentation_signature {
393
31
31
    my $self = shift;
394
31
    my $function_decl = shift;
395
396    # strip out any PARROT_* function modifiers
397
31
    foreach my $key ($self->valid_macros) {
398
465
        $function_decl =~ s/^$key$//m;
399    }
400
401
31
    $function_decl =~ s/^\s+//g;
402
31
    $function_decl =~ s/\s+/ /g;
403
404    # strip out any ARG* modifiers
405
31
    $function_decl =~ s/ARG(?:IN|IN_NULLOK|OUT|OUT_NULLOK|MOD|MOD_NULLOK|FREE|FREE_NOTNULL)\((.*?)\)/$1/g;
406
407    # strip out the SHIM modifier
408
31
    $function_decl =~ s/SHIM\((.*?)\)/$1/g;
409
410    # strip out the NULL modifiers
411
31
    $function_decl =~ s/(?:NULLOK|NOTNULL)\((.*?)\)/$1/g;
412
413    # SHIM_INTERP is still a PARROT_INTERP
414
31
    $function_decl =~ s/SHIM_INTERP/PARROT_INTERP/g;
415
416    # wrap with POD
417
31
    $function_decl = "=item C<$function_decl>";
418
419    # Wrap long lines.
420
31
    my $line_len = 80;
421
31
100
    if (length($function_decl)<= $line_len) {
422
17
        return $function_decl;
423    }
424    else {
425
14
        return handle_split_declaration(
426            $function_decl,
427            $line_len,
428        );
429    }
430}
431
432 - 438
=head2 C<valid_macro()>

    $headerizer->valid_macro( $macro )

Returns a boolean saying whether I<$macro> is a valid C<PARROT_XXX> macro.

=cut
439
440sub valid_macro {
441
96
96
    my $self = shift;
442
96
    my $macro = shift;
443
444
96
    return exists $self->{valid_macros}{$macro};
445}
446
447 - 453
=head2 C<valid_macros()>

    $headerizer->valid_macros()

Returns a list of all the valid C<PARROT_XXX> macros.

=cut
454
455sub valid_macros {
456
32
32
    my $self = shift;
457
458
32
32
    my @macros = sort keys %{$self->{valid_macros}};
459
460
32
    return @macros;
461}
462
463 - 471
=head2 C<squawk($file, $func, $error)>

Headerizer-specific ways of complaining if something went wrong.

$file => filename
$func => function name
$error => error message text

=cut
472
473sub squawk {
474
6
6
    my $self = shift;
475
6
    my $file = shift;
476
6
    my $func = shift;
477
6
    my $error = shift;
478
479
6
6
    push( @{ $self->{warnings}{$file}{$func} }, $error );
480
481
6
    return;
482}
483
484sub process_sources {
485
4
4
    my ($self) = @_;
486
4
4
    my %sourcefiles = %{$self->{sourcefiles}};
487
4
4
    my %sourcefiles_with_statics = %{$self->{sourcefiles_with_statics}};
488
4
4
    my %api = %{$self->{api}};
489
4
100
    if ( $self->{macro_match} ) {
490
1
        my $nfuncs = 0;
491
1
        for my $cfile ( sort keys %api ) {
492
1
1
1
            my @funcs = sort { $a->{name} cmp $b->{name} } @{$api{$cfile}};
493
1
            print "$cfile\n";
494
1
            for my $func ( @funcs ) {
495
2
                print " $func->{name}\n";
496
2
                ++$nfuncs;
497            }
498        }
499
1
50
        my $s = $nfuncs == 1 ? '' : 's';
500
1
        $self->{message} = "$nfuncs $self->{macro_match} function$s";
501    }
502    else { # Normal headerization and updating
503        # Update all the .h files
504
3
        for my $hfile ( sort keys %sourcefiles ) {
505
1
            my $sourcefiles = $sourcefiles{$hfile};
506
507
1
            my $header = read_file($hfile);
508
509
1
1
            for my $cfile ( sort keys %{$sourcefiles} ) {
510
1
1
                my @funcs = @{ $sourcefiles->{$cfile} };
511
1
7
                @funcs = grep { not $_->{is_static} } @funcs; # skip statics
512
1
                $header = $self->replace_headerized_declarations(
513                    $header, $cfile, $hfile, @funcs );
514            }
515
516
1
            write_file( $hfile, $header );
517        }
518
519        # Update all the .c files in place
520
3
        for my $cfile ( sort keys %sourcefiles_with_statics ) {
521
2
2
            my @funcs = @{ $sourcefiles_with_statics{$cfile} };
522
2
3
            @funcs = grep { $_->{is_static} } @funcs;
523
524
2
            my $source = read_file($cfile);
525
2
            $source = $self->replace_headerized_declarations( $source, 'static', $cfile, @funcs );
526
527
2
            write_file( $cfile, $source );
528        }
529
3
        $self->{message} = "Headerization complete.";
530    }
531}
532
533sub replace_headerized_declarations {
534
3
3
    my $self = shift;
535
3
    my $source_code = shift;
536
3
    my $sourcefile = shift;
537
3
    my $hfile = shift;
538
3
    my @funcs = @_;
539
540    # Allow a way to not headerize statics
541
3
50
    if ( $source_code =~ m{/\*\s*HEADERIZER NONE:\s*$sourcefile\s*\*/} ) {
542
0
        return $source_code;
543    }
544
545
15
50
100
50
50
100
    @funcs = sort {
546
3
        ( ( $b->{is_api} || 0 ) <=> ( $a->{is_api} || 0 ) )
547        || ( ( lc($a->{name}) || '') cmp ( lc($b->{name}) || '') )
548    } @funcs;
549
3
    my @function_decls = $self->make_function_decls(@funcs);
550
551
3
    my $markers_args = {
552        function_decls => \@function_decls,
553        sourcefile => $sourcefile,
554        hfile => $hfile,
555        code => $source_code,
556    };
557
558
3
    return add_headerizer_markers( $markers_args );
559}
560
561
562sub make_function_decls {
563
3
3
    my $self = shift;
564
3
    my @funcs = @_;
565
566
3
    my @decls;
567
3
    foreach my $func (@funcs) {
568
10
        my $alt_void = ' ';
569
570        # Splint can't handle /*@alt void@*/ on pointers, although this page
571        # http://www.mail-archive.com/lclint-interest@virginia.edu/msg00139.html
572        # seems to say that we can.
573
10
100
67
        if ( $func->{is_ignorable} && ($func->{return_type} !~ /\*/) ) {
574
1
            $alt_void = " /*\@alt void@*/\n";
575        }
576
577
10
        my $decl = sprintf( "%s%s%s(" => (
578            $func->{return_type},
579            $alt_void,
580            $func->{name}
581        ) );
582
10
100
        $decl = "static $decl" if $func->{is_static};
583
584
10
10
        my @args = @{ $func->{args} };
585
10
        my @attrs = $self->attrs_from_args( $func, @args );
586
587
10
        my @modified_args = shim_test($func, \@args);
588
589
10
        my $multiline;
590
10
        ($decl, $multiline) = handle_modified_args(
591            $decl, \@modified_args);
592
593
10
22
        my $attrs = join( "", map { "\n\t\t$_" } @attrs );
594
10
100
        if ($attrs) {
595
8
            $decl .= $attrs;
596
8
            $multiline = 1;
597        }
598
10
10
        my @macros = @{ $func->{macros} };
599
10
100
        $multiline = 1 if @macros;
600
601
10
        $decl = add_newline_if_multiline($decl, $multiline);
602
10
        $decl = join( "\n", @macros, $decl );
603
10
        $decl =~ s/\t/ /g;
604
10
        push( @decls, $decl );
605    }
606
607
3
    @decls = add_asserts_to_declarations( \@funcs, \@decls );
608
609
3
    return @decls;
610}
611
612sub attrs_from_args {
613
17
17
    my $self = shift;
614
17
    my $func = shift;
615
17
    my @args = @_;
616
617
17
    my @attrs = ();
618
17
    my @mods = ();
619
620
17
    my $name = $func->{name};
621
17
    my $file = $func->{file};
622
17
    my $n = 0;
623
17
    for my $arg (@args) {
624
30
        ++$n;
625
30
        @mods = func_modifies($arg, \@mods);
626
30
100
100
        if ( $arg =~ m{(ARGIN|ARGOUT|ARGMOD|ARGFREE_NOTNULL|NOTNULL)\(} || $arg eq 'PARROT_INTERP' ) {
627
15
            push( @attrs, "__attribute__nonnull__($n)" );
628        }
629
30
100
100
        if ( ( $arg =~ m{\*} ) && ( $arg !~ /\b(SHIM|((ARGIN|ARGOUT|ARGMOD)(_NULLOK)?)|ARGFREE(_NOTNULL)?)\b/ ) ) {
630
2
100
            if ( $name !~ /^yy/ ) { # Don't complain about the lexer auto-generated funcs
631
1
                $self->squawk( $file, $name, qq{"$arg" isn't protected with an ARGIN, ARGOUT or ARGMOD (or a _NULLOK variant), or ARGFREE} );
632            }
633        }
634
30
100
100
        if ( ($arg =~ /\bconst\b/) && ($arg =~ /\*/) && ($arg !~ /\*\*/) && ($arg =~ /\b(ARG(MOD|OUT))\b/) ) {
635
1
            $self->squawk( $file, $name, qq{"$arg" is const, but that $1 conflicts with const} );
636        }
637    }
638
639
17
    return (@attrs,@mods);
640}
641
642sub print_final_message {
643
6
6
    my $self = shift;
644
6
100
    if ($self->{message} ne '') {
645
5
        print "$self->{message}\n";
646    }
647}
648
649 - 663
=head2 C<print_headerizer_warnings()>

=over 4

=item * Purpose

=item * Arguments

=item * Return Value

=item * Comment

=back

=cut
664
665sub print_warnings {
666
17
17
    my $self = shift;
667
17
17
    my %warnings = %{$self->{warnings}};
668
17
100
    if ( keys %warnings ) {
669
6
        my $nwarnings = 0;
670
6
        my $nwarningfuncs = 0;
671
6
        my $nwarningfiles = 0;
672
6
        for my $file ( sort keys %warnings ) {
673
7
            ++$nwarningfiles;
674
7
            print "$file\n";
675
7
            my $funcs = $warnings{$file};
676
7
7
            for my $func ( sort keys %{$funcs} ) {
677
8
                ++$nwarningfuncs;
678
8
8
                for my $error ( @{ $funcs->{$func} } ) {
679
14
                    print " $func: $error\n";
680
14
                    ++$nwarnings;
681                }
682            }
683        }
684
685
6
        print "$nwarnings warnings in $nwarningfuncs funcs in $nwarningfiles C files\n";
686    }
687}
688
6891;
690
691# Local Variables:
692# mode: cperl
693# cperl-indent-level: 4
694# fill-column: 100
695# End:
696# vim: expandtab shiftwidth=4: