The Perl Toolchain Summit 2025 Needs You: You can help 🙏 Learn more

## no critic qw(ProhibitUselessNoCritic PodSpelling ProhibitExcessMainComplexity) # DEVELOPER DEFAULT 1a: allow unreachable & POD-commented code, must be on line 1; SYSTEM SPECIAL 4: allow complex code outside subroutines, must be on line 1
# NEED FIX: triplicate export code
package RPerl::Config;
use strict;
our $VERSION = 0.013_000;
our $IS_RPERL_CONFIG = 1; # DEV NOTE, CORRELATION #rp027: RPerl::Config, MathPerl::Config, PhysicsPerl::Config, etc
## no critic qw(ProhibitUselessNoCritic ProhibitMagicNumbers RequireCheckedSyscalls) # USER DEFAULT 1: allow numeric values & print operator
## no critic qw(RequireInterpolationOfMetachars) # USER DEFAULT 2: allow single-quoted control characters & sigils
## no critic qw(ProhibitUnreachableCode RequirePodSections RequirePodAtEnd) # DEVELOPER DEFAULT 1b: allow POD & unreachable or POD-commented code, must be after line 1
## no critic qw(ProhibitStringyEval) # SYSTEM DEFAULT 1: allow eval()
## no critic qw(ProhibitExplicitStdin) # USER DEFAULT 4: allow <STDIN> prompt
## no critic qw(Capitalization ProhibitMultiplePackages ProhibitReusedNames) # SYSTEM DEFAULT 3: allow multiple & lower case package names
## no critic qw(ProhibitAutomaticExportation) # SYSTEM SPECIAL 14: allow global exports from Config.pm
# DEV NOTE: this package exists to serve as the header file for RPerl.pm itself,
# as well as for RPerl.pm dependencies such as Class.pm, HelperFunctions_cpp.pm, and rperltypes.pm
# @ARG == @_, $OS_ERROR == $ERRNO == $!, $EVAL_ERROR == $@, $CHILD_ERROR == $?, $EXECUTABLE_NAME == $^X, $PROGRAM_NAME == $0, $OSNAME == $^O
# export various subroutines and variables to all who call 'use RPerl::Config;'
$Data::Dumper::Sortkeys = 1; # Dumper() output must be sorted for lib/RPerl/Tests/Type_Types/* etc.
use Carp;
use English qw(-no_match_vars);
use POSIX qw(ceil floor modf);
use Exporter 'import';
# DEV NOTE, CORRELATION #rp008: can't include to_string(), type(), types(), name(), or scope_type_name_value() in @EXPORT here or in RPerl:: namespace below
# DEV NOTE, CORRELATION #rp034: enable @ARG in all packages (class & non-class)
our @EXPORT = qw(Dumper carp croak confess *ARG $OS_ERROR $EVAL_ERROR $CHILD_ERROR $EXECUTABLE_NAME $PROGRAM_NAME $OSNAME);
1; # end of package
# NEED FIX: triplicate export code
## no critic qw(ProhibitAutomaticExportation) # SYSTEM SPECIAL 14: allow global exports from Config.pm
# export various subroutines and variables to all who call 'use RPerl::AfterSubclass;'
$Data::Dumper::Sortkeys = 1; # Dumper() output must be sorted for lib/RPerl/Tests/Type_Types/* etc.
use Carp;
use English qw(-no_match_vars);
use POSIX qw(ceil floor modf);
use Exporter 'import';
# DEV NOTE, CORRELATION #rp008: can't include to_string(), type(), types(), name(), or scope_type_name_value() in @EXPORT here or in RPerl:: namespace below
# DEV NOTE, CORRELATION #rp034: enable @ARG in all packages (class & non-class)
our @EXPORT = qw(Dumper carp croak confess *ARG $OS_ERROR $EVAL_ERROR $CHILD_ERROR $EXECUTABLE_NAME $PROGRAM_NAME $OSNAME);
1; # end of package
# NEED FIX: triplicate export code
package RPerl;
use File::Find qw(find);
use IPC::Cmd qw(can_run); # to check for `reset`
## no critic qw(ProhibitUselessNoCritic ProhibitMagicNumbers RequireCheckedSyscalls) # USER DEFAULT 1: allow numeric values & print operator
## no critic qw(RequireInterpolationOfMetachars) # USER DEFAULT 2: allow single-quoted control characters & sigils
## no critic qw(ProhibitUnreachableCode RequirePodSections RequirePodAtEnd) # DEVELOPER DEFAULT 1b: allow POD & unreachable or POD-commented code, must be after line 1
## no critic qw(ProhibitStringyEval) # SYSTEM DEFAULT 1: allow eval()
## no critic qw(ProhibitExplicitStdin) # USER DEFAULT 4: allow <STDIN> prompt
## no critic qw(Capitalization ProhibitMultiplePackages ProhibitReusedNames) # SYSTEM DEFAULT 3: allow multiple & lower case package names
## no critic qw(ProhibitAutomaticExportation) # SYSTEM SPECIAL 14: allow global exports from Config.pm
# export $RPerl::MODES, as well as various subroutines and variables to all who call 'use RPerl;'
our $MODES = { # see perl_modes.txt for more info
0 => { ops => 'PERL', types => 'PERL' }, # NEED FIX: should be types => 'PERL_STATIC'
1 => { ops => 'CPP', types => 'PERL' }, # NEED FIX: should be types => 'PERL_STATIC'
2 => { ops => 'CPP', types => 'CPP' }
};
$Data::Dumper::Sortkeys = 1; # Dumper() output must be sorted for lib/RPerl/Tests/Type_Types/* etc.
use Carp;
use English qw(-no_match_vars);
use POSIX qw(ceil floor modf);
use Exporter 'import';
# DEV NOTE, CORRELATION #rp034: enable @ARG in all packages (class & non-class)
our @EXPORT = qw(Dumper carp croak confess *ARG $OS_ERROR $EVAL_ERROR $CHILD_ERROR $EXECUTABLE_NAME $PROGRAM_NAME $OSNAME);
# [[[ OO CLASS PROPERTIES SPECIAL ]]]
# data type checking mode, disabled in RPerl system code which calls 'use RPerl;',
# changed on a per-file basis by preprocessor directive, see RPerl::CompileUnit::Module::Class::INIT
# NEED UPGRADE: enable in RPerl system code when bootstrapping compiler
our $CHECK = 'OFF';
our $DEBUG = 0; # $RPerl::DEBUG & env var RPERL_DEBUG are equivalent, default to off, see debug*() & diag*() below
our $VERBOSE = 0; # $RPerl::VERBOSE & env var RPERL_VERBOSE are equivalent, default to off, see verbose*() below
our $WARNINGS = 1; # $RPerl::WARNINGS & env var RPERL_WARNINGS are equivalent, default to on, see warn*() below
our $TYPES_CCFLAG = ' -D__CPP__TYPES'; # rperltypes_mode.h & here default to CPPTYPES if PERLTYPES not explicitly set in this variable via rperltypes::types_enable()
our $BASE_PATH = undef; # all target software lives below here
our $INCLUDE_PATH = undef; # all target system modules live here
our $SCRIPT_PATH = undef; # interpreted target system programs live here
our $CORE_PATH = undef; # all Perl core components (perl.h, etc) live here
# DEV NOTE, CORRELATION #rp032: NEED UPGRADE: properly determine whether to use DBL_EPSILON or FLT_EPSILON below
use constant EPSILON => POSIX::DBL_EPSILON();
#use constant EPSILON => POSIX::FLT_EPSILON();
# [[[ SUBROUTINES SPECIAL ]]]
# use a possibly-compiled RPerl package during runtime
sub eval_use {
(my $package_name, my $display_errors) = @ARG;
# RPerl::debug('in RPerl::eval_use(), received $package_name = ', $package_name, "\n");
# RPerl::debug('in RPerl::eval_use(), CHECKPOINT c000', "\n");
my $INC_ref_pre = {};
foreach my $INC_key_pre (keys %INC) { $INC_ref_pre->{$INC_key_pre} = 1; }
# RPerl::debug('in RPerl::eval_use(), have $INC_ref_pre = ', Dumper($INC_ref_pre), "\n");
# RPerl::debug('in RPerl::eval_use(), CHECKPOINT c001', "\n");
my $eval_string =<<"EOL";
# no warnings 'all'; # DOES NOT SUPPRESS
local \$SIG{__WARN__} = sub {}; # DOES SUPPRESS
# BEGIN { RPerl::debug('in RPerl::eval_use() eval, about to call use $package_name...', "\\n"); }
# use $package_name; # DOES NOT SUPPRESS, THIS IS THE HIDDEN PERPETRATOR OF UNSUPPRESSABLE WARNINGS! 'Too late to call INIT block' inside multi-class module files
require $package_name; # DOES SUPPRESS
# BEGIN { RPerl::debug('in RPerl::eval_use() eval, ret from use $package_name...', "\\n"); }
# detect compiled C++ code and call cpp_load() accordingly
if (defined \&$package_name\:\:cpp_load) {
# RPerl::debug('in RPerl::eval_use() eval, $package_name\:\:cpp_load() is defined, calling...', "\\n");
$package_name\:\:cpp_load();
# RPerl::debug('in RPerl::eval_use() eval, $package_name\:\:cpp_load() is defined, returned from call', "\\n");
}
# else { RPerl::debug('in RPerl::eval_use() eval, $package_name\:\:cpp_load() is NOT defined, skipping...', "\\n"); }
EOL
# RPerl::debug('in RPerl::eval_use(), have $eval_string = ', "\n\n", $eval_string, "\n\n");
# RPerl::debug('in RPerl::eval_use(), CHECKPOINT c002', "\n");
$eval_string .=<<'EOL';
my $INC_ref_post = {};
foreach my $INC_key_post (keys %INC) {
if (not exists $INC_ref_pre->{$INC_key_post}) {
$INC_ref_post->{$INC_key_post} = $INC{$INC_key_post};
}
}
# RPerl::debug('in RPerl::eval_use() eval, have $INC_ref_post = ', Dumper($INC_ref_post), "\n");
RPerl::CompileUnit::Module::Class::create_symtab_entries_and_accessors_mutators($INC_ref_post);
EOL
# RPerl::debug('in RPerl::eval_use(), CHECKPOINT c003', "\n");
my $eval_retval = eval $eval_string;
# RPerl::debug('in RPerl::eval_use(), CHECKPOINT c004', "\n");
# FOR DEBUG PURPOSES
# if (defined $eval_retval) { print 'have $eval_retval = ', $eval_retval, "\n"; }
# else { print 'have $eval_retval = undef, have $EVAL_ERROR = ', $EVAL_ERROR, "\n"; }
if ($display_errors and (defined $EVAL_ERROR) and ($EVAL_ERROR ne q{})) {
RPerl::warning( 'WARNING WCOEU00, EVAL USE: Failed to eval-use package ' . q{'}
. $package_name . q{'} . ', fatal error trapped and delayed' . "\n" );
RPerl::diag( ' Trapped the following error message...' . "\n\n" . $EVAL_ERROR . "\n" );
RPerl::warning("\n");
}
# RPerl::debug('in RPerl::eval_use(), CHECKPOINT c005', "\n");
return $eval_retval;
}
# NEED UPGRADE: replace Data::Dumper with pure-RPerl equivalent?
#sub DUMPER {
# ( my $dumpee ) = @ARG;
# die ('in RPerl::DUMPER(), received undef argument, dying') if (not(defined($_[0])));
# return '**UNDEF**' if ( not( defined $dumpee ) );
# return $dumpee->DUMPER()
# if ( defined( eval( q{$} . ref($dumpee) . q{::DUMPER} ) ) );
# return Dumper($dumpee);
#}
# do not directly print all of @ARG, only print defined arguments, if one or more arguments are undef then it will give a confusing error message:
# Use of uninitialized value $RPerl::ARG[1] in print at lib/RPerl/Config.pm line XYZ
sub print_defined_args {
my $OUTPUT_STREAM = shift @ARG;
my $elements_bad = [];
for (my $i = 0; $i < (scalar @ARG); $i++) {
my $arg_element = $ARG[$i];
if (defined $arg_element) {
print {$OUTPUT_STREAM} $arg_element;
}
else {
push @{$elements_bad}, $i;
}
}
if ((scalar @{$elements_bad}) > 0) {
if ($OUTPUT_STREAM eq *STDOUT) {
print {$OUTPUT_STREAM} q{WARNING WRPDB00: RPerl verbose() or verbose_pause() statement received undefined argument(s) at index number(s): } . Dumper($elements_bad) . "\n" ;
}
else {
print {$OUTPUT_STREAM} q{WARNING WRPVB00: RPerl diag() or diag_pause() or debug() or debug_pause() or warning() statement received undefined argument(s) at index number(s): } . Dumper($elements_bad) . "\n" ;
}
}
}
# DEV NOTE: to make diag*() & debug*() & verbose*() & warning() truly variadic, do not accept args as first line in subroutine
# DEV NOTE: diag() is simply a wrapper around debug(), they are 100% equivalent; likewise diag_pause() and debug_pause()
sub diag { return debug(@ARG); }
sub diag_pause { return debug_pause(@ARG); }
# print debugging AKA diagnostic message to STDERR, if either RPERL_DEBUG environmental variable or $RPerl::DEBUG global variable are true
sub debug {
# print {*STDERR} 'in debug(), have $ENV{RPERL_DEBUG} = ' . $ENV{RPERL_DEBUG} . "\n";
# DEV NOTE, CORRELATION #rp017: default to off; if either variable is set to true, then do emit messages
if ( $ENV{RPERL_DEBUG} or $RPerl::DEBUG ) {
#print {*STDERR} @ARG;
print_defined_args(*STDERR, @ARG);
}
# if ( $ENV{RPERL_DEBUG} or $RPerl::DEBUG ) { print {*STDERR} "\e[1;31m $message \e[0m"; } # print in red
return 1; # DEV NOTE: this must be here to avoid 'at -e line 0. INIT failed--call queue aborted.'... BUT WHY???
}
# same as debug(), except require <ENTER> to continue
sub debug_pause {
if ( $ENV{RPERL_DEBUG} or $RPerl::DEBUG ) {
# print {*STDERR} @ARG;
print_defined_args(*STDERR, @ARG);
my $stdin_ignore = <STDIN>;
}
return 1;
}
# print verbose user-friendly message to STDOUT, if either RPERL_VERBOSE environmental variable or $RPerl::VERBOSE global variable are true
sub verbose {
# DEV NOTE, CORRELATION #rp017: default to off; if either variable is set to true, then do emit messages
if ( $ENV{RPERL_VERBOSE} or $RPerl::VERBOSE ) {
# print {*STDOUT} @ARG;
print_defined_args(*STDOUT, @ARG);
}
return 1;
}
# same as verbose(), except require <ENTER> to continue
sub verbose_pause {
if ( $ENV{RPERL_VERBOSE} or $RPerl::VERBOSE ) {
# print {*STDOUT} @ARG;
print_defined_args(*STDOUT, @ARG);
my $stdin_ignore = <STDIN>;
}
return 1;
}
# clear STDOUT, if either RPERL_VERBOSE environmental variable or $RPerl::VERBOSE global variable are true
sub verbose_clear_screen {
if ( $ENV{RPERL_VERBOSE} or $RPerl::VERBOSE ) {
if ( $OSNAME eq 'linux' ) {
my $reset_path = can_run('reset');
if ( defined $reset_path ) {
system $reset_path;
}
}
elsif ( $OSNAME eq 'MSWin32' ) {
# cls is a shell builtin, not a command which can be found by can_run()
system 'cls';
}
else {
RPerl::warning(
q{WARNING WOSCLSC00: Unknown operating system '} . $OSNAME . q{' where 'linux' or 'Win32' expected, skipping screen clearing} . "\n" );
return 0;
}
}
return 1;
}
# print non-fatal warning message to STDERR, unless either RPERL_WARNINGS environmental variable or $RPerl::WARNINGS global variable are false
sub warning {
# default to on; if either variable is set to false, then do not emit messages
if ( ( ( not defined $ENV{RPERL_WARNINGS} ) or $ENV{RPERL_WARNINGS} )
and $RPerl::WARNINGS )
{
# NEED ADDRESS? the 2 following lines should be equivalent, but warn causes false ECOPAPL03
# print {*STDERR} @ARG;
# warn $message . "\n";
print_defined_args(*STDERR, @ARG);
}
return 1;
}
sub analyze_class_symtab_entries {
( my $class ) = @ARG;
my $retval = q{};
my @isa_array = eval q{@} . $class . q{::ISA};
#print Dumper(\@isa_array);
my $isa_string = join ', ', @isa_array;
$retval .= '<<<<< BEGIN SYMTAB ENTRIES >>>>>' . "\n";
$retval .= $class . ' ISA (' . $isa_string . ')' . "\n\n";
#foreach my $entry ( sort keys %RPerl::CompileUnit::Module::Header:: ) {
my @keys = eval q{sort keys %} . $class . q{::};
foreach my $entry (@keys) {
# my $glob = $RPerl::CompileUnit::Module::Header::{$entry};
my $glob = eval q{$} . $class . q{::{$entry}};
$retval .= q{-} x 50;
$retval .= "\n";
$retval .= $entry . "\n";
# $retval .= ref \$glob, "\n"; # always says GLOB
if ( defined ${$glob} ) {
$retval .= "\t" . 'scalar';
my $ref_type = ref ${$glob};
if ( $ref_type ne q{} ) {
$retval .= "\t" . $ref_type . 'ref';
}
}
if ( @{$glob} ) {
$retval .= "\t" . 'array';
}
if ( %{$glob} ) {
$retval .= "\t" . 'hash';
}
if ( defined &{$glob} ) {
$retval .= "\t" . 'code';
}
$retval .= "\n";
}
$retval .= '<<<<< END SYMTAB ENTRIES >>>>>' . "\n";
return $retval;
}
# [ AUTOMATICALLY SET SYSTEM-DEPENDENT PATH VARIABLES ]
sub set_system_paths {
( my $target_file_name_config, my $target_package_name_config, my $target_file_name_pm, my $target_file_name_script ) = @ARG;
if (( not exists $INC{$target_file_name_config} )
or ( not defined $INC{$target_file_name_config} )
)
{
Carp::croak 'BIZARRE ERROR EINPL00: Non-existent or undefined Perl %INC path entry for '
. $target_file_name_config
. ', reported from within '
. $target_package_name_config
. ', croaking';
}
my $target_config_pm_loaded = $INC{$target_file_name_config};
if ( not -e $target_config_pm_loaded ) {
Carp::croak 'BIZARRE ERROR EINPL01: Non-existent file ',
$target_config_pm_loaded,
' supposedly loaded in %INC, reported from within ' . $target_package_name_config . ', croaking';
}
( my $volume_loaded, my $directories_loaded, my $file_loaded ) = File::Spec->splitpath( $target_config_pm_loaded, my $no_file = 0 );
my @directories_loaded_split = File::Spec->splitdir($directories_loaded);
#print {*STDERR} 'in ' . $target_package_name_config . ', have pre-pop @directories_loaded_split = ', "\n", Dumper(@directories_loaded_split), "\n";
# pop twice if empty entry on top
if ( pop @directories_loaded_split eq q{} ) { pop @directories_loaded_split; }
my $target_pm_wanted = File::Spec->catpath( $volume_loaded, ( File::Spec->catdir(@directories_loaded_split) ), $target_file_name_pm );
#print {*STDERR} 'in ' . $target_package_name_config . ', have post-pop @directories_loaded_split = ', "\n", Dumper(@directories_loaded_split), "\n";
#print {*STDERR} 'in ' . $target_package_name_config . ', have $target_config_pm_loaded = ', $target_config_pm_loaded, "\n";
#print {*STDERR} 'in ' . $target_package_name_config . ', have $target_pm_wanted = ', $target_pm_wanted, "\n";
my $target_pm_loaded = undef;
if ( ( exists $INC{$target_file_name_pm} ) and ( defined $INC{$target_file_name_pm} ) ) {
$target_pm_loaded = $INC{$target_file_name_pm};
# BULK88 20150608 2015.159: Win32 Bug Fix
# if ( not -e $target_pm_loaded ) {
if ( not -f $target_pm_loaded ) {
Carp::croak 'BIZARRE ERROR EINPL02: Non-existent file ', $target_pm_loaded,
' supposedly loaded in %INC, reported from within ' . $target_package_name_config . ', croaking';
}
}
# strip trailing '/'
if ( ( substr $directories_loaded, -1, 1 ) eq q{/} ) {
$directories_loaded = substr $directories_loaded, 0, -1;
}
#print {*STDERR} 'in ' . $target_package_name_config . ', have $directories_loaded = ', $directories_loaded, "\n";
#print {*STDERR} 'in ' . $target_package_name_config . ', have $target_pm_loaded = ', ( $target_pm_loaded or '<undef>' ), "\n";
my $target_scripts_found = [];
my $target_pms_found = [];
# BULK88 20150608 2015.159: Win32 Bug Fix
#foreach my $inc_path ( $directories_loaded, @INC ) { # this doesn't work with Win32
# DEV NOTE: search order precedence for script command is OS paths, path of loaded TARGET/Config.pm (this file), Perl INC paths
foreach my $inc_path ( ( split ':', $ENV{PATH} ), File::Spec->catpath( $volume_loaded, $directories_loaded, '' ), @INC ) {
# print {*STDERR} 'in ' . $target_package_name_config . ', top of main foreach() loop, have $inc_path = ', $inc_path, "\n";
my $sub_inc_paths = [];
# push @{$sub_inc_paths}, $inc_path;
( my $inc_volume, my $inc_directories, my $inc_file ) = File::Spec->splitpath( $inc_path, my $no_file = 1 );
push @{$sub_inc_paths}, $inc_directories;
my @directories_split = File::Spec->splitdir($inc_directories);
pop @directories_split;
push @{$sub_inc_paths}, File::Spec->catdir(@directories_split);
pop @directories_split;
push @{$sub_inc_paths}, File::Spec->catdir(@directories_split);
# print {*STDERR} 'in ' . $target_package_name_config . ', in main foreach() loop, have $sub_inc_paths = ', "\n", Dumper($sub_inc_paths), "\n";
# print {*STDERR} 'in ' . $target_package_name_config . ', in main foreach() loop, have $inc_volume = ', "\n", Dumper($inc_volume), "\n";
# print {*STDERR} 'in ' . $target_package_name_config . ', in main foreach() loop, have $inc_directories = ', "\n", Dumper($inc_directories), "\n";
# print {*STDERR} 'in ' . $target_package_name_config . ', in main foreach() loop, have $inc_file = ', "\n", Dumper($inc_file), "\n";
my $possible_target_scripts = [];
foreach my $sub_inc_path ( @{$sub_inc_paths} ) {
push @{$possible_target_scripts}, File::Spec->catpath( $inc_volume, $sub_inc_path, $target_file_name_script );
if ( $sub_inc_path ne q{} ) {
push @{$possible_target_scripts}, File::Spec->catpath( $inc_volume, File::Spec->catdir( $sub_inc_path, 'script' ), $target_file_name_script );
push @{$possible_target_scripts}, File::Spec->catpath( $inc_volume, File::Spec->catdir( $sub_inc_path, 'bin' ), $target_file_name_script );
}
else {
push @{$possible_target_scripts}, File::Spec->catpath( $inc_volume, 'script', $target_file_name_script );
push @{$possible_target_scripts}, File::Spec->catpath( $inc_volume, 'bin', $target_file_name_script );
}
}
foreach my $possible_target_script ( @{$possible_target_scripts} ) {
# print {*STDERR} 'in ' . $target_package_name_config . ', have $possible_target_script = ', $possible_target_script, "\n";
# BULK88 20150608 2015.159: Win32 Bug Fix
# if ( ( -e $possible_target_script ) and ( -x $possible_target_script ) ) {
if ( ( -f $possible_target_script ) and ( $OSNAME eq 'MSWin32' ? 1 : -x $possible_target_script ) ) {
my $is_unique = 1;
foreach my $target_script_found ( @{$target_scripts_found} ) {
if ( $target_script_found eq $possible_target_script ) { $is_unique = 0; }
}
if ($is_unique) { push @{$target_scripts_found}, $possible_target_script; }
}
}
if ( not defined $target_pm_loaded ) {
my $possible_target_pm = File::Spec->catfile( $inc_path, $target_file_name_pm );
# BULK88 20150608 2015.159: Win32 Bug Fix
# if ( -e $possible_target_pm ) {
if ( -f $possible_target_pm ) {
my $is_unique = 1;
foreach my $target_pm_found ( @{$target_pms_found} ) {
if ( $target_pm_found eq $possible_target_pm ) {
$is_unique = 0;
}
}
if ($is_unique) { push @{$target_pms_found}, $possible_target_pm; }
}
}
}
#print {*STDERR} 'in ' . $target_package_name_config . ', have $target_scripts_found = ', "\n", Dumper($target_scripts_found), "\n";
#print {*STDERR} 'in ' . $target_package_name_config . ', have $target_pms_found = ', "\n", Dumper($target_pms_found), "\n";
if ( scalar @{$target_scripts_found} == 0 ) {
die 'ERROR EEXRP00: Failed to find `' . $target_file_name_script . '` executable, dying' . "\n";
}
my $target_script_found = $target_scripts_found->[0];
if ( scalar @{$target_scripts_found} > 1 ) {
RPerl::warning( 'WARNING WEXRP00: Found multiple `' . $target_file_name_script . '` executables, using first located, ' .
q{`} . $target_script_found . q{`} . '; other locations include ' .
(join ', ', (map {q{`} . $_ . q{`}} @{$target_scripts_found}[1 .. ((scalar @{$target_scripts_found} - 1))])) . "\n" );
}
my $target_pm_found = undef;
if ( defined $target_pm_loaded ) {
$target_pm_found = $target_pm_loaded;
}
else {
if ( scalar @{$target_pms_found} == 0 ) {
Carp::croak 'ERROR EINRP00: Failed to find ' . $target_file_name_pm . ' module, croaking';
}
foreach my $target_pm_found_single ( @{$target_pms_found} ) {
# strip leading './' and '.\', for matching purposes only, do not actually save stripped filename
my $target_pm_found_single_stripped = $target_pm_found_single;
if (((substr $target_pm_found_single, 0, 2) eq './') or ((substr $target_pm_found_single, 0, 2) eq '.\\')) {
substr $target_pm_found_single_stripped, 0, 2, q{};
}
if ( $target_pm_found_single_stripped eq $target_pm_wanted ) {
$target_pm_found = $target_pm_found_single;
}
}
if ( not defined $target_pm_found ) {
Carp::croak 'ERROR EINRP01: Expected to find ', $target_pm_wanted, ' but instead found ', "\n", Dumper($target_pms_found), ', croaking';
}
}
#print {*STDERR} 'in ' . $target_package_name_config . ', have $target_pm_found = ', $target_pm_found, "\n";
#print {*STDERR} 'in ' . $target_package_name_config . ', have $target_script_found = ', $target_script_found, "\n";
#( my $volume_target_pm, my $directories_target_pm, my $file_target_pm ) = File::Spec->splitpath( $target_pm_found, $no_file = 0 );
#( my $volume_target_script, my $directories_target_script, my $file_target_script ) = File::Spec->splitpath( $target_script_found, $no_file = 0 );
( undef, my $directories_target_pm, my $file_target_pm ) = File::Spec->splitpath( $target_pm_found, $no_file = 0 );
( undef, my $directories_target_script, my $file_target_script ) = File::Spec->splitpath( $target_script_found, $no_file = 0 );
#print {*STDERR} 'in ' . $target_package_name_config . ', have $volume_target_pm = ', $volume_target_pm, "\n";
#print {*STDERR} 'in ' . $target_package_name_config . ', have $directories_target_pm = ', $directories_target_pm, "\n";
#print {*STDERR} 'in ' . $target_package_name_config . ', have $file_target_pm = ', $file_target_pm, "\n";
#print {*STDERR} 'in ' . $target_package_name_config . ', have $volume_target_script = ', $volume_target_script, "\n";
#print {*STDERR} 'in ' . $target_package_name_config . ', have $directories_target_script = ', $directories_target_script, "\n";
#print {*STDERR} 'in ' . $target_package_name_config . ', have $file_target_script = ', $file_target_script, "\n";
my @directories_target_pm_split = File::Spec->splitdir($directories_target_pm);
my @directories_target_script_split = File::Spec->splitdir($directories_target_script);
my @directories_base_split = ();
for my $i ( 0 .. ( ( scalar @directories_target_pm_split ) - 1 ) ) {
if ( $directories_target_pm_split[$i] eq $directories_target_script_split[$i] ) {
push @directories_base_split, $directories_target_pm_split[$i];
}
else {
for my $j ( 0 .. ( $i - 1 ) ) {
shift @directories_target_pm_split;
shift @directories_target_script_split;
}
last;
}
}
#print {*STDERR} 'in ' . $target_package_name_config . ', have @directories_base_split = ', "\n", Dumper(\@directories_base_split), "\n";
#print {*STDERR} 'in ' . $target_package_name_config . ', have @directories_target_pm_split = ', "\n", Dumper(\@directories_target_pm_split), "\n";
#print {*STDERR} 'in ' . $target_package_name_config . ', have @directories_target_script_split = ', "\n", Dumper(\@directories_target_script_split), "\n";
my $MY_BASE_PATH;
my $MY_INCLUDE_PATH;
my $MY_SCRIPT_PATH;
my $MY_CORE_PATH;
# NEED FIX: how do we catpath() with some $volume instead of catdir() below, without breaking relative paths?
$MY_BASE_PATH = File::Spec->catpath( $volume_loaded, File::Spec->catdir(@directories_base_split), '' );
if ( $MY_BASE_PATH eq q{} ) {
$MY_INCLUDE_PATH = File::Spec->catpath( $volume_loaded, File::Spec->catdir(@directories_target_pm_split), '' );
$MY_SCRIPT_PATH = File::Spec->catpath( $volume_loaded, File::Spec->catdir(@directories_target_script_split), '' );
#print {*STDERR} 'in ' . $target_package_name_config . ', have $MY_BASE_PATH eq q{} = ', $MY_BASE_PATH, "\n";
}
else {
$MY_INCLUDE_PATH = File::Spec->catdir( $MY_BASE_PATH, @directories_target_pm_split );
$MY_SCRIPT_PATH = File::Spec->catdir( $MY_BASE_PATH, @directories_target_script_split );
#print {*STDERR} 'in ' . $target_package_name_config . ', have $MY_BASE_PATH ne q{} ', $MY_BASE_PATH, "\n";
}
foreach my $inc_path (@INC) {
$MY_CORE_PATH = File::Spec->catdir( $inc_path, 'CORE' );
my $inc_core_perl_h_path = File::Spec->catfile( $MY_CORE_PATH, 'perl.h' );
if ( ( -e $inc_core_perl_h_path ) and ( -r $inc_core_perl_h_path ) and ( -f $inc_core_perl_h_path ) ) { last; }
else { $MY_CORE_PATH = q{}; }
}
#print {*STDERR} 'in ' . $target_package_name_config . ', have $MY_BASE_PATH = ', $MY_BASE_PATH, "\n";
#print {*STDERR} 'in ' . $target_package_name_config . ', have $MY_INCLUDE_PATH = ', $MY_INCLUDE_PATH, "\n";
#print {*STDERR} 'in ' . $target_package_name_config . ', have $MY_SCRIPT_PATH = ', $MY_SCRIPT_PATH, "\n";
#print {*STDERR} 'in ' . $target_package_name_config . ', have $MY_CORE_PATH = ', $MY_CORE_PATH, "\n";
return [$MY_BASE_PATH, $MY_INCLUDE_PATH, $MY_SCRIPT_PATH, $MY_CORE_PATH];
}
# [[[ OPERATIONS SPECIAL ]]]
my $file_name_config = 'RPerl/Config.pm'; # this file name
my $package_name_config = 'RPerl::Config'; # this file's primary package name
my $file_name_pm = 'RPerl.pm';
my $file_name_script = 'rperl';
($BASE_PATH, $INCLUDE_PATH, $SCRIPT_PATH, $CORE_PATH) = @{set_system_paths($file_name_config, $package_name_config, $file_name_pm, $file_name_script)};
1; # end of package
# export system paths to main:: namespace for use by PMC files
package main;
# [[[ OO CLASS PROPERTIES SPECIAL ]]]
# DEV NOTE: duplicate lines to avoid 'used only once' warnings
our $BASE_PATH = $RPerl::BASE_PATH;
$BASE_PATH = $RPerl::BASE_PATH;
our $INCLUDE_PATH = $RPerl::INCLUDE_PATH;
$INCLUDE_PATH = $RPerl::INCLUDE_PATH;
our $SCRIPT_PATH = $RPerl::SCRIPT_PATH;
$SCRIPT_PATH = $RPerl::SCRIPT_PATH;
1; # end of package