File Coverage

/root/.cpan/build/Inline-0.54_02-wb8_n3/blib/lib/Inline.pm

Criterion	Covered	Total	%
statement	148	320	46.2
branch	53	190	27.8
condition	16	71	22.5
subroutine	25	33	75.7
pod	3	17	17.6
total	245	631	38.8

package Inline;

use strict;
require 5.006;
$Inline::VERSION = '0.54_02';
$Inline::VERSION = eval $Inline::VERSION;

use AutoLoader 'AUTOLOAD';
use Inline::denter;
use Config;
use Carp;
use Cwd qw(abs_path cwd);
use File::Spec;
use File::Spec::Unix;
use Fcntl qw(LOCK_EX LOCK_UN);

my %CONFIG = ();
my @DATA_OBJS = ();
my $INIT = 0;
my $version_requested = 0;
my $version_printed = 0;
my $untaint = 0;
my $safemode = 0;
$Inline::languages = undef; #needs to be global for AutoLoaded error messages

our $did = '_Inline'; # Default Inline Directory

# This is the config file written by create_config_file().
our $configuration_file = 'config-' . $Config::Config{'archname'} . '-' . $];

my %shortcuts =
  (
   NOCLEAN =>      [CLEAN_AFTER_BUILD => 0],
   CLEAN =>        [CLEAN_BUILD_AREA => 1],
   FORCE =>        [FORCE_BUILD => 1],
   INFO =>         [PRINT_INFO => 1],
   VERSION =>      [PRINT_VERSION => 1],
   REPORTBUG =>    [REPORTBUG => 1],
   UNTAINT =>      [UNTAINT => 1],
   SAFE =>         [SAFEMODE => 1],
   UNSAFE =>       [SAFEMODE => 0],
   GLOBAL =>       [GLOBAL_LOAD => 1],
   NOISY =>        [BUILD_NOISY => 1],
   TIMERS =>       [BUILD_TIMERS => 1],
   NOWARN =>       [WARNINGS => 0],
   _INSTALL_ =>    [_INSTALL_ => 1],
   SITE_INSTALL => undef,  # No longer supported.
  );

my $default_config =
  {
   NAME => '',
   AUTONAME => -1,
   VERSION => '',
   DIRECTORY => '',
   WITH => [],
   USING => [],

   CLEAN_AFTER_BUILD => 1,
   CLEAN_BUILD_AREA => 0,
   FORCE_BUILD => 0,
   PRINT_INFO => 0,
   PRINT_VERSION => 0,
   REPORTBUG => 0,
   UNTAINT => 0,
   NO_UNTAINT_WARN => 0,
   REWRITE_CONFIG_FILE => 0,
   SAFEMODE => -1,
   GLOBAL_LOAD => 0,
   BUILD_NOISY => 0,
   BUILD_TIMERS => 0,
   WARNINGS => 1,
   _INSTALL_ => 0,
   _TESTING => 0,
  };

sub UNTAINT {$untaint}
sub SAFEMODE {$safemode}

