File Coverage

File:lib/Parrot/Headerizer/Functions.pm
Coverage:98.9%

linestmtbrancondsubcode
1# Copyright (C) 2004-2010, Parrot Foundation.
2# $Id$
3
4package Parrot::Headerizer::Functions;
5
2
2
2
2
use strict;
6
2
2
2
2
use warnings;
7
2
2
2
2
use base qw( Exporter );
8
2
2
2
2
use Data::Dumper;$Data::Dumper::Indent=1;
9our @EXPORT_OK = qw(
10    process_argv
11    read_file
12    write_file
13    qualify_sourcefile
14    replace_pod_item
15    no_both_PARROT_EXPORT_and_PARROT_INLINE
16    validate_prototype_args
17    no_both_static_and_PARROT_EXPORT
18    handle_split_declaration
19    asserts_from_args
20    shim_test
21    handle_modified_args
22    add_asserts_to_declarations
23    add_newline_if_multiline
24    func_modifies
25    add_headerizer_markers
26);
27
28 - 71
=head1 NAME

Parrot::Headerizer::Functions - Functions used in headerizer programs

=head1 SYNOPSIS

    use Parrot::Headerizer::Functions qw(
        print_headerizer_warnings
        read_file
        write_file
        qualify_sourcefile
        asserts_from_args
    );

=head1 DESCRIPTION

This package holds (non-object-oriented) functions used in
F<tools/dev/headerizer.pl>.

=head1 SUBROUTINES

=head2 C<process_argv>

=over 4

=item * Purpose

Validate list of object files provided as arguments.

=item * Arguments

    @ofiles = process_argv(@ARGV);

List of files specified on the command-line.

=item * Return Value

Validated list of object files.

=item * Comment

=back

=cut
72
73sub process_argv {
74
2
2
    my @argv = @_;
75
2
100
    die 'No files specified.' unless @argv;
76
1
    my %ofiles;
77
1
1
    ++$ofiles{$_} for @argv;
78
1
    my @ofiles = sort keys %ofiles;
79
1
    for (@ofiles) {
80
3
100
        print "$_ is specified more than once.\n" if $ofiles{$_} > 1;
81    }
82
1
    return @ofiles;
83}
84
85
86 - 109
=head2 C<read_file()>

=over 4

=item * Purpose

Read a file into a string.

=item * Arguments

String holding name of file to be read.

=item * Return Value

String holding the file's content.

=item * Comment

We can't alias this to C<Parrot::BuildUtil::slurp_file()> because that function
changes DOS line endings to Unix, which we don't necessarily want here.

=back

=cut
110
111
112sub read_file {
113
19
19
    my $filename = shift;
114
115
19
100
    open my $fh, '<', $filename or die "couldn't read '$filename': $!";
116
18
18
18
    my $text = do { local $/ = undef; <$fh> };
117
18
    close $fh;
118
119
18
    return $text;
120}
121
122 - 141
=head2 C<write_file()>

=over 4

=item * Purpose

Write a file.

=item * Arguments

List of two scalars: string holding name of file to be written; text to be
written to the file.

=item * Return Value

Implicitly returns true upon success.

=back

=cut
142
143sub write_file {
144
4
4
    my $filename = shift;
145
4
    my $text = shift;
146
147
4
50
    open my $fh, '>', $filename or die "couldn't write '$filename': $!";
148
4
4
    print {$fh} $text;
149
4
    close $fh;
150}
151
152 - 204
=head2 C<qualify_sourcefile()>

=over 4

=item * Purpose

Given the name of a C object file, derive the name of its C<.c> or C<.pmc>
source code file, verify that file's existence, read in its source code, and
verify the existence of the corresponding C<.h> file.

=item * Arguments

    my ($sourcefile, $source_code, $hfile) =
        qualify_sourcefile( {
            ofile           => $ofile,
            PConfig         => \%PConfig,
            is_yacc         => $is_yacc,
        } );

