package Inline; use strict; require 5.005; $Inline::VERSION = '0.44'; use AutoLoader 'AUTOLOAD'; use Inline::denter; use Config; use Carp; use Cwd qw(abs_path cwd); use File::Spec; use File::Spec::Unix; my %CONFIG = (); my @DATA_OBJS = (); my $INIT = 0; my $version_requested = 0; my $version_printed = 0; my $untaint = 0; my $safemode = 0; $Inline::languages = undef; #needs to be global for AutoLoaded error messages 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, SAFEMODE => -1, GLOBAL_LOAD => 0, BUILD_NOISY => 0, BUILD_TIMERS => 0, WARNINGS => 1, _INSTALL_ => 0, }; sub UNTAINT {$untaint} sub SAFEMODE {$safemode} #============================================================================== # This is where everything starts. #============================================================================== sub import { local ($/, $") = ("\n", ' '); local ($\, $,); my $o; my ($pkg, $script) = caller; # 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 ($control eq 'with') { return handle_with($pkg, @_); } elsif ($control eq '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} = $Inline::VERSION; $o->{API}{pkg} = $pkg; $o->{API}{script} = $script; $o->{API}{language_id} = $language_id; if ($option =~ /^(FILE|BELOW)$/ 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 ($option eq '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} = $Inline::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 for 5.6+ users # and tell them to use a Inline->init() call if they run into problems. (rare) my $lexwarn = ($] >= 5.006) ? 'no warnings;' : ''; eval <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 <{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 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 $using_module = /^::/ ? "Inline::$language_id$_" : /::/ ? $_ : "Inline::${language_id}::$_"; 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"}; *{$ilsm . "::$override"} = *{$using_module . "::$override"}; } } } #============================================================================== # Restore the modules original methods #============================================================================== sub pop_overrides { 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 = ) =~ s/$CR?$LF/\n/g; @{$DATA{$pkg}} = split /(?m)(__\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; $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); $o->{install_lib} = $realpath; $o->{INLINE}{ILSM_type} = 'compiled'; $o->{INLINE}{ILSM_module} = 'Inline::C'; $o->{INLINE}{ILSM_suffix} = $suffix; $o->{INLINE}{object_ready} = 1; } #============================================================================== # Dynamically load the object module #============================================================================== sub load { my $o = shift; if ($o->{CONFIG}{_INSTALL_}) { my $inline = "$o->{API}{modfname}.inl"; 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}{modfname}.pm\n"; close INLINE; return; } 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 <bootstrap; END croak M43_error_bootstrap($module, $@) if $@; } #============================================================================== # Process the config options that apply to all Inline sections #============================================================================== sub handle_global_config { my $pkg = shift; while (@_) { my ($key, $value) = (shift, shift); croak M02_usage() if $key =~ /[\s\n]/; $key = $value if $key =~ /^(ENABLE|DISABLE)$/; croak M47_invalid_config_option($key) unless defined $default_config->{$key}; if ($key eq 'ENABLE') { $CONFIG{$pkg}{template}{$value} = 1; } elsif ($key eq 'DISABLE') { $CONFIG{$pkg}{template}{$value} = 0; } else { $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) = (shift, shift); croak M02_usage() if $key =~ /[\s\n]/; if ($key eq 'ENABLE') { push @values, $value, 1; } elsif ($key eq 'DISABLE') { push @values, $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}}, $_; } } #============================================================================== # Perform cleanup duties #============================================================================== sub DESTROY { my $o = shift; $o->clean_build if $o->{CONFIG}{CLEAN_BUILD_AREA}; } # Comment out the next 2 lines to stop autoloading of subroutines (testing) 1; __END__ #============================================================================== # Get the source code #============================================================================== sub receive_code { my $o = shift; my $code = shift; croak M02_usage() unless (defined $code and $code); if (ref $code eq 'CODE') { $o->{API}{code} = &$code; } elsif (ref $code eq 'ARRAY') { $o->{API}{code} = join '', @$code; } elsif ($code =~ m|[/\\:]| and $code =~ m|^[/\\:\w.\-\ \$\[\]<>]+$|) { if (-f $code) { local ($/, *CODE); open CODE, "< $code" or croak M06_code_file_failed_open($code); $o->{API}{code} = ; } else { croak M07_code_file_does_not_exist($code); } } else { $o->{API}{code} = $code; } } #============================================================================== # Get the source code from an Inline::Files filehandle #============================================================================== sub read_inline_file { my $o = shift; my ($lang, $pkg) = @{$o->{API}}{qw(language_id pkg)}; my $langfile = uc($lang); croak M59_bad_inline_file($lang) unless $langfile =~ /^[A-Z]\w*$/; croak M60_no_inline_files() unless (defined $INC{File::Spec::Unix->catfile("Inline","Files.pm")} and $Inline::Files::VERSION =~ /^\d\.\d\d$/ and $Inline::Files::VERSION ge '0.51'); croak M61_not_parsed() unless $lang = Inline::Files::get_filename($pkg); { no strict 'refs'; local $/; $Inline::FILE = \*{"${pkg}::$langfile"}; # open $Inline::FILE; $o->{API}{code} = <$Inline::FILE>; # close $Inline::FILE; } } #============================================================================== # Read the cached config file from the Inline directory. This will indicate # whether the Language code is valid or not. #============================================================================== sub check_config_file { my ($DIRECTORY, %config); my $o = shift; croak M14_usage_Config() if defined %main::Inline::Config::; croak M63_no_source($o->{API}{pkg}) if $o->{INLINE}{md5} eq $o->{API}{code}; # First make sure we have the DIRECTORY if ($o->{CONFIG}{_INSTALL_}) { croak M15_usage_install_directory() if $o->{CONFIG}{DIRECTORY}; my $cwd = Cwd::cwd(); $DIRECTORY = $o->{INLINE}{DIRECTORY} = File::Spec->catdir($cwd,"_Inline"); if (not -d $DIRECTORY) { _mkdir($DIRECTORY, 0777) or croak M16_DIRECTORY_mkdir_failed($DIRECTORY); } } else { $DIRECTORY = $o->{INLINE}{DIRECTORY} = $o->{CONFIG}{DIRECTORY} || $o->find_temp_dir; } $o->create_config_file($DIRECTORY) if not -e File::Spec->catfile($DIRECTORY,"config"); open CONFIG, "< ".File::Spec->catfile($DIRECTORY,"config") or croak M17_config_open_failed($DIRECTORY); my $config = join '', ; close CONFIG; croak M62_invalid_config_file(File::Spec->catfile($DIRECTORY,"config")) unless $config =~ /^version :/; ($config) = $config =~ /(.*)/s if UNTAINT; %config = Inline::denter->new()->undent($config); $Inline::languages = $config{languages}; croak M18_error_old_version($config{version}, $DIRECTORY) unless (defined $config{version} and $config{version} =~ /TRIAL/ or $config{version} >= 0.40); croak M19_usage_language($o->{API}{language_id}, $DIRECTORY) unless defined $config{languages}->{$o->{API}{language_id}}; $o->{API}{language} = $config{languages}->{$o->{API}{language_id}}; if ($o->{API}{language} ne $o->{API}{language_id}) { if (defined $o->{$o->{API}{language_id}}) { $o->{$o->{API}{language}} = $o->{$o->{API}{language_id}}; delete $o->{$o->{API}{language_id}}; } } $o->{INLINE}{ILSM_type} = $config{types}->{$o->{API}{language}}; $o->{INLINE}{ILSM_module} = $config{modules}->{$o->{API}{language}}; $o->{INLINE}{ILSM_suffix} = $config{suffixes}->{$o->{API}{language}}; } #============================================================================== # Auto-detect installed Inline language support modules #============================================================================== sub create_config_file { my ($o, $dir) = @_; # This subroutine actually fires off another instance of perl. # with arguments that make this routine get called again. # That way the queried modules don't stay loaded. if (defined $o) { ($dir) = $dir =~ /(.*)/s if UNTAINT; my $perl = $Config{perlpath}; $perl = $^X unless -f $perl; ($perl) = $perl =~ /(.*)/s if UNTAINT; local $ENV{PERL5LIB} if defined $ENV{PERL5LIB}; local $ENV{PERL5OPT} if defined $ENV{PERL5OPT}; my $inline = $INC{'Inline.pm'}; $inline ||= File::Spec->curdir(); my($v,$d,$f) = File::Spec->splitpath($inline); $f = "" if $f eq 'Inline.pm'; $inline = File::Spec->catpath($v,$d,$f); my $INC = "-I$inline -I" . join(" -I", grep {(-d File::Spec->catdir($_,"Inline") or -d File::Spec->catdir($_,"auto","Inline") )} @INC); system "$perl $INC -MInline=_CONFIG_ -e1 $dir" and croak M20_config_creation_failed($dir); return; } my ($lib, $mod, $register, %checked, %languages, %types, %modules, %suffixes); LIB: for my $lib (@INC) { next unless -d File::Spec->catdir($lib,"Inline"); opendir LIB, File::Spec->catdir($lib,"Inline") or warn(M21_opendir_failed(File::Spec->catdir($lib,"Inline"))), next; while ($mod = readdir(LIB)) { next unless $mod =~ /\.pm$/; $mod =~ s/\.pm$//; next LIB if ($checked{$mod}++); if ($mod eq 'Config') { # Skip Inline::Config warn M14_usage_Config(); next; } next if $mod =~ /^(MakeMaker|denter|messages)$/; eval "require Inline::$mod;"; warn($@), next if $@; eval "\$register=&Inline::${mod}::register"; next if $@; my $language = ($register->{language}) or warn(M22_usage_register($mod)), next; for (@{$register->{aliases}}) { warn(M23_usage_alias_used($mod, $_, $languages{$_})), next if defined $languages{$_}; $languages{$_} = $language; } $languages{$language} = $language; $types{$language} = $register->{type}; $modules{$language} = "Inline::$mod"; $suffixes{$language} = $register->{suffix}; } closedir LIB; } my $file = File::Spec->catfile($ARGV[0],"config"); open CONFIG, "> $file" or croak M24_open_for_output_failed($file); print CONFIG Inline::denter->new() ->indent(*version => $Inline::VERSION, *languages => \%languages, *types => \%types, *modules => \%modules, *suffixes => \%suffixes, ); close CONFIG; exit 0; } #============================================================================== # Check to see if code has already been compiled #============================================================================== sub check_module { my ($module, $module2); my $o = shift; return $o->install if $o->{CONFIG}{_INSTALL_}; if ($o->{CONFIG}{NAME}) { $module = $o->{CONFIG}{NAME}; } elsif ($o->{API}{pkg} eq 'main') { $module = $o->{API}{script}; my($v,$d,$file) = File::Spec->splitpath($module); $module = $file; $module =~ s|\W|_|g; $module =~ s|^_+||; $module =~ s|_+$||; $module = 'FOO' if $module =~ /^_*$/; $module = "_$module" if $module =~ /^\d/; } else { $module = $o->{API}{pkg}; } $o->{API}{suffix} = $o->{INLINE}{ILSM_suffix}; $o->{API}{directory} = $o->{INLINE}{DIRECTORY}; my $auto_level = 2; while ($auto_level <= 5) { if ($o->{CONFIG}{AUTONAME}) { $module2 = $module . '_' . substr($o->{INLINE}{md5}, 0, 2**$auto_level); $auto_level++; } else { $module2 = $module; $auto_level = 6; # Don't loop on non-autoname objects } $o->{API}{module} = $module2; my @modparts = split /::/, $module2; $o->{API}{modfname} = $modparts[-1]; $o->{API}{modpname} = File::Spec->catdir(@modparts); $o->{API}{build_dir} = File::Spec->catdir($o->{INLINE}{DIRECTORY}, 'build',$o->{API}{modpname}); $o->{API}{install_lib} = File::Spec->catdir($o->{INLINE}{DIRECTORY}, 'lib'); my $inl = File::Spec->catfile($o->{API}{install_lib},"auto", $o->{API}{modpname},"$o->{API}{modfname}.inl"); $o->{API}{location} = File::Spec->catfile($o->{API}{install_lib},"auto",$o->{API}{modpname}, "$o->{API}{modfname}.$o->{INLINE}{ILSM_suffix}"); last unless -f $inl; my %inl; { local ($/, *INL); open INL, $inl or croak M31_inline_open_failed($inl); %inl = Inline::denter->new()->undent(); } next unless ($o->{INLINE}{md5} eq $inl{md5}); next unless ($inl{inline_version} ge '0.40'); unless (-f $o->{API}{location}) { warn <{API}{location} For Inline file: $inl END next; } $o->{INLINE}{object_ready} = 1 unless $o->{CONFIG}{FORCE_BUILD}; last; } unshift @::INC, $o->{API}{install_lib}; } #============================================================================== # Set things up so that the extension gets installed into the blib/arch. # Then 'make install' will do the right thing. #============================================================================== sub install { my ($module, $DIRECTORY); my $o = shift; croak M64_install_not_c($o->{API}{language_id}) unless uc($o->{API}{language_id}) =~ /^(C|CPP)$/ ; croak M36_usage_install_main() if ($o->{API}{pkg} eq 'main'); croak M37_usage_install_auto() if $o->{CONFIG}{AUTONAME}; croak M38_usage_install_name() unless $o->{CONFIG}{NAME}; croak M39_usage_install_version() unless $o->{CONFIG}{VERSION}; croak M40_usage_install_badname($o->{CONFIG}{NAME}, $o->{API}{pkg}) unless $o->{CONFIG}{NAME} eq $o->{API}{pkg}; # $o->{CONFIG}{NAME} =~ /^$o->{API}{pkg}::\w(\w|::)+$/ # ); my ($mod_name, $mod_ver, $ext_name, $ext_ver) = ($o->{API}{pkg}, $ARGV[0], @{$o->{CONFIG}}{qw(NAME VERSION)}); croak M41_usage_install_version_mismatch($mod_name, $mod_ver, $ext_name, $ext_ver) unless ($mod_ver eq $ext_ver); $o->{INLINE}{INST_ARCHLIB} = $ARGV[1]; $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); $o->{API}{suffix} = $o->{INLINE}{ILSM_suffix}; $o->{API}{build_dir} = File::Spec->catdir($o->{INLINE}{DIRECTORY},'build', $o->{API}{modpname}); $o->{API}{directory} = $o->{INLINE}{DIRECTORY}; my $cwd = Cwd::cwd(); $o->{API}{install_lib} = File::Spec->catdir($cwd,$o->{INLINE}{INST_ARCHLIB}); $o->{API}{location} = File::Spec->catfile($o->{API}{install_lib},"auto",$o->{API}{modpname}, "$o->{API}{modfname}.$o->{INLINE}{ILSM_suffix}"); 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 { no strict 'refs'; &{$mod . "::Inline"}($o->{API}{language}); }; croak M25_no_WITH_support($mod, $@) if $@; push @configs, %$ref; } return @configs; } #============================================================================== # Blindly untaint tainted fields in Inline object. #============================================================================== sub env_untaint { my $o = shift; for (keys %ENV) { ($ENV{$_}) = $ENV{$_} =~ /(.*)/; } my $delim = $^O eq 'MSWin32' ? ';' : ':'; $ENV{PATH} = join $delim, grep {not /^\./ and not ((stat($_))[2] & 0022) } split $delim, $ENV{PATH}; map {($_) = /(.*)/} @INC; } #============================================================================== # Blindly untaint tainted fields in Inline object. #============================================================================== sub obj_untaint { my $o = shift; ($o->{INLINE}{ILSM_module}) = $o->{INLINE}{ILSM_module} =~ /(.*)/; ($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; } #============================================================================== # Apply a list of filters to the source code #============================================================================== sub filter { my $o = shift; my $new_code = $o->{API}{code}; for (@_) { croak M52_invalid_filter($_) unless ref; if (ref eq 'CODE') { $new_code = $_->($new_code); } else { $new_code = $_->filter($o, $new_code); } } return $new_code; } #============================================================================== # User wants to report a bug #============================================================================== sub reportbug { use strict; my $o = shift; return if $o->{INLINE}{reportbug_handled}++; print STDERR < REPORTBUG mode in effect. Your Inline $o->{API}{language_id} code will be processed in the build directory: $o->{API}{build_dir} A perl-readable bug report including your perl configuration and run-time diagnostics will also be generated in the build directory. When the program finishes please bundle up the above build directory with: tar czf Inline.REPORTBUG.tar.gz $o->{API}{build_dir} and send "Inline.REPORTBUG.tar.gz" as an email attachment to the author of the offending Inline::* module with the subject line: REPORTBUG: Inline.pm Include in the email, a description of the problem and anything else that you think might be helpful. Patches are welcome! :-\) <-----------------------End of REPORTBUG Section------------------------------> END my %versions; { no strict 'refs'; %versions = map {eval "use $_();"; ($_, $ {$_ . '::VERSION'})} qw (Digest::MD5 Parse::RecDescent ExtUtils::MakeMaker File::Path FindBin Inline ); } $o->mkpath($o->{API}{build_dir}); open REPORTBUG, "> ".File::Spec->catfile($o->{API}{build_dir},"REPORTBUG") or croak M24_open_for_output_failed (File::Spec->catfile($o->{API}{build_dir},"REPORTBUG")); %Inline::REPORTBUG_Inline_Object = (); %Inline::REPORTBUG_Perl_Config = (); %Inline::REPORTBUG_Module_Versions = (); print REPORTBUG Inline::denter->new() ->indent(*REPORTBUG_Inline_Object, $o, *REPORTBUG_Perl_Config, \%Config::Config, *REPORTBUG_Module_Versions, \%versions, ); close REPORTBUG; } #============================================================================== # Print a small report if PRINT_INFO option is set. #============================================================================== sub print_info { use strict; my $o = shift; print STDERR < Information about the processing of your Inline $o->{API}{language_id} code: END print STDERR <{INLINE}{object_ready}); Your module is already compiled. It is located at: $o->{API}{location} END print STDERR <{INLINE}{object_ready} and $o->{CONFIG}{FORCE_BUILD}); But the FORCE_BUILD option is set, so your code will be recompiled. I\'ll use this build directory: $o->{API}{build_dir} and I\'ll install the executable as: $o->{API}{location} END print STDERR <{INLINE}{object_ready}); Your source code needs to be compiled. I\'ll use this build directory: $o->{API}{build_dir} and I\'ll install the executable as: $o->{API}{location} END eval { print STDERR $o->info; }; print $@ if $@; print STDERR < END } #============================================================================== # Hand off this invokation to Inline::MakeMaker #============================================================================== sub maker_utils { require Inline::MakeMaker; goto &Inline::MakeMaker::utils; } #============================================================================== # Utility subroutines #============================================================================== #============================================================================== # Make a path #============================================================================== sub mkpath { use strict; my ($o, $mkpath) = @_; my($volume,$dirs,$nofile) = File::Spec->splitpath($mkpath,1); my @parts = File::Spec->splitdir($dirs); my @done; foreach (@parts){ push(@done,$_); my $path = File::Spec->catpath($volume,File::Spec->catdir(@done),""); -d $path || _mkdir($path, 0777); } croak M53_mkdir_failed($mkpath) unless -d $mkpath; } #============================================================================== # Nuke a path (nicely) #============================================================================== sub rmpath { use strict; my ($o, $prefix, $rmpath) = @_; # Nuke the target directory _rmtree(File::Spec->catdir($prefix ? ($prefix,$rmpath) : ($rmpath))); # Remove any empty directories underneath the requested one my @parts = File::Spec->splitdir($rmpath); while (@parts){ $rmpath = File::Spec->catdir($prefix ? ($prefix,@parts) : @parts); rmdir $rmpath or last; # rmdir failed because dir was not empty pop @parts; } } sub _rmtree { my($roots) = @_; $roots = [$roots] unless ref $roots; my($root); foreach $root (@{$roots}) { if ( -d $root ) { my(@names,@paths); if (opendir MYDIR, $root) { @names = readdir MYDIR; closedir MYDIR; } else { croak M21_opendir_failed($root); } my $dot = File::Spec->curdir(); my $dotdot = File::Spec->updir(); foreach my $name (@names) { next if $name eq $dot or $name eq $dotdot; my $maybefile = File::Spec->catfile($root,$name); push(@paths,$maybefile),next if $maybefile and -f $maybefile; push(@paths,File::Spec->catdir($root,$name)); } _rmtree(\@paths); ($root) = $root =~ /(.*)/ if UNTAINT; rmdir($root) or croak M54_rmdir_failed($root); } else { ($root) = $root =~ /(.*)/ if UNTAINT; unlink($root) or croak M55_unlink_failed($root); } } } #============================================================================== # Find the 'Inline' directory to use. #============================================================================== my $TEMP_DIR; sub find_temp_dir { return $TEMP_DIR if $TEMP_DIR; my ($temp_dir, $home, $bin, $cwd, $env); $temp_dir = ''; $env = $ENV{PERL_INLINE_DIRECTORY} || ''; $home = $ENV{HOME} ? abs_path($ENV{HOME}) : ''; if ($env and -d $env and -w $env) { $temp_dir = $env; } elsif ($cwd = abs_path('.') and $cwd ne $home and -d File::Spec->catdir($cwd,".Inline") and -w File::Spec->catdir($cwd,".Inline")) { $temp_dir = File::Spec->catdir($cwd,".Inline"); } elsif (require FindBin and $bin = $FindBin::Bin and -d File::Spec->catdir($bin,".Inline") and -w File::Spec->catdir($bin,".Inline")) { $temp_dir = File::Spec->catdir($bin,".Inline"); } elsif ($home and -d File::Spec->catdir($home,".Inline") and -w File::Spec->catdir($home,".Inline")) { $temp_dir = File::Spec->catdir($home,".Inline"); } elsif (defined $cwd and $cwd and -d File::Spec->catdir($cwd,"_Inline") and -w File::Spec->catdir($cwd,"_Inline")) { $temp_dir = File::Spec->catdir($cwd,"_Inline"); } elsif (defined $bin and $bin and -d File::Spec->catdir($bin,"_Inline") and -w File::Spec->catdir($bin,"_Inline")) { $temp_dir = File::Spec->catdir($bin,"_Inline"); } elsif (defined $cwd and $cwd and -d $cwd and -w $cwd and _mkdir(File::Spec->catdir($cwd,"_Inline"), 0777)) { $temp_dir = File::Spec->catdir($cwd,"_Inline"); } elsif (defined $bin and $bin and -d $bin and -w $bin and _mkdir(File::Spec->catdir($bin,"_Inline"), 0777)) { $temp_dir = File::Spec->catdir($bin,"_Inline"); } 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); } # Comment out the next 2 lines to stop autoloading of messages (for testing) #1; #__END__ #============================================================================== # Error messages are autoloaded #============================================================================== sub M01_usage_use { my ($module) = @_; return < "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 .= <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 .= <catfile(${dir},"config"); return <catfile(${dir},"config"); return < '$mod'" but '$mod' does not work with Inline. $err END } sub M26_error_version_without_name { return < 'module1', 'module2', ..., 'moduleN'; END } sub M46_usage_with_bad { my $mod = shift; return < "$mod";'. '$mod' could not be found. END } sub M47_invalid_config_option { my ($option) = @_; return <