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}
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)
) {
$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;
inc/Inline.pm view on Meta::CPAN
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} =
# (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};
inc/Inline.pm view on Meta::CPAN
#==============================================================================
# Dynamically load the object module
#==============================================================================
sub load {
my $o = shift;
return if $o->{CONFIG}{_INSTALL_};
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 <<END;
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 $@;
}
#==============================================================================
# Create file that satisfies the Makefile dependency for this object
#==============================================================================
sub satisfy_makefile_dep {
my $o = shift;
my $inline = $o->{API}{modinlname};
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}{module}\n";
close INLINE;
return;
}
#==============================================================================
# Process the config options that apply to all Inline sections
#==============================================================================
sub handle_global_config {
my $pkg = shift;
while (@_) {
my ($key, $value) = (uc shift, shift);
croak M02_usage() if $key =~ /[\s\n]/;
if ($key =~ /^(ENABLE|DISABLE)$/) {
($key, $value) = (uc $value, $key eq 'ENABLE' ? 1 : 0);
}
croak M47_invalid_config_option($key)
unless defined $default_config->{$key};
$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) = (uc shift, shift);
croak M02_usage() if $key =~ /[\s\n]/;
if ($key eq 'ENABLE') {
push @values, uc $value, 1;
}
elsif ($key eq 'DISABLE') {
push @values, uc $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}}, $_;
}
}
( run in 0.597 second using v1.01-cache-2.11-cpan-140bd7fdf52 )