Reference to hash with 3 key-value pairs:

=over 4

=item * C<ofile>

String holding name of C or yacc object file.

=item * C<PConfig>

Reference to Parrot configuration hash.

=item * C<is_yacc>

Boolean reporting whether the source code file is a yacc file or not.

=back

=item * Return Value

List of 3 scalars: String holding source code file, string holding the ssource
code, string holding header file (or C<none> if no header file is found).

=item * Comment

The subroutine will die if the value provided for C<ofile> does not have a
corresponding C<.c> file or if it is a yacc file.  The subroutine will also
die if it cannot locate an C<HEADERIZER HFILE> directive in the source code
file.  The subroutine will also die if any header file referenced from the
source code cannot be located.

=back

=cut
205
206sub qualify_sourcefile {
207
14
14
    my $args = shift;
208
14
    my $cfile = $args->{ofile};
209
14
100
100
    $cfile =~ s/\Q$args->{PConfig}->{o}\E$/.c/ or $args->{is_yacc}
210        or die "$cfile doesn't look like an object file";
211
212
13
    my $pmcfile = $args->{ofile};
213
13
    $pmcfile =~ s/\Q$args->{PConfig}->{o}\E$/.pmc/;
214
215
13
100
    my $from_pmc = -f $pmcfile && !$args->{is_yacc};
216
217
13
100
    my $sourcefile = $from_pmc ? $pmcfile : $cfile;
218
219
13
    my $source_code = read_file( $sourcefile );
220
13
100
    die qq{can't find HEADERIZER HFILE directive in "$sourcefile"}
221        unless $source_code =~
222            m{ /\* \s+ HEADERIZER\ HFILE: \s+ ([^*]+?) \s+ \*/ }sx;
223
224
12
    my $hfile = $1;
225
12
100
100
    if ( ( $hfile ne 'none' ) && ( not -f $hfile ) ) {
226
1
        die qq{"$hfile" not found (referenced from "$sourcefile")};
227    }
228
229
11
    return ($sourcefile, $source_code, $hfile);
230}
231
232 - 241
=pod

    $text = replace_pod_item( {
        text        => $text,
        name        => $name,
        heading     => $heading,
        cfile_name  => $cfile_name,
    } );

=cut
242
243sub replace_pod_item {
244
34
34
    my $args = shift;
245    $args->{text} =~ s/=item C<[^>]*\b$args->{name}\b[^>]*>\n+/$args->{heading}\n\n/sm
246
34
100
        or do {
247
2
100
            warn "$args->{cfile_name}: $args->{name} has no POD\n"
248                # lexer funcs don't have to have POD
249                unless $args->{name} =~ /^yy/;
250    };
251
34
    return $args->{text};
252}
253
254 - 263
=pod

    no_both_PARROT_EXPORT_and_PARROT_INLINE( {
        file            => $file,
        name            => $name,
        parrot_inline   => $parrot_inline,
        parrot_api      => $parrot_api,
    } );

=cut
264
265sub no_both_PARROT_EXPORT_and_PARROT_INLINE {
266
71
71
    my $args = shift;
267
71
    my $death =
268        "$args->{file} $args->{name}: Can't have both PARROT_EXPORT and PARROT_INLINE";
269
71
100
100
    die $death if $args->{parrot_inline} && $args->{parrot_api};
270
70
    return 1;
271}
272
273 - 277
=pod

    @args = validate_prototype_args( $args, $proto );

=cut
278
279sub validate_prototype_args {
280
71
71
    my ($args, $proto) = @_;
281
71
    my @args = split( /\s*,\s*/, $args );
282
71
    for (@args) {
283
171
100
100
        /\S+\s+\S+/
284            || ( $_ eq '...' )
285            || ( $_ eq 'void' )
286            || ( $_ =~ /(PARROT|NULLOK|SHIM)_INTERP/ )
287            or die "Bad args in $proto";
288    }
289
70
    return @args;
290}
291
292 - 301
=pod

    ($return_type, $is_static) = no_both_static_and_PARROT_EXPORT( {
        file            => $file,
        name            => $name,
        return_type     => $return_type,
        parrot_api      => $parrot_api,
    } );

=cut
302
303sub no_both_static_and_PARROT_EXPORT {
304
72
72
    my $args = shift;
305
72
    my $is_static = 0;
306
72
50
    $is_static = $2 if $args->{return_type} =~ s/^((static)\s+)?//i;
307
72
    my $death = "$args->{file} $args->{name}: Impossible to have both static and PARROT_EXPORT";
308
72
100
100
    die $death if $args->{parrot_api} && $is_static;
309
71
    return ($args->{return_type}, $is_static);
310}
311
312 - 319
=pod

    my $split_decl = handle_split_declaration(
        $function_decl,
        $line_len,
    );

=cut
320
321sub handle_split_declaration {
322
16
16
    my ($function_decl, $line_len) = @_;
323
16
    my @doc_chunks = split /\s+/, $function_decl;
324
16
    my $split_decl = '';
325
16
    my @line;
326
16
    while (@doc_chunks) {
327
134
        my $chunk = shift @doc_chunks;
328
134
100
        if (length(join(' ', @line, $chunk)) <= $line_len) {
329
119
            push @line, $chunk;
330        }
331        else {
332
15
            $split_decl .= join(' ', @line) . "\n";
333
15
            @line=($chunk);
334        }
335    }
336
16
    $split_decl .= join(' ', @line) . "\n";
337
16
    $split_decl =~ s/\n$//;
338
339
16
    return $split_decl;
340}
341
342sub asserts_from_args {
343
14
14
    my @args = @_;
344
14
    my @asserts;
345
346
14
    for my $arg (@args) {
347
38
100
        if ( $arg =~ m{(ARGIN|ARGOUT|ARGMOD|ARGFREE_NOTNULL|NOTNULL)\((.+)\)} ) {
348
21
            my $var = $2;
349
21
100
            if($var =~ /\(*\s*([a-zA-Z_][a-zA-Z0-9_]*)\s*\)\s*\(/) {
350                # argument is a function pointer
351                # Is this branch ever reached?
352
1
                $var = $1;
353            }
354            else {
355                # try to isolate the variable's name;
356                # strip off everything before the final space or asterisk.
357
20
                $var =~ s{.+[* ]([^* ]+)$}{$1};
358                # strip off a trailing "[]", if any.
359
20
                $var =~ s{\[\]$}{};
360            }
361
21
            push( @asserts, "PARROT_ASSERT_ARG($var)" );
362        }
363
38
100
        if( $arg eq 'PARROT_INTERP' ) {
364
5
            push( @asserts, "PARROT_ASSERT_ARG(interp)" );
365        }
366    }
367
368
14
    return (@asserts);
369}
370
371 - 375
=pod

    my @modified_args = shim_test($func, \@args);

=cut
376
377sub shim_test {
378
14
14
    my ($func, $argsref) = @_;
379
14
14
    my @args = @{$argsref};
380
14
    for my $arg (@args) {
381
31
100
        if ( $arg =~ m{SHIM\((.+)\)} ) {
382
3
            $arg = $1;
383
3
100
100
            if ( $func->{is_static} || ( $arg =~ /\*/ ) ) {
384
2
                $arg = "SHIM($arg)";
385            }
386            else {
387
1
                $arg = "NULLOK($arg)";
388            }
389        }
390    }
391
14
    return @args;
392}
393
394sub handle_modified_args {
395
14
14
    my ($decl, $modified_args_ref) = @_;
396
14
14
    my @modified_args = @{ $modified_args_ref };
397
14
    my $multiline = 0;
398
14
    my $argline = join( ", ", @modified_args );
399
14
100
    if ( length( $decl . $argline ) <= 75 ) {
400
6
        $decl = "$decl$argline)";
401    }
402    else {
403
8
100
        if ( $modified_args[0] =~ /^(?:(?:SHIM|PARROT)_INTERP|Interp)\b/ ) {
404
7
            $decl .= ( shift @modified_args );
405
7
100
            $decl .= "," if @modified_args;
406        }
407
8
15
        $argline = join( ",", map { "\n\t$_" } @modified_args );
408
8
        $decl = "$decl$argline)";
409
8
        $multiline = 1;
410    }
411
14
    return ($decl, $multiline);
412}
413
414# $decl .= $multiline ? ";\n" : ";";
415sub add_newline_if_multiline {
416
12
12
    my ($decl, $multiline) = @_;
417
12
100
    $decl .= $multiline ? ";\n" : ";";
418
12
    return $decl;
419}
420
421sub add_asserts_to_declarations {
422
4
4
    my ($funcs_ref, $decls_ref) = @_;
423
4
4
    foreach my $func (@{ $funcs_ref }) {
424
11
        my $assert = "#define ASSERT_ARGS_" . $func->{name};
425
11
100
        if(length($func->{name}) > 29) {
426
1
            $assert .= " \\\n ";
427        }
428
11
        $assert .= " __attribute__unused__ int _ASSERT_ARGS_CHECK = (";
429
430
11
11
        my @asserts = asserts_from_args( @{ $func->{args} } );
431
11
100
        if(@asserts) {
432
9
            $assert .= "\\\n ";
433
9
            $assert .= join(" \\\n , ", @asserts);
434        }
435        else {
436
2
            $assert .= "0";
437        }
438
11
        $assert .= ")";
439
11
11
        push(@{ $decls_ref }, $assert);
440    }
441
4
4
    return @{ $decls_ref };
442}
443
444 - 448
=pod

   @mods = func_modifies($arg, \@mods);

=cut
449
450sub func_modifies {
451
34
34
    my ($arg, $modsref) = @_;
452
34
34
    my @mods = @{$modsref};
453
34
100
    if ( $arg =~ m{ARG(?:MOD|OUT)(?:_NULLOK)?\((.+?)\)} ) {
454
10
        my $modified = $1;
455
10
100
        if ( $modified =~ s/.*\*/*/ ) {
456            # We're OK
457        }
458        else {
459
2
100
            $modified =~ s/.* (\w+)$/$1/ or die qq{Unable to figure out the modified parm out of "$modified"};
460        }
461
9
        push( @mods, "FUNC_MODIFIES($modified)" );
462    }
463
33
    return @mods;
464}
465 - 474
=pod

    return add_headerizer_markers( {
        function_decls  => \@function_decls,
        sourcefile      => $sourcefile,
        hfile           => $hfile,
        code            => $source_code,
    } );

=cut
475
476sub add_headerizer_markers {
477
3
3
    my $args = shift;
478
479
3
3
    my $function_decls = join( "\n" => @{ $args->{function_decls} });
480
3
    my $STARTMARKER = qr{/\* HEADERIZER BEGIN: $args->{sourcefile} \*/\n};
481
3
    my $ENDMARKER = qr{/\* HEADERIZER END: $args->{sourcefile} \*/\n?};
482
3
    my $DO_NOT_TOUCH = q{/* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */};
483
484
3
50
    $args->{code} =~
485        s{($STARTMARKER)(?:.*?)($ENDMARKER)}
486         {$1$DO_NOT_TOUCH\n\n$function_decls\n$DO_NOT_TOUCH\n$2}s
487        or die "Need begin/end HEADERIZER markers for $args->{sourcefile} in $args->{hfile}\n";
488
489
3
    return $args->{code};
490}
491
4921;
493
494# Local Variables:
495# mode: cperl
496# cperl-indent-level: 4
497# fill-column: 100
498# End:
499# vim: expandtab shiftwidth=4: