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;

inc/Inline.pm  view on Meta::CPAN

    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;
}