view release on metacpan or  search on metacpan

inc/Inline.pm  view on Meta::CPAN

    }
}

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"} =
              \&{$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) = @_;

inc/Inline.pm  view on Meta::CPAN

            $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);