File Coverage

blib/lib/Module/Install/DSL.pm
Criterion Covered Total %
statement 33 51 64.7
branch 6 12 50.0
condition 2 3 66.6
subroutine 4 5 80.0
pod 0 1 0.0
total 45 72 62.5


line stmt bran cond sub pod time code
1             package Module::Install::DSL;
2              
3 2     2   1129 use strict;
  2         4  
  2         57  
4 2     2   9 use vars qw{$VERSION $ISCORE};
  2         3  
  2         125  
5             BEGIN {
6 2     2   6 $VERSION = '1.19';
7 2         4 $ISCORE = 1;
8 2         4 *inc::Module::Install::DSL::VERSION = *VERSION;
9 2         1055 @inc::Module::Install::DSL::ISA = __PACKAGE__;
10             }
11              
12             sub import {
13             # Read in the rest of the Makefile.PL
14 0 0   0   0 open 0 or die "Couldn't open $0: $!";
15 0         0 my $dsl;
16             SCOPE: {
17 0         0 local $/ = undef;
  0         0  
18 0         0 $dsl = join "", <0>;
19             }
20              
21             # Change inc::Module::Install::DSL to the regular one.
22             # Remove anything before the use inc::... line.
23 0         0 $dsl =~ s/.*?^\s*use\s+(?:inc::)?Module::Install::DSL(\b[^;]*);\s*\n//sm;
24              
25             # Load inc::Module::Install as we would in a regular Makefile.Pl
26             SCOPE: {
27 0         0 package main;
28 0         0 require inc::Module::Install;
29 0         0 inc::Module::Install->import;
30             }
31              
32             # Add the ::DSL plugin to the list of packages in /inc
33 0         0 my $admin = $Module::Install::MAIN->{admin};
34 0 0       0 if ( $admin ) {
35 0         0 my $from = $INC{"$admin->{path}/DSL.pm"};
36 0         0 my $to = "$admin->{base}/$admin->{prefix}/$admin->{path}/DSL.pm";
37 0         0 $admin->copy( $from => $to );
38             }
39              
40             # Convert the basic syntax to code
41 0         0 my $code = "{\n"
42             . "package main;\n\n"
43             . dsl2code($dsl)
44             . "\n\nWriteAll();\n"
45             . "}\n";
46              
47             # Execute the script
48 0         0 eval $code;
49 0 0       0 print STDERR "Failed to execute the generated code...\n$@" if $@;
50              
51 0         0 exit(0);
52             }
53              
54             sub dsl2code {
55 2     2 0 918 my $dsl = shift;
56              
57             # Split into lines and strip blanks
58 2         14 my @lines = grep { /\S/ } split /[\012\015]+/, $dsl;
  12         26  
59              
60             # Each line represents one command
61 2         4 my @code = ();
62 2         3 my $static = 1;
63 2         3 foreach my $line ( @lines ) {
64             # Split the lines into tokens
65 12         34 my @tokens = split /\s+/, $line;
66              
67             # The first word is the command
68 12         14 my $command = shift @tokens;
69 12         14 my @params = ();
70 12         12 my @suffix = ();
71 12         21 while ( @tokens ) {
72 15         19 my $token = shift @tokens;
73 15 100 66     39 if ( $token eq 'if' or $token eq 'unless' ) {
74             # This is the beginning of a suffix
75 1         2 push @suffix, $token;
76 1         2 push @suffix, @tokens;
77              
78             # The conditional means this distribution
79             # can no longer be considered fully static.
80 1         1 $static = 0;
81 1         2 last;
82             } else {
83             # Convert to a string
84 14         19 $token =~ s/([\\\'])/\\$1/g;
85 14         30 push @params, "'$token'";
86             }
87             };
88              
89             # Merge to create the final line of code
90 12 100       27 @tokens = ( $command, @params ? join( ', ', @params ) : (), @suffix );
91 12         30 push @code, join( ' ', @tokens ) . ";\n";
92             }
93              
94             # Is our configuration static?
95 2 100       4 push @code, "static_config;\n" if $static;
96              
97             # Join into the complete code block
98 2         10 return join( '', @code );
99             }
100              
101             1;