File Coverage

blib/lib/Module/MakefilePL/Parse.pm

Criterion	Covered	Total	%
statement	89	101	88.1
branch	38	56	67.8
condition			n/a
subroutine	11	11	100.0
pod	3	3	100.0
total	141	171	82.4

package Module::MakefilePL::Parse;

use 5.006001;
use strict;
use warnings::register __PACKAGE__;

require Exporter;
use Carp;
use Text::Balanced qw( extract_bracketed );

use enum qw(TYPE_MAKEMAKER=1 TYPE_MODULEINSTALL TYPE_MODULEBUILD);

our @ISA = qw(Exporter);

our %EXPORT_TAGS = ( 'all' => [ qw( ) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw( );

our $VERSION = '0.12';

our $DEBUG  = 0;

sub new {
  my $class  = shift;

  my $script = shift;

  $script =~ s/\#.*\n/\n/g;             # remove comments (not greedy?)
  $script =~ s/\s\s+/ /g;               # normalize spaces

  my $self = {
    SCRIPT    => $script,
    INSTALLER => undef,
  };

  if ($script =~ /use\s+ExtUtils::MakeMaker/) {
    $self->{INSTALLER} = TYPE_MAKEMAKER;
  }
  elsif ($script =~ /use\s+(inc::)?Module::Install/) {
    $self->{INSTALLER} = TYPE_MODULEINSTALL;
  }
  else {
    croak "Only scripts which use ExtUtils::MakeMaker or Module::Install are supported";
  }
  bless $self, $class;

  $self->{REQUIRED} = $self->_parse;
  unless ($self->required) {
    return;
  }

  return $self;
}

sub required {
  my $self = shift;
  if (ref($self->{REQUIRED}) ne 'HASH') {
    return;
  }
  else {
    return $self->{REQUIRED};
  }
}

# Cleanup module names (if surrounded by quotes, etc.) and make sure
# version is a number.

sub _cleanup {
  my $hashref = shift;
  if (ref($hashref) eq 'HASH') {
    foreach my $module (keys %$hashref) {
      my $version = ($hashref->{$module} += 0); # change to number
      if ($module =~ /[\'\"](.+)[\'\"]/) {
	$hashref->{$1} = $version;
	delete $hashref->{$module};
      }
    }
    return $hashref;
  } else {
# TODO: carp "Expected HASH reference", if (warnings::enabled);
    return;
  }
}

sub _parse {
  my $self = shift;

  my $script = $self->{SCRIPT};

  # Look for first call to WriteMakefile function. Key should be there.

  if ($self->{INSTALLER} == TYPE_MAKEMAKER) {

    my $key_start = index $script, 'WriteMakefile';
    if ($key_start < 0) {
      carp "Error: cannot find call to WriteMakefile",
	if (warnings::enabled);
      return;
    }

    $key_start = index $script, 'PREREQ_PM', $key_start;
    if ($key_start < 0) {
      # if no PREREQ_PM, we assume that there are no prereqs
      return { };
    } else {

      my $block_start = index $script, '{', $key_start;
      if ($block_start < $key_start) {
	carp "Error: cannot find left bracket after PREREQ_PM",
	  if (warnings::enabled);
	return;
      }

      # check that operator between PREREQ_PM and hash reference is valid
      {
	my $op = substr($script, $key_start, $block_start-$key_start);
	unless ($op =~ /^[\'\"]?PREREQ_PM[\'\"]?\s*(=>|\,)\s*$/) {
	  carp "Error: unexpected syntax found", if (warnings::enabled);
	  return;
	}
      }

      my $prereq_pm = extract_bracketed(substr($script, $block_start), '{}' );
      unless ($prereq_pm) {
	carp "Error: unable to extract prerequisites: no balanced brackets",
	  if (warnings::enabled);
	return;
      }

      # Surround bareword module names with quotes so that eval works
      # properly. This regex will not work for code that is specified
      # as "{qw( module 0 )}"

      $prereq_pm =~ s/([\,\s\{])(\w+)(::\w+)+\s*(=>|\,|\'?\d)/$1 '$2$3' $4/g;

      $self->{_PREREQ_PM} = $prereq_pm;

      if ($prereq_pm =~ /[\&\$\@\%\*]/) {
	carp "Warning: possible variable references",
	  if (warnings::enabled);
      }

      my $hashref;
      eval "\$hashref = $prereq_pm;";
      return _cleanup($hashref);
    }
  }
  elsif ($self->{INSTALLER} == TYPE_MODULEBUILD) {
    croak "Unsupported type";
    return;
  }
  elsif ($self->{INSTALLER} == TYPE_MODULEINSTALL) {

    my $hashref    = { };

    my $index      = 0;
    while (($index = index($script, 'requires', $index)) >= 0) {
      my $reqstr;
      my $start    = index($script, '(', $index+1);
      if ($start   > $index) {
	$reqstr = extract_bracketed(substr($script, $start), '()' );
	if ($reqstr) {
	  my ($module, $comma, $version) =
	    split /(,|=>)/, substr($reqstr,1,-1);

	  $hashref->{eval $module} =
	    ((defined $version) ? (eval $version) : 0);
	}
	else {
	  return;
	}
      }
      else {
	return;
      }
      $index   = $index+1;
    }

    return _cleanup($hashref);
  }
  else {
    croak "Unsupported type";
    return;
  }
}

sub install_type {
  my $self = shift;
  if (@_) {
    carp "Exra arguments ignored",
      if (warnings::enabled);
  }
  if ($self->{INSTALLER} == TYPE_MAKEMAKER) {
    return 'ExtUtils::MakeMaker';
  } elsif ($self->{INSTALLER} == TYPE_MODULEINSTALL) {
    return 'Module::Install';
  } elsif ($self->{INSTALLER} == TYPE_MODULEBUILD) {
    return 'Module::Build';
  } else {
    return;
  }
}


1;
__END__