File Coverage

Awk.pm

Criterion	Covered	Total	%
statement	12	71	16.9
branch	0	26	0.0
condition			n/a
subroutine	4	9	44.4
pod	1	5	20.0
total	17	111	15.3

package Inline::Awk;


###############################################################################
#
# Inline::Awk - Add awk code to your Perl programs.
#
# John McNamara, [e-mail]
#
# Documentation after __END__
#


use strict;
use Carp;
require Inline;


use vars qw($VERSION @ISA);
@ISA = qw(Inline);
$VERSION = '0.04';


###############################################################################
#
# register(). This function is required by Inline See the Inline-API pod.
#
sub register {
    return {
                language => 'Awk',
                aliases  => ['AWK', 'awk'],
                type     => 'interpreted',
                suffix   => 'pl',
           };
}


###############################################################################
#
# build(). This function is required by Inline See the Inline-API pod.
#
# Unlike other inline modules we don't interface with a compiler or
# interpreter. Instead we translate the awk code into Perl code using a2p and
# eval it into the user's program.
#
# The main body of the awk code is wrapped in a sub called awk() that the user
# can call. It accepts arguments and localised them into @ARGV.
#
# Any functions are stripped out and given there own copy of the global
# variables created by a2p. This allows the user to write functions and then
# call them from Perl.
#
# The code is derived from Foo.pm. The majority of the smoke and mirrors is
# handled by Inline.
#
sub build {

    my $self    = shift;


    # Set up the path and object names.
    my $awk_obj;
    my $path    = $self->{API}{install_lib} .'/auto/' .$self->{API}{modpname};
    my $obj     = $self->{API}{location};
    ($awk_obj   = $obj) =~ s|$self->{API}{suffix}$|awk|;


    # Create the build directory if necessary.
    $self->mkpath($path) unless -d $path;


    # Get the awk code.
    my $awk_code = $self->{API}{code};


    # In awk a standalone END block implies a default PATTERN block.
    # This behaviour isn't replicated by a2p. Therefore, if the awk code
    # includes an END block we append an empty PATTERN block to force a2p
    # to generate the required while loop.
    #
    $awk_code .= "\n{}\n" if $awk_code =~ m[END(\s*)?{];


    # Create the awk "object" file. In this case it is just a source file.
    open  OBJ, "> $awk_obj" or croak "Can't open $awk_obj for output: $!\n";
    print OBJ  $awk_code;
    close OBJ;


    # Run the awk code through a2p to generate the Perl code.
    #
    my @code = `a2p $awk_obj`;
    chomp(@code);


    # Remove the shebang lines and the switch processing
    splice(@code, 0, 9);


    # Add code for processing args other than @ARGV and add a modified switch
    # processor to take account of the fact that the code is being called from
    # within a sub.
    #
    my @main = ( 'local @ARGV = @_ if @_;',
                 '',
                 '# process any FOO=bar switches',
                 'if (@ARGV) {',
                 '    eval "\$$1$2;" while $ARGV[0] =~ /^(\w+=)(.*)/ '.
                                                       '&& shift @ARGV;',
                 '}',
                 ''
               );


    # The following code is a workaround for the fact that a2p sometimes chomps
    # lines without setting $\ for subsequent print statements.
    #
    push @main, '$\ = "\n";' if grep { /\s+chomp;/ } @code;


    # Store global assignments for use in any subroutines. Variables can be
    # declared more than once so we use a hash to store the last declaration
    # only. We also deal with chained assignments such as $\ = $/ = "\n";.
    #
    my $globals;
    my %globals;

    foreach (@code) {
        last if /while \(/;             # Bail at first while
        last if /^sub /;                # or bail at first sub
        next unless /^(\$\S+)\s=\s/;    # Match assignment

        # Extract chained assignments
        my $line = $_;
        my @vars;
        push @vars, $1 while $line =~ s|^(\$\S+)\s=\s||;

        # Strip trailing comments, crudely
        $line =~ s|;\s+#.*|;|;

        # Literal value remains in $line
        foreach my $var (@vars) {
            $globals{$var} = "    $var = $line\n";
        }
    }


    # Format the globals for printing
    $globals = "\n". join '', values %globals;


    # Separate the main code from the subs.
    while (@code) {
        last if $code[0] =~ /^sub \w+ \{$/;
        push @main, shift @code;
    }


    # Add the global variable to any subroutines
    foreach (@code) {
        s/(^sub .*)/$1$globals/;
    }


    # Enclose the program main in a subroutine and prettify the code in case
    # anyone looks at it. Well...you're looking at this. ;-)
    #
    # Text::Tabs is probably overkill for the tab expansion.
    #
    for (@main) {                       # Indent code 4 spaces.
        $_ = "    $_" unless $_ eq '';
    }

    s[\t][' ' x 8]eg for @code;         # Expand tabs.
    s[\t][' ' x 8]eg for @main;         # Expand tabs.
    pop @main if $main[-1] eq '';       # Remove trailing blank line.
    unshift @main, "sub awk {";         # Add the function header.
    push @main, "}\n";                  # Add the function tail.


    # Join the main and subs into a single source.
    my $perl_code = join "\n", @main, @code, "\n";


    # Write the Perl code to the "object" file.
    open  OBJ, "> $obj" or croak "Can't open $obj for output: $!\n";
    print OBJ  $perl_code;
    close OBJ;
}


###############################################################################
#
# load(). This function is required by Inline See the Inline-API pod.
#
# This function reloads the Perl code created by build() and evals it into the
# user's program. Nice.
#
sub load {

    my $self    = shift;
    my $obj     = $self->{API}{location};

    # Re-read the converted Perl source code
    open OBJ, "$obj" or croak "Can't open $obj for reading $!";

    # Slurp Perl code
    my $code = do {local $/; };

    close OBJ;

    # Stop strict "vars" and "subs" propagating to the eval
    no strict;
    eval  "package $self->{API}{pkg};\n$code";
    croak "Problems compiling Perl code $obj: $@\n" if $@;
}


###############################################################################
#
# validate(). This function is required by Inline See the Inline-API pod.
#
sub validate {

    my $self = shift;
    # Place holder
}


###############################################################################
#
# info(). This function is required by Inline See the Inline-API pod.
#
sub info {

    my $self = shift;
    # Place holder
}


1;


__END__