view release on metacpan or  search on metacpan

inc/Inline.pm  view on Meta::CPAN

   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;

    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) = @_;
    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;