Acme-MITHALDU-XSGrabBag
view release on metacpan or search on metacpan
inc/Inline.pm view on Meta::CPAN
use strict; use warnings;
package Inline;
our $VERSION = '0.80';
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}
inc/Inline.pm view on Meta::CPAN
#==============================================================================
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)
) {
$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 (uc $option eq uc '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} = $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 <<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
inc/Inline.pm view on Meta::CPAN
) {
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"} =
\&{$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 = <Inline::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} =
inc/Inline.pm view on Meta::CPAN
-w File::Spec->catdir($home,".Inline")) {
$temp_dir = File::Spec->catdir($home,".Inline");
}
elsif (defined $cwd and $cwd and
-d File::Spec->catdir($cwd, $did) and
-w File::Spec->catdir($cwd, $did)) {
$temp_dir = File::Spec->catdir($cwd, $did);
}
elsif (defined $bin and $bin and
-d File::Spec->catdir($bin, $did) and
-w File::Spec->catdir($bin, $did)) {
$temp_dir = File::Spec->catdir($bin, $did);
}
elsif (defined $cwd and $cwd and
-d $cwd and
-w $cwd and
_mkdir(File::Spec->catdir($cwd, $did), 0777)) {
$temp_dir = File::Spec->catdir($cwd, $did);
}
elsif (defined $bin and $bin and
-d $bin and
-w $bin and
_mkdir(File::Spec->catdir($bin, $did), 0777)) {
$temp_dir = File::Spec->catdir($bin, $did);
}
}
croak M56_no_DIRECTORY_found()
unless $temp_dir;
return $TEMP_DIR = abs_path($temp_dir);
}
sub _mkdir {
my $dir = shift;
my $mode = shift || 0777;
($dir) = ($dir =~ /(.*)/) if UNTAINT;
$dir =~ s|[/\\:]$||;
return mkdir($dir, $mode);
}
#==============================================================================
# Error messages
#==============================================================================
sub M01_usage_use {
my ($module) = @_;
return <<END;
It is invalid to use '$module' directly. Please consult the Inline
documentation for more information.
END
}
sub M02_usage {
my $usage = <<END;
Invalid usage of Inline module. Valid usages are:
use Inline;
use Inline language => "source-string", config-pair-list;
use Inline language => "source-file", config-pair-list;
use Inline language => [source-line-list], config-pair-list;
use Inline language => 'DATA', config-pair-list;
use Inline language => 'Config', config-pair-list;
use Inline Config => config-pair-list;
use Inline with => module-list;
use Inline shortcut-list;
END
# This is broken ????????????????????????????????????????????????????
$usage .= <<END if defined $Inline::languages;
Supported languages:
${\ join(', ', sort keys %$Inline::languages)}
END
return $usage;
}
sub M03_usage_bind {
my $usage = <<END;
Invalid usage of the Inline->bind() function. Valid usages are:
Inline->bind(language => "source-string", config-pair-list);
Inline->bind(language => "source-file", config-pair-list);
Inline->bind(language => [source-line-list], config-pair-list);
END
$usage .= <<END if defined $Inline::languages;
Supported languages:
${\ join(', ', sort keys %$Inline::languages)}
END
return $usage;
}
sub M04_error_nocode {
my ($language) = @_;
return <<END;
No $language source code found for Inline.
END
}
sub M05_error_eval {
my ($subroutine, $msg) = @_;
return <<END;
An eval() failed in Inline::$subroutine:
$msg
END
}
sub M06_code_file_failed_open {
my ($file) = @_;
return <<END;
Couldn't open Inline code file '$file':
$!
END
#'
}
sub M07_code_file_does_not_exist {
my ($file) = @_;
return <<END;
Inline assumes '$file' is a filename,
and that file does not exist.
END
}
sub M08_no_DATA_source_code {
my ($lang) = @_;
return <<END;
No source code in DATA section for Inline '$lang' section.
END
}
sub M09_marker_mismatch {
my ($marker, $lang) = @_;
return <<END;
Marker '$marker' does not match Inline '$lang' section.
END
}
sub M10_usage_WITH_USING {
return <<END;
Config option WITH or USING must be a module name or an array ref
of module names.
END
}
sub M11_usage_DIRECTORY {
my ($value) = @_;
return <<END;
Invalid value '$value' for config option DIRECTORY
END
}
sub M12_usage_NAME {
my ($name) = @_;
return <<END;
Invalid value for NAME config option: '$name'
END
}
sub M13_usage_VERSION {
my ($version) = @_;
return <<END;
Invalid value for VERSION config option: '$version'
Must be of the form '#.##'.
(Should also be specified as a string rather than a floating point number)
END
}
sub M14_usage_Config {
return <<END;
As of Inline v0.30, use of the Inline::Config module is no longer supported
or allowed. If Inline::Config exists on your system, it can be removed. See
the Inline documentation for information on how to configure Inline.
END
}
sub M15_usage_install_directory {
return <<END;
Can't use the DIRECTORY option when installing an Inline extension module.
END
inc/Inline.pm view on Meta::CPAN
$err
END
}
sub M45_usage_with {
return <<END;
Syntax error detected using 'use Inline with ...'.
Should be specified as:
use Inline with => 'module1', 'module2', ..., 'moduleN';
END
}
sub M46_usage_with_bad {
my $mod = shift;
return <<END;
Syntax error detected using 'use Inline with => "$mod";'.
'$mod' could not be found.
END
}
sub M47_invalid_config_option {
my ($option) = @_;
return <<END;
Invalid Config option '$option'
END
#'
}
sub M48_usage_shortcuts {
my ($shortcut) = @_;
return <<END;
Invalid shortcut '$shortcut' specified.
Valid shortcuts are:
VERSION, INFO, FORCE, NOCLEAN, CLEAN, UNTAINT, SAFE, UNSAFE,
GLOBAL, NOISY and REPORTBUG
END
}
sub M49_usage_unsafe {
my ($terminate) = @_;
return <<END .
You are using the Inline.pm module with the UNTAINT and SAFEMODE options,
but without specifying the DIRECTORY option. This is potentially unsafe.
Either use the DIRECTORY option or turn off SAFEMODE.
END
($terminate ? <<END : "");
Since you are running as a privileged user, Inline.pm is terminating.
END
}
sub M51_unused_DATA {
return <<END;
One or more DATA sections were not processed by Inline.
END
}
sub M52_invalid_filter {
my ($filter) = @_;
return <<END;
Invalid filter '$filter' is not a reference.
END
}
sub M53_mkdir_failed {
my ($dir) = @_;
return <<END;
Couldn't make directory path '$dir'.
END
#'
}
sub M54_rmdir_failed {
my ($dir) = @_;
return <<END;
Can't remove directory '$dir':
$!
END
#'
}
sub M55_unlink_failed {
my ($file) = @_;
return <<END;
Can't unlink file '$file':
$!
END
#'
}
sub M56_no_DIRECTORY_found {
return <<END;
Couldn't find an appropriate DIRECTORY for Inline to use.
END
#'
}
sub M57_wrong_architecture {
my ($ext, $arch, $thisarch) = @_;
return <<END;
The extension '$ext'
is built for perl on the '$arch' platform.
This is the '$thisarch' platform.
END
}
( run in 1.209 second using v1.01-cache-2.11-cpan-cdf2f3d4e48 )