local-lib5/lib/perl5/Module/Install/DSL.pm

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