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


line stmt bran cond sub pod time code
1             package Inline::Awk;
2              
3              
4             ###############################################################################
5             #
6             # Inline::Awk - Add awk code to your Perl programs.
7             #
8             # John McNamara, jmcnamara@cpan.org
9             #
10             # Documentation after __END__
11             #
12              
13              
14 1     1   588 use strict;
  1         2  
  1         23  
15 1     1   3 use Carp;
  1         1  
  1         60  
16             require Inline;
17              
18              
19 1     1   3 use vars qw($VERSION @ISA);
  1         3  
  1         640  
20             @ISA = qw(Inline);
21             $VERSION = '0.04';
22              
23              
24             ###############################################################################
25             #
26             # register(). This function is required by Inline See the Inline-API pod.
27             #
28             sub register {
29             return {
30 0     0 0   language => 'Awk',
31             aliases => ['AWK', 'awk'],
32             type => 'interpreted',
33             suffix => 'pl',
34             };
35             }
36              
37              
38             ###############################################################################
39             #
40             # build(). This function is required by Inline See the Inline-API pod.
41             #
42             # Unlike other inline modules we don't interface with a compiler or
43             # interpreter. Instead we translate the awk code into Perl code using a2p and
44             # eval it into the user's program.
45             #
46             # The main body of the awk code is wrapped in a sub called awk() that the user
47             # can call. It accepts arguments and localised them into @ARGV.
48             #
49             # Any functions are stripped out and given there own copy of the global
50             # variables created by a2p. This allows the user to write functions and then
51             # call them from Perl.
52             #
53             # The code is derived from Foo.pm. The majority of the smoke and mirrors is
54             # handled by Inline.
55             #
56             sub build {
57              
58 0     0 0   my $self = shift;
59              
60              
61             # Set up the path and object names.
62 0           my $awk_obj;
63 0           my $path = $self->{API}{install_lib} .'/auto/' .$self->{API}{modpname};
64 0           my $obj = $self->{API}{location};
65 0           ($awk_obj = $obj) =~ s|$self->{API}{suffix}$|awk|;
66              
67              
68             # Create the build directory if necessary.
69 0 0         $self->mkpath($path) unless -d $path;
70              
71              
72             # Get the awk code.
73 0           my $awk_code = $self->{API}{code};
74              
75              
76             # In awk a standalone END block implies a default PATTERN block.
77             # This behaviour isn't replicated by a2p. Therefore, if the awk code
78             # includes an END block we append an empty PATTERN block to force a2p
79             # to generate the required while loop.
80             #
81 0 0         $awk_code .= "\n{}\n" if $awk_code =~ m[END(\s*)?{];
82              
83              
84             # Create the awk "object" file. In this case it is just a source file.
85 0 0         open OBJ, "> $awk_obj" or croak "Can't open $awk_obj for output: $!\n";
86 0           print OBJ $awk_code;
87 0           close OBJ;
88              
89              
90             # Run the awk code through a2p to generate the Perl code.
91             #
92 0           my @code = `a2p $awk_obj`;
93 0           chomp(@code);
94              
95              
96             # Remove the shebang lines and the switch processing
97 0           splice(@code, 0, 9);
98              
99              
100             # Add code for processing args other than @ARGV and add a modified switch
101             # processor to take account of the fact that the code is being called from
102             # within a sub.
103             #
104 0           my @main = ( 'local @ARGV = @_ if @_;',
105             '',
106             '# process any FOO=bar switches',
107             'if (@ARGV) {',
108             ' eval "\$$1$2;" while $ARGV[0] =~ /^(\w+=)(.*)/ '.
109             '&& shift @ARGV;',
110             '}',
111             ''
112             );
113              
114              
115             # The following code is a workaround for the fact that a2p sometimes chomps
116             # lines without setting $\ for subsequent print statements.
117             #
118 0 0         push @main, '$\ = "\n";' if grep { /\s+chomp;/ } @code;
  0            
119              
120              
121             # Store global assignments for use in any subroutines. Variables can be
122             # declared more than once so we use a hash to store the last declaration
123             # only. We also deal with chained assignments such as $\ = $/ = "\n";.
124             #
125 0           my $globals;
126             my %globals;
127              
128 0           foreach (@code) {
129 0 0         last if /while \(/; # Bail at first while
130 0 0         last if /^sub /; # or bail at first sub
131 0 0         next unless /^(\$\S+)\s=\s/; # Match assignment
132              
133             # Extract chained assignments
134 0           my $line = $_;
135 0           my @vars;
136 0           push @vars, $1 while $line =~ s|^(\$\S+)\s=\s||;
137              
138             # Strip trailing comments, crudely
139 0           $line =~ s|;\s+#.*|;|;
140              
141             # Literal value remains in $line
142 0           foreach my $var (@vars) {
143 0           $globals{$var} = " $var = $line\n";
144             }
145             }
146              
147              
148             # Format the globals for printing
149 0           $globals = "\n". join '', values %globals;
150              
151              
152             # Separate the main code from the subs.
153 0           while (@code) {
154 0 0         last if $code[0] =~ /^sub \w+ \{$/;
155 0           push @main, shift @code;
156             }
157              
158              
159             # Add the global variable to any subroutines
160 0           foreach (@code) {
161 0           s/(^sub .*)/$1$globals/;
162             }
163              
164              
165             # Enclose the program main in a subroutine and prettify the code in case
166             # anyone looks at it. Well...you're looking at this. ;-)
167             #
168             # Text::Tabs is probably overkill for the tab expansion.
169             #
170 0           for (@main) { # Indent code 4 spaces.
171 0 0         $_ = " $_" unless $_ eq '';
172             }
173              
174 0           s[\t][' ' x 8]eg for @code; # Expand tabs.
  0            
175 0           s[\t][' ' x 8]eg for @main; # Expand tabs.
  0            
176 0 0         pop @main if $main[-1] eq ''; # Remove trailing blank line.
177 0           unshift @main, "sub awk {"; # Add the function header.
178 0           push @main, "}\n"; # Add the function tail.
179              
180              
181             # Join the main and subs into a single source.
182 0           my $perl_code = join "\n", @main, @code, "\n";
183              
184              
185             # Write the Perl code to the "object" file.
186 0 0         open OBJ, "> $obj" or croak "Can't open $obj for output: $!\n";
187 0           print OBJ $perl_code;
188 0           close OBJ;
189             }
190              
191              
192             ###############################################################################
193             #
194             # load(). This function is required by Inline See the Inline-API pod.
195             #
196             # This function reloads the Perl code created by build() and evals it into the
197             # user's program. Nice.
198             #
199             sub load {
200              
201 0     0 0   my $self = shift;
202 0           my $obj = $self->{API}{location};
203              
204             # Re-read the converted Perl source code
205 0 0         open OBJ, "$obj" or croak "Can't open $obj for reading $!";
206              
207             # Slurp Perl code
208 0           my $code = do {local $/; };
  0            
  0            
209              
210 0           close OBJ;
211              
212             # Stop strict "vars" and "subs" propagating to the eval
213 1     1   4 no strict;
  1         1  
  1         85  
214 0           eval "package $self->{API}{pkg};\n$code";
215 0 0         croak "Problems compiling Perl code $obj: $@\n" if $@;
216             }
217              
218              
219             ###############################################################################
220             #
221             # validate(). This function is required by Inline See the Inline-API pod.
222             #
223             sub validate {
224              
225 0     0 0   my $self = shift;
226             # Place holder
227             }
228              
229              
230             ###############################################################################
231             #
232             # info(). This function is required by Inline See the Inline-API pod.
233             #
234             sub info {
235              
236 0     0 1   my $self = shift;
237             # Place holder
238             }
239              
240              
241             1;
242              
243              
244             __END__