#==============================================================================
# This is where everything starts.
#==============================================================================
sub import {
    local ($/, $") = ("\n", ' '); local ($\, $,);

    my $o;
    my ($pkg, $script) = caller;
    # Not sure what this is for. Let's see what breaks.
    # $pkg =~ s/^.*[\/\\]//;
    my $class = shift;
    if ($class ne 'Inline') {
	croak M01_usage_use($class) if $class =~ /^Inline::/;
	croak M02_usage();
    }

    $CONFIG{$pkg}{template} ||= $default_config;

    return unless @_;
    &create_config_file(), return 1 if $_[0] eq '_CONFIG_';
    goto &maker_utils if $_[0] =~ /^(install|makedist|makeppd)$/i;

    my $control = shift;

    if ($control eq 'with') {
	return handle_with($pkg, @_);
    }
    elsif ($control eq 'Config') {
	return handle_global_config($pkg, @_);
    }
    elsif (exists $shortcuts{uc($control)}) {
	handle_shortcuts($pkg, $control, @_);
	$version_requested = $CONFIG{$pkg}{template}{PRINT_VERSION};
	return;
    }
    elsif ($control =~ /^\S+$/ and $control !~ /\n/) {
	my $language_id = $control;
	my $option = shift || '';
	my @config = @_;
	my $next = 0;
	for (@config) {
	    next if $next++ % 2;
	    croak M02_usage() if /[\s\n]/;
	}
	$o = bless {}, $class;
	$o->{INLINE}{version} = $Inline::VERSION;
	$o->{API}{pkg} = $pkg;
	$o->{API}{script} = $script;
	$o->{API}{language_id} = $language_id;
	if ($option =~ /^(FILE|BELOW)$/ or
	    not $option and
            defined $INC{File::Spec::Unix->catfile('Inline','Files.pm')} and
	    Inline::Files::get_filename($pkg)
	   ) {
	    $o->read_inline_file;
	    $o->{CONFIG} = handle_language_config(@config);
	}
	elsif ($option eq 'DATA' or not $option) {
	    $o->{CONFIG} = handle_language_config(@config);
	    push @DATA_OBJS, $o;
	    return;
	}
	elsif ($option eq 'Config') {
	    $CONFIG{$pkg}{$language_id} = handle_language_config(@config);
	    return;
	}
	else {
	    $o->receive_code($option);
	    $o->{CONFIG} = handle_language_config(@config);
	}
    }
    else {
	croak M02_usage();
    }
    $o->glue;
}

#==============================================================================
# Run time version of import (public method)
#==============================================================================
sub bind {
    local ($/, $") = ("\n", ' '); local ($\, $,);

    my ($code, @config);
    my $o;
    my ($pkg, $script) = caller;
    my $class = shift;
    croak M03_usage_bind() unless $class eq 'Inline';

    $CONFIG{$pkg}{template} ||= $default_config;

    my $language_id = shift or croak M03_usage_bind();
    croak M03_usage_bind()
      unless ($language_id =~ /^\S+$/ and $language_id !~ /\n/);
    $code = shift or croak M03_usage_bind();
    @config = @_;

    my $next = 0;
    for (@config) {
	next if $next++ % 2;
	croak M03_usage_bind() if /[\s\n]/;
    }
    $o = bless {}, $class;
    $o->{INLINE}{version} = $Inline::VERSION;
    $o->{API}{pkg} = $pkg;
    $o->{API}{script} = $script;
    $o->{API}{language_id} = $language_id;
    $o->receive_code($code);
    $o->{CONFIG} = handle_language_config(@config);

    $o->glue;
}

#==============================================================================
# Process delayed objects that don't have source code yet.
#==============================================================================
# This code is an ugly hack because of the fact that you can't use an
# INIT block at "run-time proper". So we kill the warning and tell users
# to use an Inline->init() call if they run into problems. (rare)

eval <
no warnings;
\$INIT = \$INIT; # Needed by Sarathy's patch.
sub INIT {
    \$INIT++;
    &init;
}
END

sub init {
    local ($/, $") = ("\n", ' '); local ($\, $,);

    while (my $o = shift(@DATA_OBJS)) {
	$o->read_DATA;
	$o->glue;
    }
}

sub END {
    warn M51_unused_DATA() if @DATA_OBJS;
    print_version() if $version_requested && not $version_printed;
}

#==============================================================================
# Print a small report about the version of Inline
#==============================================================================
sub print_version {
    return if $version_printed++;
    print STDERR <

    You are using Inline.pm version $Inline::VERSION

END
}

#==============================================================================
# Compile the source if needed and then dynaload the object
#==============================================================================
sub glue {
    my $o = shift;
    my ($pkg, $language_id) = @{$o->{API}}{qw(pkg language_id)};
    my @config = (%{$CONFIG{$pkg}{template}},
		  %{$CONFIG{$pkg}{$language_id} || {}},
		  %{$o->{CONFIG} || {}},
		 );
    @config = $o->check_config(@config);
    $o->fold_options;

    $o->check_installed;
    $o->env_untaint if UNTAINT;
    if (not $o->{INLINE}{object_ready}) {
	$o->check_config_file;                # Final DIRECTORY set here.
	push @config, $o->with_configs;
	my $language = $o->{API}{language};
	croak M04_error_nocode($language_id) unless $o->{API}{code};
	$o->check_module;
    }
    $o->env_untaint if UNTAINT;
    $o->obj_untaint if UNTAINT;
    print_version() if $version_requested;
    $o->reportbug() if $o->{CONFIG}{REPORTBUG};
    if (not $o->{INLINE}{object_ready}
	or $o->{CONFIG}{PRINT_INFO}
       ) {
	eval "require $o->{INLINE}{ILSM_module}";
	croak M05_error_eval('glue', $@) if $@;
        $o->push_overrides;
	bless $o, $o->{INLINE}{ILSM_module};
	$o->validate(@config);
    }
    else {
	$o->{CONFIG} = {(%{$o->{CONFIG}}, @config)};
    }
    $o->print_info if $o->{CONFIG}{PRINT_INFO};
    unless ($o->{INLINE}{object_ready} or
	    not length $o->{INLINE}{ILSM_suffix}) {
	$o->build();
	$o->write_inl_file() unless $o->{CONFIG}{_INSTALL_};
    }
    if ($o->{INLINE}{ILSM_suffix} ne 'so' and
	$o->{INLINE}{ILSM_suffix} ne 'dll' and
	$o->{INLINE}{ILSM_suffix} ne 'bundle' and
	$o->{INLINE}{ILSM_suffix} ne 'sl' and
	ref($o) eq 'Inline'
       ) {
	eval "require $o->{INLINE}{ILSM_module}";
	croak M05_error_eval('glue', $@) if $@;
        $o->push_overrides;
	bless $o, $o->{INLINE}{ILSM_module};
	$o->validate(@config);
    }
    $o->load;
    $o->pop_overrides;
}

#==============================================================================
# Set up the USING overrides
#==============================================================================
sub push_overrides {
    my ($o) = @_;
    my ($language_id) = $o->{API}{language_id};
    my ($ilsm) = $o->{INLINE}{ILSM_module};
    for (@{$o->{CONFIG}{USING}}) {
        my $using_module = /^::/
                           ? "Inline::$language_id$_"
                           : /::/
                             ? $_
                             : "Inline::${language_id}::$_";
        eval "require $using_module";
        croak "Invalid module '$using_module' in USING list:\n$@" if $@;
        my $register;
        eval "\$register = $using_module->register";
        croak "Invalid module '$using_module' in USING list:\n$@" if $@;
        for my $override (@{$register->{overrides}}) {
            no strict 'refs';
            next if defined $o->{OVERRIDDEN}{$ilsm . "::$override"};
            $o->{OVERRIDDEN}{$ilsm . "::$override"} =
              \&{$ilsm . "::$override"};
            {
            no warnings 'redefine';
            *{$ilsm . "::$override"} =
              \&{$using_module . "::$override"};
            }
        }
    }
}

#==============================================================================
# Restore the modules original methods
#==============================================================================
sub pop_overrides {
    my $nowarn = $] >= 5.006 ? "no warnings 'redefine';" : '';
    eval ($nowarn .
    'my ($o) = @_;
    for my $override (keys %{$o->{OVERRIDDEN}}) {
        no strict "refs";
        *{$override} = $o->{OVERRIDDEN}{$override};
    }
    delete $o->{OVERRIDDEN};')
}

#==============================================================================
# Get source from the DATA filehandle
#==============================================================================
my (%DATA, %DATA_read);
sub read_DATA {
    require Socket;
    my ($marker, $marker_tag);
    my $o = shift;
    my ($pkg, $language_id) = @{$o->{API}}{qw(pkg language_id)};
    unless ($DATA_read{$pkg}++) {
	no strict 'refs';
	*Inline::DATA = *{$pkg . '::DATA'};
	local ($/);
	my ($CR, $LF) = (&Socket::CR, &Socket::LF);
	(my $data = ) =~ s/$CR?$LF/\n/g;
	@{$DATA{$pkg}} = split /(?m)^[ \t]{0,}(__\S+?__\n)/, $data;
	shift @{$DATA{$pkg}} unless ($ {$DATA{$pkg}}[0] || '') =~ /__\S+?__\n/;
    }
    ($marker, $o->{API}{code}) = splice @{$DATA{$pkg}}, 0, 2;
    croak M08_no_DATA_source_code($language_id)
      unless defined $marker;
    ($marker_tag = $marker) =~ s/__(\S+?)__\n/$1/;
    croak M09_marker_mismatch($marker, $language_id)
      unless $marker_tag eq $language_id;
}

#==============================================================================
# Validate and store the non language-specific config options
#==============================================================================
sub check_config {
    my $o = shift;
    my @others;
    while (@_) {
	my ($key, $value) = (shift, shift);
	if (defined $default_config->{$key}) {
	    if ($key =~ /^(WITH|USING)$/) {
		croak M10_usage_WITH_USING()
                  if (ref $value and ref $value ne 'ARRAY');
		$value = [$value] unless ref $value;
		$o->{CONFIG}{$key} = $value;
		next;
	    }
	    $o->{CONFIG}{$key} = $value, next if not $value;
	    if ($key eq 'DIRECTORY') {
		croak M11_usage_DIRECTORY($value) unless (-d $value);
		$value = abs_path($value);
	    }
	    elsif ($key eq 'NAME') {
		croak M12_usage_NAME($value)
		  unless $value =~ /^[a-zA-Z_](\w|::)*$/;
	    }
	    elsif ($key eq 'VERSION') {
		croak M13_usage_VERSION($value) unless $value =~ /^\d\.\d\d*$/;
	    }
	    $o->{CONFIG}{$key} = $value;
	}
	else {
	    push @others, $key, $value;
	}
    }
    return (@others);
}

#==============================================================================
# Set option defaults based on current option settings.
#==============================================================================
sub fold_options {
    my $o = shift;

# The following small section of code seems, to me, to be unnecessary - which is the
# reason that I've commented it out. I've left it here (including its associated comments)
# in case it later becomes evident that there *is* good reason to include it. --sisyphus
#
## This bit tries to enable UNTAINT automatically if required when running the test suite.
#    my $env_ha = $ENV{HARNESS_ACTIVE} || 0 ;
#    my ($harness_active) = $env_ha =~ /(.*)/ ;
#    if (($harness_active)&&(! $o->{CONFIG}{UNTAINT})){
#            eval {
#                    require Scalar::Util;
#                    $o->{CONFIG}{UNTAINT} =
#                      (Scalar::Util::tainted(Cwd::cwd()) ? 1 : 0) ;
## Disable SAFEMODE in the test suite, we know what we are doing...
#                    $o->{CONFIG}{SAFEMODE} = 0 ;
#                    warn "\n-[tT] enabled for test suite.
#Automatically setting UNTAINT=1 and SAFEMODE=0.\n"
#                     unless $Inline::_TAINT_WARNING_ ;
#                    $Inline::_TAINT_WARNING_ = 1 ;
#            } ;
#   }
##
    $untaint = $o->{CONFIG}{UNTAINT} || 0;
    $safemode = (($o->{CONFIG}{SAFEMODE} == -1) ?
		 ($untaint ? 1 : 0) :
		 $o->{CONFIG}{SAFEMODE}
		);
    if (UNTAINT and
	SAFEMODE and
	not $o->{CONFIG}{DIRECTORY}) {
	croak M49_usage_unsafe(1) if ($< == 0 or $> == 0);
	warn M49_usage_unsafe(0) if $^W;
    }
    if ($o->{CONFIG}{AUTONAME} == -1) {
	$o->{CONFIG}{AUTONAME} = length($o->{CONFIG}{NAME}) ? 0 : 1;
    }
    $o->{API}{cleanup} =
      ($o->{CONFIG}{CLEAN_AFTER_BUILD} and not $o->{CONFIG}{REPORTBUG});
}

#==============================================================================
# Check if Inline extension is preinstalled
#==============================================================================
sub check_installed {
    my $o = shift;
    $o->{INLINE}{object_ready} = 0;
    unless ($o->{API}{code} =~ /^[A-Fa-f0-9]{32}$/) {
	require Digest::MD5;
	$o->{INLINE}{md5} = Digest::MD5::md5_hex($o->{API}{code});
    }
    else {
	$o->{INLINE}{md5} = $o->{API}{code};
    }
    return if $o->{CONFIG}{_INSTALL_};
    return unless $o->{CONFIG}{VERSION};
    croak M26_error_version_without_name()
      unless $o->{CONFIG}{NAME};

    my @pkgparts = split(/::/, $o->{API}{pkg});
    my $realname = File::Spec->catfile(@pkgparts) . '.pm';
    my $realname_unix = File::Spec::Unix->catfile(@pkgparts) . '.pm';
    my $realpath = $INC{$realname_unix}
      or croak M27_module_not_indexed($realname_unix);

    my ($volume,$dir,$file) = File::Spec->splitpath($realpath);
    my @dirparts = File::Spec->splitdir($dir);
    pop @dirparts unless $dirparts[-1];
    push @dirparts, $file;
    my @endparts = splice(@dirparts, 0 - @pkgparts);

    $dirparts[-1] = 'arch'
      if $dirparts[-2] eq 'blib' && $dirparts[-1] eq 'lib';
    File::Spec->catfile(@endparts) eq $realname
      or croak M28_error_grokking_path($realpath);
    $realpath =
      File::Spec->catpath($volume,File::Spec->catdir(@dirparts),"");

    $o->{API}{version} = $o->{CONFIG}{VERSION};
    $o->{API}{module} = $o->{CONFIG}{NAME};
    my @modparts = split(/::/,$o->{API}{module});
    $o->{API}{modfname} = $modparts[-1];
    $o->{API}{modpname} = File::Spec->catdir(@modparts);

    my $suffix = $Config{dlext};
    my $obj = File::Spec->catfile($realpath,'auto',$o->{API}{modpname},
                                  "$o->{API}{modfname}.$suffix");
    croak M30_error_no_obj($o->{CONFIG}{NAME}, $o->{API}{pkg},
			   $realpath) unless -f $obj;

    @{$o->{CONFIG}}{qw( PRINT_INFO
			REPORTBUG
			FORCE_BUILD
			_INSTALL_
		      )} = (0, 0, 0, 0);

    $o->{install_lib} = $realpath;
    $o->{INLINE}{ILSM_type} = 'compiled';
    $o->{INLINE}{ILSM_module} = 'Inline::C';
    $o->{INLINE}{ILSM_suffix} = $suffix;
    $o->{INLINE}{object_ready} = 1;
}

#==============================================================================
# Dynamically load the object module
#==============================================================================
sub load {
    my $o = shift;

    if ($o->{CONFIG}{_INSTALL_}) {
	my $inline = "$o->{API}{modfname}.inl";
	open INLINE, "> $inline"
	  or croak M24_open_for_output_failed($inline);
	print INLINE "*** AUTOGENERATED by Inline.pm ***\n\n";
	print INLINE "This file satisfies the make dependency for ";
	print INLINE "$o->{API}{modfname}.pm\n";
	close INLINE;
	return;
    }

    my ($pkg, $module) = @{$o->{API}}{qw(pkg module)};
    croak M42_usage_loader() unless $o->{INLINE}{ILSM_type} eq 'compiled';

    require DynaLoader;
    @Inline::ISA = qw(DynaLoader);

    my $global = $o->{CONFIG}{GLOBAL_LOAD} ? '0x01' : '0x00';
    my $version = $o->{API}{version} || '0.00';

    eval <
	package $pkg;
	push \@$ {pkg}::ISA, qw($module)
          unless \$module eq "$pkg";
        local \$$ {module}::VERSION = '$version';

	package $module;
	push \@$ {module}::ISA, qw(Exporter DynaLoader);
        sub dl_load_flags { $global }
	${module}::->bootstrap;
END
    croak M43_error_bootstrap($module, $@) if $@;
}

#==============================================================================
# Process the config options that apply to all Inline sections
#==============================================================================
sub handle_global_config {
    my $pkg = shift;
    while (@_) {
	my ($key, $value) = (shift, shift);
	croak M02_usage() if $key =~ /[\s\n]/;
	$key = $value if $key =~ /^(ENABLE|DISABLE)$/;
	croak M47_invalid_config_option($key)
	  unless defined $default_config->{$key};
	if ($key eq 'ENABLE') {
	    $CONFIG{$pkg}{template}{$value} = 1;
	}
	elsif ($key eq 'DISABLE') {
	    $CONFIG{$pkg}{template}{$value} = 0;
	}
	else {
	    $CONFIG{$pkg}{template}{$key} = $value;
	}
    }
}

#==============================================================================
# Process the config options that apply to a particular language
#==============================================================================
sub handle_language_config {
    my @values;
    while (@_) {
	my ($key, $value) = (shift, shift);
	croak M02_usage() if $key =~ /[\s\n]/;
	if ($key eq 'ENABLE') {
	    push @values, $value, 1;
	}
	elsif ($key eq 'DISABLE') {
	    push @values, $value, 0;
	}
	else {
	    push @values, $key, $value;
	}
    }
    return {@values};
}

#==============================================================================
# Validate and store shortcut config options
#==============================================================================
sub handle_shortcuts {
    my $pkg = shift;

    for my $option (@_) {
	my $OPTION = uc($option);
	if ($OPTION eq 'SITE_INSTALL') {
	    croak M58_site_install();
	}
	elsif ($shortcuts{$OPTION}) {
	    my ($method, $arg) = @{$shortcuts{$OPTION}};
	    $CONFIG{$pkg}{template}{$method} = $arg;
	}
	else {
	    croak M48_usage_shortcuts($option);
	}
    }
}

#==============================================================================
# Process the with command
#==============================================================================
sub handle_with {
    my $pkg = shift;
    croak M45_usage_with() unless @_;
    for (@_) {
	croak M02_usage() unless /^[\w:]+$/;
	eval "require $_;";
	croak M46_usage_with_bad($_) . $@ if $@;
	push @{$CONFIG{$pkg}{template}{WITH}}, $_;
    }
}

#==============================================================================
# Perform cleanup duties
#==============================================================================
sub DESTROY {
    my $o = shift;
    $o->clean_build if $o->{CONFIG}{CLEAN_BUILD_AREA};
}

# Comment out the next 2 lines to stop autoloading of subroutines (testing)
1;
__END__