Alt-Math-Prime-FastSieve-Inline
view release on metacpan or search on metacpan
inc/Inline.pm view on Meta::CPAN
use strict; use warnings;
package Inline;
our $VERSION = '0.78';
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;
our $languages = undef;
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 {
my $class = shift;
$class->import_heavy(@_);
}
sub import_heavy {
local ($/, $") = ("\n", ' '); local ($\, $,);
my $o;
my ($pkg, $script) = caller(1);
# 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 (uc $control eq uc 'with') {
return handle_with($pkg, @_);
}
elsif (uc $control eq uc '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} = $VERSION;
$o->{API}{pkg} = $pkg;
$o->{API}{script} = $script;
$o->{API}{language_id} = $language_id;
if ($option =~ /^(FILE|BELOW)$/i or
not $option and
defined $INC{File::Spec::Unix->catfile('Inline','Files.pm')} and
Inline::Files::get_filename($pkg)
inc/Inline.pm view on Meta::CPAN
$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 <<END;
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 <<END;
You are using Inline.pm version $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 $fixed_name = /^Parser?(Pegex|RegExp|RecDescent)$/ ? "Parser::$1" : $_;
$fixed_name =~ s/^:://;
my $using_module = /^::/
? "Inline::${language_id}::$fixed_name"
: /::/
? $_
: "Inline::${language_id}::$fixed_name";
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"} =
inc/Inline.pm view on Meta::CPAN
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},
inc/Inline.pm view on Meta::CPAN
# open $Inline::FILE;
$o->{API}{code} = <$Inline::FILE>;
# close $Inline::FILE;
}
}
#==============================================================================
# Read the cached config file from the Inline directory. This will indicate
# whether the Language code is valid or not.
#==============================================================================
sub check_config_file {
my ($DIRECTORY, %config);
my $o = shift;
croak M14_usage_Config() if $Inline::Config::VERSION;
croak M63_no_source($o->{API}{pkg})
if $o->{INLINE}{md5} eq $o->{API}{code};
# First make sure we have the DIRECTORY
if ($o->{CONFIG}{_INSTALL_}) {
croak M15_usage_install_directory()
if $o->{CONFIG}{DIRECTORY};
my $cwd = Cwd::cwd();
$DIRECTORY =
$o->{INLINE}{DIRECTORY} = File::Spec->catdir($cwd, $did);
if (not -d $DIRECTORY) {
_mkdir($DIRECTORY, 0777)
or croak M16_DIRECTORY_mkdir_failed($DIRECTORY);
}
}
else {
$DIRECTORY = $o->{INLINE}{DIRECTORY} =
$o->{CONFIG}{DIRECTORY} || $o->find_temp_dir;
}
if($o->{CONFIG}{REWRITE_CONFIG_FILE}) {
if(-e File::Spec->catfile($DIRECTORY, $configuration_file)) {
my $unlink = unlink(File::Spec->catfile($DIRECTORY, $configuration_file));
if(!$unlink) {warn "REWRITE_CONFIG_FILE is set, but removal of config file failed"}
else {warn "config file removal successful\n" if $o->{CONFIG}{_TESTING}}
}
}
my $load_cfg = sub {
$o->create_config_file($DIRECTORY)
if not -e File::Spec->catfile($DIRECTORY, $configuration_file);
open CONFIG, "< ".File::Spec->catfile($DIRECTORY,$configuration_file)
or croak M17_config_open_failed($DIRECTORY);
flock(CONFIG, LOCK_EX) if $^O !~ /^VMS|riscos|VOS$/;
my $config = join '', <CONFIG>;
flock(CONFIG, LOCK_UN) if $^O !~ /^VMS|riscos|VOS$/;
close CONFIG;
unless($config =~ /^version :/) {
warn "\$load_cfg sub: \$config: *${config}*\n";
croak M62_invalid_config_file(File::Spec->catfile($DIRECTORY,$configuration_file));
}
if(UNTAINT) {
warn "In Inline::check_config_file(): Blindly untainting Inline configuration file information.\n"
unless $o->{CONFIG}{NO_UNTAINT_WARN};
($config) = $config =~ /(.*)/s;
}
%config = Inline::denter->new()->undent($config);
} ;
$load_cfg->() ;
if (! defined $config{languages}->{$o->{API}{language_id}}){
my $unlink = unlink(File::Spec->catfile($DIRECTORY, $configuration_file));
if(!$unlink) {warn "Failed to remove config file"}
else {warn "config file removed\n" if $o->{CONFIG}{_TESTING}}
$load_cfg->() ;
}
$Inline::languages = $config{languages};
{
no warnings ('numeric'); # These warnings were a pain with devel releases.
# If there's a problem with the version number, the
# error message will output $config{version} anyway.
croak M18_error_old_version($config{version}, $DIRECTORY)
unless (defined $config{version} and
$config{version} =~ /TRIAL/ or
$config{version} >= 0.40);
} # numeric warnings re-enabled.
croak M19_usage_language($o->{API}{language_id}, $DIRECTORY)
unless defined $config{languages}->{$o->{API}{language_id}};
$o->{API}{language} = $config{languages}->{$o->{API}{language_id}};
if ($o->{API}{language} ne $o->{API}{language_id}) {
if (defined $o->{$o->{API}{language_id}}) {
$o->{$o->{API}{language}} = $o->{$o->{API}{language_id}};
delete $o->{$o->{API}{language_id}};
}
}
$o->{INLINE}{ILSM_type} = $config{types}->{$o->{API}{language}};
$o->{INLINE}{ILSM_module} = $config{modules}->{$o->{API}{language}};
$o->{INLINE}{ILSM_suffix} = $config{suffixes}->{$o->{API}{language}};
}
#==============================================================================
# Auto-detect installed Inline language support modules
#==============================================================================
sub create_config_file {
my ($o, $dir) = @_;
# This subroutine actually fires off another instance of perl.
# with arguments that make this routine get called again.
# That way the queried modules don't stay loaded.
if (defined $o) {
($dir) = $dir =~ /(.*)/s if UNTAINT;
my $perl = $Config{perlpath};
$perl = $^X unless -f $perl;
($perl) = $perl =~ /(.*)/s if UNTAINT;
local $ENV{PERL5LIB} if defined $ENV{PERL5LIB};
local $ENV{PERL5OPT} if defined $ENV{PERL5OPT};
my $inline = $INC{'Inline.pm'};
$inline ||= File::Spec->curdir();
inc/Inline.pm view on Meta::CPAN
$o->{API}{directory} = $o->{INLINE}{DIRECTORY};
my $cwd = Cwd::cwd();
$o->{API}{install_lib} =
File::Spec->catdir($cwd,$o->{INLINE}{INST_ARCHLIB});
$o->{API}{location} =
File::Spec->catfile($o->{API}{install_lib},"auto",$o->{API}{modpname},
"$o->{API}{modfname}.$o->{INLINE}{ILSM_suffix}");
unshift @::INC, $o->{API}{install_lib};
$o->{INLINE}{object_ready} = 0;
}
#==============================================================================
# Create the .inl file for an object
#==============================================================================
sub write_inl_file {
my $o = shift;
my $inl =
File::Spec->catfile($o->{API}{install_lib},"auto",$o->{API}{modpname},
"$o->{API}{modfname}.inl");
open INL, "> $inl"
or croak "Can't create Inline validation file $inl: $!";
my $apiversion = $Config{apiversion} || $Config{xs_apiversion};
print INL Inline::denter->new()
->indent(*md5, $o->{INLINE}{md5},
*name, $o->{API}{module},
*version, $o->{CONFIG}{VERSION},
*language, $o->{API}{language},
*language_id, $o->{API}{language_id},
*installed, $o->{CONFIG}{_INSTALL_},
*date_compiled, scalar localtime,
*inline_version, $Inline::VERSION,
*ILSM, { map {($_, $o->{INLINE}{"ILSM_$_"})}
(qw( module suffix type ))
},
*Config, { (map {($_,$Config{$_})}
(qw( archname osname osvers
cc ccflags ld so version
))),
(apiversion => $apiversion),
},
);
close INL;
}
#==============================================================================
# Get config hints
#==============================================================================
sub with_configs {
my $o = shift;
my @configs;
for my $mod (@{$o->{CONFIG}{WITH}}) {
my $ref = eval { $mod->Inline($o->{API}{language}); };
croak M25_no_WITH_support($mod, $@) if $@;
croak M65_WITH_not_lang($mod, $o->{API}{language}) unless $ref;
push @configs, %$ref;
}
return @configs;
}
#==============================================================================
# Blindly untaint tainted fields in %ENV.
#==============================================================================
sub env_untaint {
my $o = shift;
warn "In Inline::env_untaint() : Blindly untainting tainted fields in %ENV.\n" unless $o->{CONFIG}{NO_UNTAINT_WARN};
{
no warnings ('uninitialized'); # In case $ENV{$_} is set to undef.
for (keys %ENV) {
($ENV{$_}) = $ENV{$_} =~ /(.*)/;
}
}
# only accept dirs that are absolute and not world-writable
$ENV{PATH} = $^O eq 'MSWin32' ?
join ';', grep {not /^\./ and -d $_
} split /;/, $ENV{PATH}
:
join ':', grep {/^\// and -d $_ and $< == $> ? 1 : not (-W $_ or -O $_)
} split /:/, $ENV{PATH};
map {($_) = /(.*)/} @INC;
# list cherry-picked from `perldoc perlrun`
delete @ENV{qw(PERL5OPT PERL5SHELL PERL_ROOT IFS CDPATH ENV BASH_ENV)};
$ENV{SHELL} = '/bin/sh' if -x '/bin/sh';
$< = $> if $< != $>; # so child processes retain euid - ignore failure
}
#==============================================================================
# Blindly untaint tainted fields in Inline object.
#==============================================================================
sub obj_untaint {
my $o = shift;
warn "In Inline::obj_untaint() : Blindly untainting tainted fields in Inline object.\n" unless $o->{CONFIG}{NO_UNTAINT_WARN};
($o->{INLINE}{ILSM_module}) = $o->{INLINE}{ILSM_module} =~ /(.*)/;
($o->{API}{directory}) = $o->{API}{directory} =~ /(.*)/;
($o->{API}{build_dir}) = $o->{API}{build_dir} =~ /(.*)/;
($o->{CONFIG}{DIRECTORY}) = $o->{CONFIG}{DIRECTORY} =~ /(.*)/;
($o->{API}{install_lib}) = $o->{API}{install_lib} =~ /(.*)/;
($o->{API}{modpname}) = $o->{API}{modpname} =~ /(.*)/;
($o->{API}{modfname}) = $o->{API}{modfname} =~ /(.*)/;
($o->{API}{language}) = $o->{API}{language} =~ /(.*)/;
($o->{API}{pkg}) = $o->{API}{pkg} =~ /(.*)/;
($o->{API}{module}) = $o->{API}{module} =~ /(.*)/;
}
#==============================================================================
# Clean the build directory from previous builds
#==============================================================================
sub clean_build {
use strict;
my ($prefix, $dir);
my $o = shift;
$prefix = $o->{INLINE}{DIRECTORY};
opendir(BUILD, $prefix)
or croak "Can't open build directory: $prefix for cleanup $!\n";
while ($dir = readdir(BUILD)) {
my $maybedir = File::Spec->catdir($prefix,$dir);
if (($maybedir and -d $maybedir) and ($dir =~ /\w{36,}/)) {
$o->rmpath($prefix,$dir);
}
}
close BUILD;
}
#==============================================================================
# Apply a list of filters to the source code
#==============================================================================
sub filter {
my $o = shift;
my $new_code = $o->{API}{code};
for (@_) {
croak M52_invalid_filter($_) unless ref;
if (ref eq 'CODE') {
$new_code = $_->($new_code);
}
else {
$new_code = $_->filter($o, $new_code);
}
}
return $new_code;
}
#==============================================================================
# User wants to report a bug
#==============================================================================
sub reportbug {
use strict;
my $o = shift;
return if $o->{INLINE}{reportbug_handled}++;
print STDERR <<END;
( run in 0.557 second using v1.01-cache-2.11-cpan-39bf76dae61 )