our $VERSION = 0.044_000;
unshift @PATH, Alien::astyle->bin_dir();
our hashref_hashref $filename_suffixes_supported = {
INPUT_SOURCE => { PL => ['.pl'], PM => ['.pm'] },
OUTPUT_SOURCE => { CPP => ['.cpp'], H => ['.h'], PMC => ['.pmc'], OPENMP_CPP => ['.openmp.cpp'] },
OUTPUT_BINARY => { O => ['.o'], A => ['.a'], SO => ['.so'], EXE => [ q{}, '.exe' ], OPENMP_EXE => [ '.openmp', '.openmp.exe' ] }
};
sub find_parents {
{ my string_arrayref $RETURN_TYPE };
( my string $file_name, my boolean $find_grandparents_recurse, my string_hashref $modes ) = @ARG;
$file_name = post_processor__INC_paths_delete($file_name, 1, 0);
$file_name = post_processor__absolute_path_delete($file_name);
$file_name = post_processor__current_directory_path_delete($file_name);
my string_arrayref $parents = [];
if ( not -f $file_name ) {
die 'ERROR ECOCOPA00, COMPILER, FIND PARENTS: File not found, ' . q{'} . $file_name . q{'} . ', dying' . "\n";
}
open my filehandleref $FILE_HANDLE, '<', $file_name
or die 'ERROR ECOCOPA01, COMPILER, FIND PARENTS: Cannot open file ' . q{'} . $file_name . q{'} . ' for reading, ' . $OS_ERROR . ', dying' . "\n";
my string $file_line;
my string $top_level_package_name = undef;
my boolean $use_rperl = 0;
while ( $file_line = <$FILE_HANDLE> ) {
if ( $file_line =~ /^\s*package\s+[\w:]+\s*;\s*$/xms ) {
if ( not defined $top_level_package_name ) {
$top_level_package_name = $file_line;
$top_level_package_name =~ s/^\s*package\s+([\w:]+)\s*;\s*$/$1/gxms;
}
else {
last;
}
}
if ( $file_line =~ /^\s*use\s+[\w:]+/xms ) {
if (( $file_line =~ /use\s+RPerl\s*;/ ) or
( $file_line =~ /use\s+RPerl::AfterSubclass\s*;/ )) {
$use_rperl = 1;
next;
}
elsif ( $file_line =~ /use\s+lib/ ) {
die
q{ERROR ECOCOPA02, COMPILER, FIND PARENTS: 'use lib...' not currently supported, please set @INC using the PERL5LIB environment variable, file }
. q{'}
. $file_name . q{'}
. ', dying' . "\n";
}
elsif ( $file_line !~ /use\s+parent/ )
{
next;
}
if (not $use_rperl) {
last;
}
my string $package_file_name_included;
my string $package_name = $file_line;
$package_name =~ s/^(\s*)//gxms;
substr $package_name, 0, 14, q{};
$package_name =~ s/([\w:]+)(.*)$/$1/gxms;
if ($package_name eq 'RPerl::CompileUnit::Module::Class') {
next;
}
my string $package_file_name = $package_name;
$package_file_name =~ s/::/\//gxms;
$package_file_name .= '.pm';
foreach my string $INC_directory (File::Spec->catpath( '', getcwd, 'lib' ), @INC) {
$package_file_name_included = File::Spec->catpath( '', $INC_directory, $package_file_name );
if (-e $package_file_name_included) {
last;
}
else {
$package_file_name_included = q{};
}
}
if ($package_file_name_included eq q{}) {
die 'ERROR ECOCOPA04, COMPILER, FIND PARENTS: Failed to find package file ', q{'}, $package_file_name, q{'},
' in @INC, included from file ', q{'}, $file_name, q{'}, ', dying', "\n";
}
my string $package_file_name_included_relative = $package_file_name_included;
$package_file_name_included_relative = post_processor__INC_paths_delete($package_file_name_included_relative, 1, 0);
$package_file_name_included_relative = post_processor__absolute_path_delete( $package_file_name_included_relative );
$package_file_name_included_relative = post_processor__current_directory_path_delete( $package_file_name_included_relative );
push @{$parents}, $package_file_name_included_relative;
if ($find_grandparents_recurse) {
my string_arrayref $grandparents = find_parents( $package_file_name_included, $find_grandparents_recurse, $modes );
$parents = [ uniq @{$grandparents}, @{$parents} ];
}
}
}
close $FILE_HANDLE
or die 'ERROR ECOCOPA05, COMPILER, FIND PARENTS: Cannot close file ' . q{'}
. $file_name . q{'}
. ' after reading, '
. $OS_ERROR
. ', dying' . "\n";
return $parents;
}
sub find_dependencies {
{ my string_arrayref $RETURN_TYPE };
( my string $file_name, my boolean $find_subdependencies_recurse, my string_hashref $modes ) = @ARG;
my boolean $leading_lib_delete = 0;
my string $file_name_pre_process = $file_name;
$file_name = post_processor__INC_paths_delete($file_name, 1, $leading_lib_delete);
$file_name = post_processor__absolute_path_delete($file_name);
$file_name = post_processor__current_directory_path_delete($file_name);
my string_arrayref $dependencies = [];
if ( not -f $file_name ) {
$leading_lib_delete = 1;
my string $file_name_nolib = post_processor__INC_paths_delete($file_name_pre_process, 1, $leading_lib_delete);
if ( not -f $file_name_nolib ) {
die 'ERROR ECOCODE00, COMPILER, FIND DEPENDENCIES: File not found, ' . q{'} . $file_name . q{'} . ', or ' . q{'} . $file_name_nolib . q{'} . ', dying' . "\n";
}
else {
$file_name = $file_name_nolib;
}
}
open my filehandleref $FILE_HANDLE, '<', $file_name
or die 'ERROR ECOCODE01, COMPILER, FIND DEPENDENCIES: Cannot open file ' . q{'} . $file_name . q{'} . ' for reading, ' . $OS_ERROR . ', dying' . "\n";
my string $file_line;
my string $top_level_package_name = undef;
my boolean $use_rperl = 0;
while ( $file_line = <$FILE_HANDLE> ) {
if ( ( $file_line =~ /^\s*package\s+[\w:]+\s*;\s*$/xms ) and ( not defined $top_level_package_name ) ) {
$top_level_package_name = $file_line;
$top_level_package_name =~ s/^\s*package\s+([\w:]+)\s*;\s*$/$1/gxms;
}
if ( $file_line =~ /^\s*use\s+[\w:]+/xms ) {
if (( $file_line =~ /use\s+RPerl\s*;/ ) or
( $file_line =~ /use\s+RPerl::AfterSubclass\s*;/ )) {
$use_rperl = 1;
next;
}
elsif ( ( $file_line =~ /use\s+strict\s*;/ )
or ( $file_line =~ /use\s+warnings\s*;/ )
or ( $file_line =~ /use\s+RPerl::CompileUnit::Module::Class\s*;/ )
or ( $file_line =~ /use\s+RPerl::Class\s*;/ )
or ( $file_line =~ /use\s+RPerl::Config\s*;/ )
or ( $file_line =~ /use\s+RPerl::Exporter.*;/ )
or ( $file_line =~ /use\s+\w+Perl::Config\s*;/ )
or ( $file_line =~ /use\s+perlapinames_generated/ )
or ( $file_line =~ /use\s+parent/ )
or ( $file_line =~ /use\s+constant/ )
or ( $file_line =~ /use\s+overload/ )
or ( $file_line =~ /use\s+integer/ )
or ( $file_line =~ /use\s+[0-9]/ )
)
{
next;
}
elsif ((defined $top_level_package_name) and ( $file_line =~ /use\s+$top_level_package_name\s*;/ )) {
next;
}
elsif ( $file_line =~ /use\s+rperlsse\s*;/ ) {
if ( ( substr $Config{archname}, 0, 3 ) eq 'arm' ) {
die q{ERROR ECOCODE06, COMPILER, FIND DEPENDENCIES: 'use rperlsse;' command found but SSE not supported on ARM architecture, file }
. q{'}
. $file_name . q{'}
. ', dying' . "\n";
}
if ( ( not exists $modes->{_enable_sse} ) or ( not defined $modes->{_enable_sse} ) ) {
$modes->{_enable_sse} = {};
}
$modes->{_enable_sse}->{$file_name} = 1;
next;
}
elsif ( $file_line =~ /use\s+rperlgmp\s*;/ ) {
if ( ( not exists $modes->{_enable_gmp} ) or ( not defined $modes->{_enable_gmp} ) ) {
$modes->{_enable_gmp} = {};
}
$modes->{_enable_gmp}->{$file_name} = 1;
next;
}
elsif ( $file_line =~ /use\s+rperlgsl\s*;/ ) {
if ( ( not exists $modes->{_enable_gsl} ) or ( not defined $modes->{_enable_gsl} ) ) {
$modes->{_enable_gsl} = {};
}
$modes->{_enable_gsl}->{$file_name} = 1;
next;
}
elsif ( $file_line =~ /use\s+RPerl::Support::MongoDB\s*;/ ) {
if ( ( not exists $modes->{_enable_mongodb} ) or ( not defined $modes->{_enable_mongodb} ) ) {
$modes->{_enable_mongodb} = {};
}
$modes->{_enable_mongodb}->{$file_name} = 1;
next;
}
elsif ( $file_line =~ /use\s+lib/ ) {
die
q{ERROR ECOCODE02, COMPILER, FIND DEPENDENCIES: 'use lib...' not currently supported, please set @INC using the PERL5LIB environment variable, file }
. q{'}
. $file_name . q{'}
. ', dying' . "\n";
}
if (not $use_rperl) {
last;
}
my string $package_file_name_included;
my string $package_name = $file_line;
$package_name =~ s/^\s*use\s+([\w:]+)\s*.*\s*;\s*$/$1/gxms;
my string $package_file_name = $package_name;
$package_file_name =~ s/::/\//gxms;
$package_file_name .= '.pm';
foreach my string $INC_directory (getcwd, File::Spec->catpath( '', getcwd, 'lib' ), @INC) {
$package_file_name_included = File::Spec->catpath( '', $INC_directory, $package_file_name );
if (-e $package_file_name_included) {
last;
}
else {
$package_file_name_included = q{};
}
}
if ($package_file_name_included eq q{}) {
die 'ERROR ECOCODE04, COMPILER, FIND DEPENDENCIES: Failed to find package file ', q{'}, $package_file_name, q{'},
' in @INC, included from file ', q{'}, $file_name, q{'}, ', dying', "\n";
}
my string $package_file_name_included_relative = $package_file_name_included;
$package_file_name_included_relative = post_processor__INC_paths_delete($package_file_name_included_relative, 1, $leading_lib_delete);
$package_file_name_included_relative = post_processor__absolute_path_delete( $package_file_name_included_relative );
$package_file_name_included_relative = post_processor__current_directory_path_delete( $package_file_name_included_relative );
push @{$dependencies}, $package_file_name_included_relative;
if ($find_subdependencies_recurse) {
my string_arrayref $subdependencies;
$subdependencies = find_dependencies( $package_file_name_included_relative, $find_subdependencies_recurse, $modes );
$dependencies = [ uniq @{$subdependencies}, @{$dependencies} ];
}
}
}
close $FILE_HANDLE
or die 'ERROR ECOCODE05, COMPILER, FIND DEPENDENCIES: Cannot close file ' . q{'}
. $file_name . q{'}
. ' after reading, '
. $OS_ERROR
. ', dying' . "\n";
return $dependencies;
}
sub rperl_to_rperl__parse_generate {
{ my string_hashref $RETURN_TYPE };
( my string $rperl_input_file_name, my string_hashref $rperl_output_file_name_group, my string_hashref $rperl_source_group, my string_hashref $modes ) = @ARG;
my object $rperl_ast;
if ( ( $modes->{compile} eq 'PARSE' )
or ( $modes->{compile} eq 'GENERATE' )
or ( $modes->{compile} eq 'SAVE' ) )
{
$rperl_ast = RPerl::Parser::rperl_to_ast__parse($rperl_input_file_name);
}
if ( ( $modes->{compile} eq 'GENERATE' )
or ( $modes->{compile} eq 'SAVE' ) )
{
$rperl_source_group = RPerl::Generator::ast_to_rperl__generate( $rperl_ast, $modes );
}
if ( ( $modes->{compile} eq 'SAVE' )
or ( $modes->{compile} eq 'SAVE_DEFERRED' ) )
{
save_source_files( $rperl_source_group, $rperl_output_file_name_group, $modes );
}
return $rperl_source_group;
}
sub rperl_to_xsbinary__parse_generate_compile {
{ my string_hashref $RETURN_TYPE };
( my string $rperl_input_file_name, my string_hashref $cpp_output_file_name_group, my string_hashref $cpp_source_group, my string_hashref $modes ) = @ARG;
my object $rperl_ast;
if ( ( $modes->{compile} eq 'PARSE' )
or ( $modes->{compile} eq 'GENERATE' )
or ( $modes->{compile} eq 'SAVE' )
or ( $modes->{compile} eq 'SUBCOMPILE' ) )
{
$rperl_ast = RPerl::Parser::rperl_to_ast__parse($rperl_input_file_name);
}
if ( ( $modes->{compile} eq 'GENERATE' )
or ( $modes->{compile} eq 'SAVE' )
or ( $modes->{compile} eq 'SUBCOMPILE' ) )
{
$cpp_source_group = RPerl::Generator::ast_to_cpp__generate( $rperl_ast, $modes );
}
if ( ( $modes->{compile} eq 'SAVE' )
or ( $modes->{compile} eq 'SAVE_DEFERRED' )
or ( $modes->{compile} eq 'SUBCOMPILE' )
or ( $modes->{compile} eq 'SUBCOMPILE_DEFERRED' ) )
{
save_source_files( $cpp_source_group, $cpp_output_file_name_group, $modes );
}
if ( $modes->{parallel} eq 'OPENMP' ) {
cpp_to_openmp_cpp( $cpp_output_file_name_group, $modes );
}
if ( ( $modes->{compile} eq 'SUBCOMPILE' )
or ( $modes->{compile} eq 'SUBCOMPILE_DEFERRED' ) )
{
cpp_to_xsbinary__subcompile( $cpp_output_file_name_group, $modes );
}
return $cpp_source_group;
}
sub generate_output_file_names {
{ my hashref_arrayref $RETURN_TYPE };
( my string_arrayref $input_file_names, my string_arrayref $output_file_name_prefixes, my integer $input_files_count, my string_hashref $modes ) = @ARG;
my hashref_arrayref $output_file_name_groups = [];
my string $input_file_name;
my string $input_file_name_path;
my string $input_file_name_prefix;
my string $input_file_name_suffix;
for my $i ( 0 .. ( $input_files_count - 1 ) ) {
$input_file_name = $input_file_names->[$i];
$output_file_name_groups->[$i] = {};
if ( defined $output_file_name_prefixes->[$i] ) {
( $input_file_name_prefix, $input_file_name_path, $input_file_name_suffix ) = fileparse( $output_file_name_prefixes->[$i], qr/[.][^.]*/xms );
if ( $input_file_name_prefix eq q{} ) {
die "ERROR EAR17: Invalid RPerl source code output file command-line argument specified, dying\n";
}
if ((($input_file_name_path eq './') and ((substr $output_file_name_prefixes->[$i], 0, 2) ne './')) or
(($input_file_name_path eq '.\\') and ((substr $output_file_name_prefixes->[$i], 0, 2) ne '.\\'))) {
$input_file_name_path = q{};
}
}
else {
( $input_file_name_prefix, $input_file_name_path, $input_file_name_suffix ) = fileparse( $input_file_name, qr/[.][^.]*/xms );
if ((($input_file_name_path eq './') and ((substr $input_file_name, 0, 2) ne './')) or
(($input_file_name_path eq '.\\') and ((substr $input_file_name, 0, 2) ne '.\\'))) {
$input_file_name_path = q{};
}
}
my string $output_file_name_path_prefix = $input_file_name_path . $input_file_name_prefix;
if ( $input_file_name =~ /[.]pl$/xms ) {
if ( $modes->{subcompile} eq 'ASSEMBLE' ) {
$output_file_name_groups->[$i]->{O} = $output_file_name_path_prefix . $filename_suffixes_supported->{OUTPUT_BINARY}->{O}->[0];
}
elsif ( $modes->{subcompile} eq 'ARCHIVE' ) {
$output_file_name_groups->[$i]->{O} = $output_file_name_path_prefix . $filename_suffixes_supported->{OUTPUT_BINARY}->{O}->[0];
$output_file_name_groups->[$i]->{_O_label} = ' (temporary)';
$output_file_name_groups->[$i]->{A} = $output_file_name_path_prefix . $filename_suffixes_supported->{OUTPUT_BINARY}->{A}->[0];
}
elsif ( $modes->{subcompile} eq 'SHARED' ) {
$output_file_name_groups->[$i]->{SO} = $output_file_name_path_prefix . $filename_suffixes_supported->{OUTPUT_BINARY}->{SO}->[0];
}
elsif (
( $modes->{subcompile} eq 'STATIC' )
or ( $modes->{subcompile} eq 'DYNAMIC' )
or (( $modes->{subcompile} eq 'OFF' )
and ( ( $modes->{compile} eq 'PARSE' )
or ( $modes->{compile} eq 'GENERATE' )
or ( $modes->{compile} eq 'SAVE' )
or ( $modes->{compile} eq 'SUBCOMPILE' ) )
)
)
{
if ( $OSNAME eq 'MSWin32' ) {
if ( $modes->{parallel} eq 'OFF' ) {
$output_file_name_groups->[$i]->{EXE} = $output_file_name_path_prefix . $filename_suffixes_supported->{OUTPUT_BINARY}->{EXE}->[1];
}
elsif ( $modes->{parallel} eq 'OPENMP' ) {
$output_file_name_groups->[$i]->{OPENMP_EXE}
= $output_file_name_path_prefix . $filename_suffixes_supported->{OUTPUT_BINARY}->{OPENMP_EXE}->[1];
}
}
else {
if ( $modes->{parallel} eq 'OFF' ) {
$output_file_name_groups->[$i]->{EXE} = $output_file_name_path_prefix . $filename_suffixes_supported->{OUTPUT_BINARY}->{EXE}->[0];
}
elsif ( $modes->{parallel} eq 'OPENMP' ) {
$output_file_name_groups->[$i]->{OPENMP_EXE}
= $output_file_name_path_prefix . $filename_suffixes_supported->{OUTPUT_BINARY}->{OPENMP_EXE}->[0];
}
}
}
else {
die "ERROR EAR18: Invalid compile mode '"
. $modes->{compile}
. "' and/or subcompile mode '"
. $modes->{subcompile}
. "' command-line arguments specified, dying\n";
}
}
else {
if ( $modes->{subcompile} eq 'ASSEMBLE' ) {
$output_file_name_groups->[$i]->{O} = $output_file_name_path_prefix . $filename_suffixes_supported->{OUTPUT_BINARY}->{O}->[0];
}
elsif ( $modes->{subcompile} eq 'ARCHIVE' ) {
$output_file_name_groups->[$i]->{O} = $output_file_name_path_prefix . $filename_suffixes_supported->{OUTPUT_BINARY}->{O}->[0];
$output_file_name_groups->[$i]->{_O_label} = ' (temporary)';
$output_file_name_groups->[$i]->{A} = $output_file_name_path_prefix . $filename_suffixes_supported->{OUTPUT_BINARY}->{A}->[0];
}
elsif ( $modes->{subcompile} eq 'SHARED' ) {
$output_file_name_groups->[$i]->{SO} = $output_file_name_path_prefix . $filename_suffixes_supported->{OUTPUT_BINARY}->{SO}->[0];
}
elsif ( $modes->{subcompile} eq 'STATIC' ) {
die 'ERROR EAR15: Incompatible command-line arguments provided, both --static subcompile mode flag and *.pm Perl module input file, dying'
. "\n";
}
elsif (
( $modes->{subcompile} eq 'DYNAMIC' )
or (( $modes->{subcompile} eq 'OFF' )
and ( ( $modes->{compile} eq 'PARSE' )
or ( $modes->{compile} eq 'GENERATE' )
or ( $modes->{compile} eq 'SAVE' )
or ( $modes->{compile} eq 'SUBCOMPILE' ) )
)
)
{
$output_file_name_groups->[$i]->{PMC} = $output_file_name_path_prefix . $filename_suffixes_supported->{OUTPUT_SOURCE}->{PMC}->[0];
}
else {
die "ERROR EAR18: Invalid compile mode '"
. $modes->{compile}
. "' and/or subcompile mode '"
. $modes->{subcompile}
. "' command-line arguments specified, dying\n";
}
}
if ( $modes->{ops} eq 'CPP' ) {
$output_file_name_groups->[$i]->{CPP} = $output_file_name_path_prefix . $filename_suffixes_supported->{OUTPUT_SOURCE}->{CPP}->[0];
if ( $input_file_name =~ /[.]pm$/xms ) {
$output_file_name_groups->[$i]->{H} = $output_file_name_path_prefix . $filename_suffixes_supported->{OUTPUT_SOURCE}->{H}->[0];
$output_file_name_groups->[$i]->{_H_label} = ' (if needed)';
}
if ( $modes->{parallel} eq 'OPENMP' ) {
$output_file_name_groups->[$i]->{OPENMP_CPP} = $output_file_name_path_prefix . $filename_suffixes_supported->{OUTPUT_SOURCE}->{OPENMP_CPP}->[0];
}
}
}
return $output_file_name_groups;
}
sub save_source_files {
{ my void $RETURN_TYPE };
( my string_hashref $source_group, my string_hashref $file_name_group, my string_hashref $modes ) = @ARG;
foreach my string $suffix_key ( sort keys %{$source_group} ) {
if ( ( substr $suffix_key, 0, 1 ) eq '_' ) { next; }
if ( ( not exists $file_name_group->{$suffix_key} )
or ( not defined $file_name_group->{$suffix_key} )
or ( $file_name_group->{$suffix_key} eq q{} ) )
{
croak("\nERROR ECOCOFI00, COMPILER, SAVE OUTPUT FILES: Expecting file name for suffix '$suffix_key', but received empty or no value, croaking");
}
}
if ( $modes->{ops} eq 'CPP' ) {
RPerl::verbose('SAVE PHASE 0: Final file modifications... ');
$source_group->{CPP} = post_processor_cpp__header_unneeded( $source_group );
if (defined $file_name_group->{H}) {
$source_group->{CPP} = post_processor_cpp__header_or_cpp_path( $source_group->{CPP}, $file_name_group->{H} );
}
if ( $modes->{_input_file_name} =~ /[.]pm$/xms ) {
$source_group = post_processor_cpp__types_change( $source_group, $modes );
post_processor_cpp__pmc_generate( $source_group, $file_name_group, $modes );
}
RPerl::verbose( ' done.' . "\n" );
}
RPerl::verbose('SAVE PHASE 1: Format & write files to disk...');
foreach my string $suffix_key ( sort keys %{$source_group} ) {
if ( ( substr $suffix_key, 0, 1 ) eq '_' ) { next; }
if ( ( not exists $source_group->{$suffix_key} )
or ( not defined $source_group->{$suffix_key} )
or ( $source_group->{$suffix_key} eq q{} ) )
{
croak("\nERROR ECOCOFI05, COMPILER, SAVE OUTPUT FILES: Expecting source code for suffix '$suffix_key', but received empty or no value, croaking");
}
my filehandleref $SOURCE_FILE_HANDLE;
my string $file_name = $file_name_group->{$suffix_key};
my string $source = $source_group->{$suffix_key};
if ( $file_name eq '_TEMPFILE' ) {
( $SOURCE_FILE_HANDLE, $file_name )
= tempfile( 'tempfileXXXX', SUFFIX => ( lc $suffix_key ), UNLINK => 1, TMPDIR => 1 );
print {$SOURCE_FILE_HANDLE} $source
or croak("\nERROR ECOCOFI06, COMPILER, FILE SYSTEM: Attempting to save new file '$file_name', cannot write to file,\ncroaking: $OS_ERROR");
close $SOURCE_FILE_HANDLE
or croak("\nERROR ECOCOFI09, COMPILER, FILE SYSTEM: Attempting to save new file '$file_name', cannot close file,\ncroaking: $OS_ERROR");
}
else {
if ( -f $file_name ) {
unlink $file_name
or croak(
"\nERROR ECOCOFI07, COMPILER, FILE SYSTEM: Attempting to save new file '$file_name', cannot delete existing file,\ncroaking: $OS_ERROR");
}
open $SOURCE_FILE_HANDLE, '>', $file_name
or
croak("\nERROR ECOCOFI08, COMPILER, FILE SYSTEM: Attempting to save new file '$file_name', cannot open file for writing,\ncroaking: $OS_ERROR");
print {$SOURCE_FILE_HANDLE} $source
or croak("\nERROR ECOCOFI06, COMPILER, FILE SYSTEM: Attempting to save new file '$file_name', cannot write to file,\ncroaking: $OS_ERROR");
close $SOURCE_FILE_HANDLE
or croak("\nERROR ECOCOFI09, COMPILER, FILE SYSTEM: Attempting to save new file '$file_name', cannot close file,\ncroaking: $OS_ERROR");
}
if ( ( $suffix_key eq 'PMC' ) or ( $suffix_key eq 'EXE' ) ) {
my string $perltidy_path = undef;
$perltidy_path = can_run('perltidy');
if ( defined $perltidy_path ) {
system $perltidy_path, '-pbp', '--ignore-side-comment-lengths', '--converge', '-l=' . RPerl::Generator::PERLTIDY_LINE_WIDTH(), '-b', '-nst', q{-bext='/'}, '-q', $file_name;
}
else {
RPerl::warning( "\n" . 'WARNING WCOCOFO00, COMPILER, PERL CODE FORMATTING: Perltidy command `perltidy` not found, abandoning formatting' . "\n" );
}
}
elsif ( ( $suffix_key eq 'H' ) or ( $suffix_key eq 'CPP' ) ) {
my string $astyle_path = can_run('astyle');
if ( defined $astyle_path ) {
system $astyle_path, '-q', '--keep-one-line-blocks', '--keep-one-line-statements', $file_name;
if ( -f $file_name . '.orig' ) {
unlink( $file_name . '.orig' )
or croak( "\n"
. 'ERROR ECOCOFI10, COMPILER, FILE SYSTEM: Cannot delete Artistic Style original file ' . q{'}
. $file_name . '.orig' . q{'} . ',' . "\n"
. 'croaking:'
. $OS_ERROR );
}
}
else {
RPerl::warning( 'WARNING WCOCOFO01, COMPILER, C++ CODE FORMATTING: Artistic Style command `astyle` not found, abandoning formatting' . "\n" );
}
}
}
RPerl::verbose( ' done.' . "\n" );
return;
}
sub post_processor_cpp__header_unneeded {
{ my string $RETURN_TYPE };
( my string $source_group ) = @ARG;
if ((not exists $source_group->{H}) or (not defined $source_group->{H})) {
my string $source_group_CPP_no_header = q{};
foreach my string $source_group_CPP_line (split /\n/, $source_group->{CPP}) {
if ($source_group_CPP_line =~ m/__NEED_HEADER_PATH/) { next; }
$source_group_CPP_no_header .= $source_group_CPP_line . "\n";
}
return $source_group_CPP_no_header;
}
else {
return $source_group->{CPP};
}
}
sub post_processor_cpp__header_or_cpp_path {
{ my string $RETURN_TYPE };
( my string $source_CPP, my string $file_path ) = @ARG;
if ( $OSNAME eq 'MSWin32' ) {
if ( ( substr $file_path, 0, 2 ) eq q{.\\} ) {
substr $file_path, 0, 2, q{};
}
}
else {
if ( ( substr $file_path, 0, 2 ) eq './' ) {
substr $file_path, 0, 2, q{};
}
}
$file_path = post_processor_cpp__lib_path_delete($file_path);
$source_CPP =~ s/__NEED_HEADER_PATH/$file_path/gxms;
$source_CPP =~ s/__NEED_CPP_PATH/$file_path/gxms;
return $source_CPP;
}
sub post_processor_cpp__lib_path_delete {
{ my string $RETURN_TYPE };
( my string $path ) = @ARG;
if ( ( substr $path, 0, 4 ) eq 'lib\\' ) {
substr $path, 0, 4, q{};
}
elsif ( ( substr $path, 0, 6 ) eq '.\\lib\\' ) {
substr $path, 0, 6, q{};
}
elsif ( ( substr $path, 0, 9 ) eq 'blib\\lib\\' ) {
substr $path, 0, 9, q{};
}
elsif ( ( substr $path, 0, 11 ) eq '.\\blib\\lib\\' ) {
substr $path, 0, 11, q{};
}
elsif ( ( substr $path, 0, 4 ) eq 'lib/' ) {
substr $path, 0, 4, q{};
}
elsif ( ( substr $path, 0, 6 ) eq './lib/' ) {
substr $path, 0, 6, q{};
}
elsif ( ( substr $path, 0, 9 ) eq 'blib/lib/' ) {
substr $path, 0, 9, q{};
}
elsif ( ( substr $path, 0, 11 ) eq './blib/lib/' ) {
substr $path, 0, 11, q{};
}
return $path;
}
sub post_processor_cpp__blib_path_delete {
{ my string $RETURN_TYPE };
( my string $path ) = @ARG;
if ( ( substr $path, 0, 5 ) eq 'blib\\' ) {
substr $path, 0, 5, q{};
}
elsif ( ( substr $path, 0, 7 ) eq '.\\blib\\' ) {
substr $path, 0, 7, q{};
}
elsif ( ( substr $path, 0, 5 ) eq 'blib/' ) {
substr $path, 0, 5, q{};
}
elsif ( ( substr $path, 0, 7 ) eq './blib/' ) {
substr $path, 0, 7, q{};
}
return $path;
}
sub post_processor_cpp__types_change {
{ my string_hashref $RETURN_TYPE };
( my string_hashref $source_group, my string_hashref $modes ) = @ARG;
my string $mode_tagline = $modes->{ops} . 'OPS_' . $modes->{types} . 'TYPES';
if ( exists $source_group->{H} ) {
$source_group->{H} =~ s/PERLOPS_PERLTYPES/$mode_tagline/gxms;
}
if ( exists $source_group->{CPP} ) {
$source_group->{CPP} =~ s/PERLOPS_PERLTYPES/$mode_tagline/gxms;
}
return $source_group;
}
sub post_processor_perl__comments_whitespace_delete {
{ my string $RETURN_TYPE };
( my string $input_source_code ) = @ARG;
my string_arrayref $input_source_code_split = [ ( split /\n/xms, $input_source_code ) ];
my string_arrayref $input_source_code_split_tmp = [];
my boolean $inside_comment = 0;
my boolean $inside_string = 0;
my boolean $inside_heredoc = 0;
my boolean $inside_indent;
my string $open_quote_string;
my string $open_quote_heredoc;
foreach my string $input_source_code_line ( @{$input_source_code_split} ) {
if ($inside_comment) {
if ( $input_source_code_line =~ m/^=cut$/xms ) { $inside_comment = 0; next; }
next;
}
if ($inside_heredoc) {
if ( $input_source_code_line eq $open_quote_heredoc ) { $inside_heredoc = 0; }
push @{$input_source_code_split_tmp}, $input_source_code_line;
next;
}
if ( $input_source_code_line =~ m/^\s*$/xms ) { next; }
if ( $input_source_code_line =~ m/^\s*[
if ( $input_source_code_line =~ m/^=\w+/xms ) { $inside_comment = 1; next; }
$inside_indent = 1;
my string $input_source_code_line_tmp = q{};
my string $current_character;
my string $next_character;
my boolean $advance_one = 0;
for my integer $i ( 0 .. ( ( length $input_source_code_line ) - 1 ) ) {
$current_character = substr $input_source_code_line, $i, 1;
if ( ($inside_indent) and ( $current_character !~ m/[ \t]/xms ) ) {
$inside_indent = 0;
}
if ($advance_one) {
$advance_one--;
$input_source_code_line_tmp .= $current_character;
next;
}
if ( not $inside_string ) {
if ( $current_character eq '#' ) {
$next_character = substr $input_source_code_line, ( $i + 1 ), 1;
if ( ( $next_character eq '!' ) or ( $next_character eq '#' ) ) { $advance_one = 1; } # do not delete shebang #! or critics ##
else { last; }
}
elsif ( $current_character eq q{'} ) {
$inside_string = 1;
$open_quote_string = q{'};
}
elsif ( $current_character eq q{"} ) {
$inside_string = 1;
$open_quote_string = q{"};
}
elsif ( $current_character eq 'q' ) {
$next_character = substr $input_source_code_line, ( $i + 1 ), 1;
if ( $next_character eq '{' ) {
$inside_string = 1;
$advance_one = 1;
$open_quote_string = 'q{';
}
}
elsif ( $current_character eq '<' ) {
$next_character = substr $input_source_code_line, ( $i + 1 ), 1;
if ( $next_character eq '<' ) {
$inside_heredoc = 1;
$open_quote_heredoc = substr $input_source_code_line, ( $i + 2 );
if ( ( substr $open_quote_heredoc, 0, 1 ) eq q{'} ) { substr $open_quote_heredoc, 0, 1, q{}; }
if ( ( substr $open_quote_heredoc, 0, 1 ) eq q{"} ) { substr $open_quote_heredoc, 0, 1, q{}; }
$open_quote_heredoc =~ s/\s+$//xms;
if ( ( substr $open_quote_heredoc, -1, 1 ) eq q{;} ) { substr $open_quote_heredoc, -1, 1, q{}; }
$open_quote_heredoc =~ s/\s+$//xms;
if ( ( substr $open_quote_heredoc, -1, 1 ) eq q{'} ) { substr $open_quote_heredoc, -1, 1, q{}; }
if ( ( substr $open_quote_heredoc, -1, 1 ) eq q{"} ) { substr $open_quote_heredoc, -1, 1, q{}; }
}
}
elsif ( ( not $inside_indent ) and ( $current_character =~ m/[ \t]/xms ) ) {
$next_character = substr $input_source_code_line, ( $i + 1 ), 1;
if ( $next_character =~ m/[ \t]/xms ) { next; }
}
}
else {
if ( ( $current_character eq q{'} ) and ( $open_quote_string eq q{'} ) ) { $inside_string = 0; }
elsif ( ( $current_character eq q{"} ) and ( $open_quote_string eq q{"} ) ) { $inside_string = 0; }
elsif ( ( $current_character eq '}' ) and ( $open_quote_string eq 'q{' ) ) { $inside_string = 0; }
}
$input_source_code_line_tmp .= $current_character;
}
$input_source_code_line = $input_source_code_line_tmp;
$input_source_code_line =~ s/[ \t]+$//xms;
push @{$input_source_code_split_tmp}, $input_source_code_line;
}
return join "\n", @{$input_source_code_split_tmp};
}
sub post_processor_cpp__comments_whitespace_delete {
{ my string $RETURN_TYPE };
( my string $input_source_code ) = @ARG;
my string_arrayref $input_source_code_split = [ ( split /\n/xms, $input_source_code ) ];
my string_arrayref $input_source_code_split_tmp = [];
my boolean $inside_comment = 0;
my boolean $inside_string = 0;
my string $open_quote;
foreach my string $input_source_code_line ( @{$input_source_code_split} ) {
if ($inside_comment) {
if ( $input_source_code_line =~ m!\*/!xms ) {
$input_source_code_line =~ s!^(.*\*/)!!xms;
$inside_comment = 0;
}
else { next; }
}
if ( $input_source_code_line =~ m/^\s*$/xms ) { next; }
if ( $input_source_code_line =~ m!^\s*//!xms ) { next; }
if ( $input_source_code_line =~ m!^\s*/\*.*\*/\s*$!xms ) { next; }
my string $input_source_code_line_tmp = q{};
my string $current_character;
my string $next_character;
my boolean $advance_one = 0;
for my integer $i ( 0 .. ( ( length $input_source_code_line ) - 1 ) ) {
$current_character = substr $input_source_code_line, $i, 1;
if ($advance_one) {
$advance_one = 0;
$input_source_code_line_tmp .= $current_character;
next;
}
if ( not $inside_string ) {
if ($inside_comment) {
if ( $current_character eq '*' ) {
$next_character = substr $input_source_code_line, ( $i + 1 ), 1;
if ( $next_character eq '/' ) {
$advance_one = 1;
$inside_comment = 0;
next;
}
}
else { next; }
}
else {
if ( $current_character eq '/' ) {
$next_character = substr $input_source_code_line, ( $i + 1 ), 1;
if ( $next_character eq '/' ) { last; }
elsif ( $next_character eq '*' ) {
$advance_one = 1;
$inside_comment = 1;
next;
}
}
elsif ( $current_character eq q{'} ) {
$inside_string = 1;
$open_quote = q{'};
}
elsif ( $current_character eq q{"} ) {
$inside_string = 1;
$open_quote = q{"};
}
}
}
else {
if ( ( $current_character eq q{'} ) and ( $open_quote eq q{'} ) ) { $inside_string = 0; }
elsif ( ( $current_character eq q{"} ) and ( $open_quote eq q{"} ) ) { $inside_string = 0; }
elsif ( $current_character eq '\\' ) {
$next_character = substr $input_source_code_line, ( $i + 1 ), 1;
if ( ( $next_character eq q{'} ) and ( $open_quote eq q{'} ) ) { $advance_one = 1; }
if ( ( $next_character eq q{"} ) and ( $open_quote eq q{"} ) ) { $advance_one = 1; }
}
}
$input_source_code_line_tmp .= $current_character;
}
$input_source_code_line = $input_source_code_line_tmp;
$input_source_code_line =~ s/[ \t]+$//xms;
push @{$input_source_code_split_tmp}, $input_source_code_line;
}
return join "\n", @{$input_source_code_split_tmp};
}
sub post_processor__INC_paths_delete {
{ my string $RETURN_TYPE };
( my string $input_path, my boolean $leading_slash_delete, my boolean $leading_lib_delete ) = @ARG;
my @INC_copy = @INC;
if ( $OSNAME eq 'MSWin32' ) {
$input_path =~ s/\\/\//gxms;
}
foreach my string $INC_directory (@INC_copy) {
if ((not $leading_lib_delete) and ((substr $INC_directory, -3, 3) eq 'lib')) {
substr $INC_directory, -3, 3, q{};
}
if ($INC_directory eq q{}) {
next;
}
if ((substr $input_path, 0, (length $INC_directory)) eq $INC_directory ) {
substr $input_path, 0, ( length $INC_directory ), q{};
if ($leading_slash_delete and ((substr $input_path, 0, 1) eq '/')) {
substr $input_path, 0, 1, q{};
}
last;
}
}
return $input_path;
}
sub post_processor__absolute_path_delete {
{ my string $RETURN_TYPE };
( my string $input_path ) = @ARG;
if ( $OSNAME eq 'MSWin32' ) {
$input_path =~ s/\\/\//gxms;
}
my string $current_working_directory = getcwd;
if ( ( substr $input_path, 0, ( length $current_working_directory ) ) eq $current_working_directory ) {
return substr $input_path, ( ( length $current_working_directory ) + 1 );
}
return $input_path;
}
sub post_processor__current_directory_path_delete {
{ my string $RETURN_TYPE };
( my string $input_path ) = @ARG;
if ( $OSNAME eq 'MSWin32' ) {
$input_path =~ s/\\/\//gxms;
}
if ( ( substr $input_path, 0, 2 ) eq './' ) {
return substr $input_path, 2;
}
return $input_path;
}
sub post_processor_cpp__pmc_generate {
{ my void $RETURN_TYPE };
( my string_hashref $source_group, my string_hashref $file_name_group, my string_hashref $modes ) = @ARG;
if ( $modes->{subcompile} eq 'DYNAMIC' ) {
if ( ( exists $source_group->{PMC} ) and ( defined $source_group->{PMC} ) and ( $source_group->{PMC} ne q{} ) ) {
die 'ERROR ECOCOFI01, COMPILER, SAVE OUTPUT FILES, MODULE TEMPLATE COPY: Received non-empty PMC source, dying' . "\n";
}
my string_arrayref $module_names_split = [ ( split /\n/, $source_group->{_package_names} ) ];
my string_arrayref $module_names_underscores_split = [ ( split /\n/, $source_group->{_package_names_underscores} ) ];
my integer $module_count = scalar @{$module_names_split};
my string $module_name = shift @{$module_names_split};
my string $module_name_underscores = shift @{$module_names_underscores_split};
my integer $i = 0;
while ( defined $module_name_underscores ) {
my string $module_pmc_filename_manual;
if ( $module_count == 1 ) {
$module_pmc_filename_manual = $RPerl::INCLUDE_PATH . '/RPerl/CompileUnit/Module.pmc.CPPOPS_DUALTYPES_TEMPLATE';
}
else {
if ( $i == ( $module_count - 1 ) ) {
$module_pmc_filename_manual = $RPerl::INCLUDE_PATH . '/RPerl/CompileUnit/Module.pmc.CPPOPS_DUALTYPES_TEMPLATE_MONOLITH';
}
else {
$module_pmc_filename_manual = $RPerl::INCLUDE_PATH . '/RPerl/CompileUnit/Module.pmc.CPPOPS_DUALTYPES_TEMPLATE_MONOLITH_SECONDARY';
}
}
if ( not -f $module_pmc_filename_manual ) {
die 'ERROR ECOCOFI02, COMPILER, SAVE OUTPUT FILES, MODULE TEMPLATE COPY: File not found, ' . q{'}
. $module_pmc_filename_manual . q{'} . "\n"
. ', dying' . "\n";
}
open my filehandleref $FILE_HANDLE, '<', $module_pmc_filename_manual
or die 'ERROR ECOCOFI03, COMPILER, SAVE OUTPUT FILES, MODULE TEMPLATE COPY: Cannot open file '
. $module_pmc_filename_manual
. ' for reading, '
. $OS_ERROR
. ', dying' . "\n";
my string $file_line;
my string $file_string = q{};
my string $pm_file_path = $file_name_group->{PMC};
my boolean $has_rperl_config = 0;
chop $pm_file_path;
while ( $file_line = <$FILE_HANDLE> ) {
$file_line =~ s/RPerl::CompileUnit::Module/$module_name/gxms;
$file_line =~ s/RPerl__CompileUnit__Module/$module_name_underscores/gxms;
if ( $file_line eq
( '# <<< OO PROPERTIES, ACCESSORS & MUTATORS, SHIMS >>> # <<< CHANGE_ME: add real shims after this line or delete it >>>' . "\n" ) )
{
if ( ( exists $source_group->{_PMC_accessors_mutators_shims}->{$module_name_underscores} )
and ( defined $source_group->{_PMC_accessors_mutators_shims}->{$module_name_underscores} ) )
{
$file_line
= ( substr $file_line, 0, 52 ) . "\n" . $source_group->{_PMC_accessors_mutators_shims}->{$module_name_underscores} . "\n\n";
}
else { $file_line = undef; }
}
elsif (
$file_line eq ( '# <<< OO PROPERTIES, SUBROUTINES, SHIMS >>> # <<< CHANGE_ME: add real shims after this line or delete it >>>' . "\n" ) )
{
if ( ( exists $source_group->{_PMC_subroutines_shims}->{$module_name_underscores} )
and ( defined $source_group->{_PMC_subroutines_shims}->{$module_name_underscores} ) )
{
$file_line = ( substr $file_line, 0, 43 ) . "\n" . $source_group->{_PMC_subroutines_shims}->{$module_name_underscores} . "\n\n";
}
else { $file_line = undef; }
}
elsif ( $file_line eq ( '# <<< CHANGE_ME: add OO ISA here >>>' . "\n" ) ) {
$file_line = 'our @ISA = qw(' . $source_group->{_parent_names}->{$module_name_underscores} . ');' . "\n";
}
elsif ( $file_line eq ( '# <<< CHANGE_ME: add distribution-specific config include here >>>' . "\n" ) ) {
my string $distribution_package = ( split /::/, $source_group->{_package_name} )[0];
my string $eval_line = q{};
$eval_line .= 'use ' . $distribution_package . '::Config; ';
$eval_line .= 'if ((defined $' . $distribution_package . '::Config::IS_RPERL_CONFIG) and ($' . $distribution_package . '::Config::IS_RPERL_CONFIG)) { return q{YES_CONFIG}; } else { return 0; }';
my integer $eval_retval = eval $eval_line;
if ($EVAL_ERROR ne q{}) {
$file_line = undef;
$has_rperl_config = 0;
}
elsif (defined $eval_retval) {
if (not $eval_retval) {
$file_line = undef;
$has_rperl_config = 0;
}
elsif ($eval_retval eq 'YES_CONFIG') {
$file_line = 'use ' . $distribution_package . '::Config;' . "\n";
$has_rperl_config = 1;
}
else {
die 'ERROR ECOCOFI11, COMPILER, SAVE OUTPUT FILES, MODULE TEMPLATE COPY: Attempt to check for distribution-specific config file '
. q{'} . $distribution_package . '::Config' . q{'} . ' returned invalid value:' . "\n" . $eval_retval . "\n" . 'dying' . "\n";
}
}
else {
die 'ERROR ECOCOFI11, COMPILER, SAVE OUTPUT FILES, MODULE TEMPLATE COPY: Attempt to check for distribution-specific config file '
. q{'} . $distribution_package . '::Config' . q{'} . ' returned undefined value, dying' . "\n";
}
}
elsif ( $file_line eq ( '# <<< CHANGE_ME: add use Inline path & args here >>>' . "\n" ) ) {
$file_line = ' my $eval_string = <<"EOF";' . "\n";
$file_line .= 'package main;' . "\n";
$file_line .= 'use RPerl::Inline;' . "\n";
my string $cpp_file_path = $file_name_group->{CPP};
my string $cpp_file_path_noblib = q{};
my boolean $has_blib = 0;
if ($has_rperl_config) {
$cpp_file_path = post_processor_cpp__lib_path_delete($cpp_file_path);
}
else {
$cpp_file_path_noblib = post_processor_cpp__blib_path_delete($cpp_file_path);
if ($cpp_file_path_noblib ne $cpp_file_path) {
$has_blib = 1;
}
}
(my string $cpp_volume, my string $cpp_directories, my string $cpp_file) = File::Spec->splitpath( $cpp_file_path, my boolean $no_file = 0 );
my string $cpp_directories_char0 = substr $cpp_directories, 0, 1;
if ((($cpp_volume ne q{}) or ($cpp_directories_char0 eq '/') or ($cpp_directories_char0 eq '\\')) or
($cpp_directories_char0 eq '.')) {
$file_line .= q<BEGIN { RPerl::diag("[[[ BEGIN 'use Inline' STAGE for '> . $cpp_file_path . q<' ]]]\n" x 1); }> . "\n";
$file_line .= q{use Inline (CPP => '} . $cpp_file_path . q{', \%RPerl::Inline::ARGS);} . "\n";
$file_line .= q{RPerl::diag("[[[ END 'use Inline' STAGE for '} . $cpp_file_path . q{' ]]]\n" x 1);} . "\n";
}
else {
if ($has_rperl_config) {
if ( $OSNAME eq 'MSWin32' ) {
$file_line .= q<BEGIN { RPerl::diag("[[[ BEGIN 'use Inline' STAGE for '> . $cpp_file_path . q<' ]]]\n" x 1); }> . "\n";
$file_line .= q{use Inline (CPP => '$main::INCLUDE_PATH' . '\\' . '} . $cpp_file_path . q{', \%RPerl::Inline::ARGS);} . "\n";
$file_line .= q{RPerl::diag("[[[ END 'use Inline' STAGE for '} . $cpp_file_path . q{' ]]]\n" x 1);} . "\n";
}
else {
$file_line .= q<BEGIN { RPerl::diag("[[[ BEGIN 'use Inline' STAGE for '> . $cpp_file_path . q<' ]]]\n" x 1); }> . "\n";
$file_line .= q{use Inline (CPP => '$main::INCLUDE_PATH' . '/' . '} . $cpp_file_path . q{', \%RPerl::Inline::ARGS);} . "\n";
$file_line .= q{RPerl::diag("[[[ END 'use Inline' STAGE for '} . $cpp_file_path . q{' ]]]\n" x 1);} . "\n";
}
}
else {
if (not $has_blib) {
if ( $OSNAME eq 'MSWin32' ) {
$cpp_file_path = 'blib\\' . $cpp_file_path;
}
else {
$cpp_file_path = 'blib/' . $cpp_file_path;
}
}
if ( $cpp_file_path !~ /\// ) {
if ( $OSNAME eq 'MSWin32' ) {
$cpp_file_path = q{.\\} . $cpp_file_path;
}
else {
$cpp_file_path = q{./} . $cpp_file_path;
}
}
if ( $cpp_file_path_noblib !~ /\// ) {
if ( $OSNAME eq 'MSWin32' ) {
$cpp_file_path_noblib = q{.\\} . $cpp_file_path_noblib;
}
else {
$cpp_file_path_noblib = q{./} . $cpp_file_path_noblib;
}
}
my $file_line_prepend = q{};
$file_line_prepend .= q< my $cpp_file_path = '> . $cpp_file_path . q<';> . "\n";
$file_line_prepend .= q< my $cpp_file_path_noblib = '> . $cpp_file_path_noblib . q<';> . "\n";
$file_line_prepend .= q< if (not ((-e $cpp_file_path) and (-f $cpp_file_path))) { $cpp_file_path = $cpp_file_path_noblib; } # fall back to non-blib, if blib does not exist> . "\n";
$file_line = $file_line_prepend . $file_line;
$file_line .= q<BEGIN { RPerl::diag("[[[ BEGIN 'use Inline' STAGE for '> . $cpp_file_path_noblib . q<' ]]]\n" x 1); }> . "\n";
$file_line .= q{use Inline (CPP => \$cpp_file_path, \%RPerl::Inline::ARGS);} . "\n";
$file_line .= q{RPerl::diag("[[[ END 'use Inline' STAGE for '} . $cpp_file_path_noblib . q{' ]]]\n" x 1);} . "\n";
}
}
$file_line .= '1;' . "\n";
$file_line .= 'EOF' . "\n";
}
elsif ( $file_line eq ( '# <<< CHANGE_ME: add user-defined includes here >>>' . "\n" ) ) {
if ( ( exists $source_group->{_PMC_includes}->{$module_name_underscores} )
and ( defined $source_group->{_PMC_includes}->{$module_name_underscores} ) )
{
$file_line = $source_group->{_PMC_includes}->{$module_name_underscores} . "\n\n";
}
else { $file_line = undef; }
}
elsif ( $file_line eq ( ' # <<< CHANGE_ME: enable optional SSE support here >>>' . "\n" ) ) {
$pm_file_path = post_processor__INC_paths_delete($pm_file_path, 1, 0);
$pm_file_path = post_processor__absolute_path_delete($pm_file_path);
$pm_file_path = post_processor__current_directory_path_delete($pm_file_path);
if ( ( exists $modes->{_enable_sse} )
and ( defined $modes->{_enable_sse} )
and ( exists $modes->{_enable_sse}->{$pm_file_path} )
and ( defined $modes->{_enable_sse}->{$pm_file_path} )
and $modes->{_enable_sse}->{$pm_file_path} )
{
$file_line = q( $RPerl::Inline::ARGS{optimize} .= ' -mfpmath=sse -msse3'; # enable SSE support) . "\n";
$file_line
.= q( $RPerl::Inline::ARGS{auto_include} = ['#include <immintrin.h>', @{$RPerl::Inline::ARGS{auto_include}}]; # enable SSE support)
. "\n";
}
else { $file_line = undef; }
}
elsif ( $file_line eq ( ' # <<< CHANGE_ME: enable optional GMP support here >>>' . "\n" ) ) {
$pm_file_path = post_processor__INC_paths_delete($pm_file_path, 1, 0);
$pm_file_path = post_processor__absolute_path_delete($pm_file_path);
$pm_file_path = post_processor__current_directory_path_delete($pm_file_path);
if ( ( exists $modes->{_enable_gmp} )
and ( defined $modes->{_enable_gmp} )
and ( exists $modes->{_enable_gmp}->{$pm_file_path} )
and ( defined $modes->{_enable_gmp}->{$pm_file_path} )
and $modes->{_enable_gmp}->{$pm_file_path} )
{
$file_line = q( $RPerl::Inline::ARGS{libs} = '-L' . $RPerl::Inline::gmp_lib_dir . ' -lgmpxx -lgmp'; # enable GMP support) . "\n";
$file_line .= q( $RPerl::Inline::ARGS{inc} .= ' -I' . $RPerl::Inline::gmp_include_dir; # enable GMP support) . "\n";
$file_line
.= q( $RPerl::Inline::ARGS{auto_include} = [ @{ $RPerl::Inline::ARGS{auto_include} }, '#include <gmpxx.h>', '#include <gmp.h>' ]; # enable GMP support)
. "\n";
}
else { $file_line = undef; }
}
elsif ( $file_line eq ( ' # <<< CHANGE_ME: enable optional GSL support here >>>' . "\n" ) ) {
$pm_file_path = post_processor__INC_paths_delete($pm_file_path, 1, 0);
$pm_file_path = post_processor__absolute_path_delete($pm_file_path);
$pm_file_path = post_processor__current_directory_path_delete($pm_file_path);
if ( ( exists $modes->{_enable_gsl} )
and ( defined $modes->{_enable_gsl} )
and ( exists $modes->{_enable_gsl}->{$pm_file_path} )
and ( defined $modes->{_enable_gsl}->{$pm_file_path} )
and $modes->{_enable_gsl}->{$pm_file_path} )
{
$file_line = q( $RPerl::Inline::ARGS{libs} = '-L' . $RPerl::Inline::gsl_lib_dir . ' -lgsl -lgslcblas -lm'; # enable GSL support) . "\n";
$file_line .= q( $RPerl::Inline::ARGS{inc} .= ' -I' . $RPerl::Inline::gsl_include_dir; # enable GSL support) . "\n";
$file_line
.= q( $RPerl::Inline::ARGS{auto_include} = [ @{ $RPerl::Inline::ARGS{auto_include} }, '#include <gsl_matrix.h>', '#include <gsl_blas.h>' ]; # enable GSL support)
. "\n";
}
else { $file_line = undef; }
}
elsif ( $file_line eq ( ' # <<< CHANGE_ME: enable optional MongoDB support here >>>' . "\n" ) ) {
$pm_file_path = post_processor__INC_paths_delete($pm_file_path, 1, 0);
$pm_file_path = post_processor__absolute_path_delete($pm_file_path);
$pm_file_path = post_processor__current_directory_path_delete($pm_file_path);
if ( ( exists $modes->{_enable_mongodb} )
and ( defined $modes->{_enable_mongodb} )
and ( exists $modes->{_enable_mongodb}->{$pm_file_path} )
and ( defined $modes->{_enable_mongodb}->{$pm_file_path} )
and $modes->{_enable_mongodb}->{$pm_file_path} )
{
$file_line = q( $RPerl::Inline::ARGS{libs} = '$(pkg-config --libs libmongocxx) -Wl,-rpath,' . $RPerl::Inline::mongodb_lib_dir;
$file_line .= q( $RPerl::Inline::ARGS{inc} .= ' $(pkg-config --cflags libmongocxx)';
$file_line .= q( $RPerl::Inline::ARGS{auto_include} = [ @{ $RPerl::Inline::ARGS{auto_include} }, ) .
q('#undef exp', '#include <mongocxx/client.hpp>', '#include <mongocxx/stdx.hpp>', '#include <mongocxx/uri.hpp>', ) .
q('#include <mongocxx/instance.hpp>', '#include <bsoncxx/json.hpp>', '#include <bsoncxx/builder/stream/document.hpp>' ]; # enable MongoDB support) . "\n";
}
else { $file_line = undef; }
}
if ( defined $file_line ) { $source_group->{PMC} .= $file_line; }
}
close $FILE_HANDLE
or die 'ERROR ECOCOFI04, COMPILER, SAVE OUTPUT FILES, MODULE TEMPLATE COPY: Cannot close file '
. $module_pmc_filename_manual
. ' after reading, '
. $OS_ERROR
. ', dying' . "\n";
$module_name = shift @{$module_names_split};
$module_name_underscores = shift @{$module_names_underscores_split};
$i++;
}
}
return;
}
sub cpp_to_openmp_cpp {
{ my void $RETURN_TYPE };
( my string_hashref $cpp_output_file_name_group, my string_hashref $modes ) = @ARG;
RPerl::diag( q{in Compiler::cpp_to_openmp_cpp(), received $cpp_output_file_name_group =} . "\n" . Dumper($cpp_output_file_name_group) . "\n" );
RPerl::verbose('PARALLELIZE: Generate OpenMP Code... ');
my string $polycc_path = can_run('polycc');
if ( not defined $polycc_path ) {
die 'ERROR Exxxxx, COMPILER, PARALLELIZATION: Pluto PolyCC command `polycc` not found, dying';
}
my string $polycc_command = $polycc_path . q{ } . $cpp_output_file_name_group->{CPP} . ' -o ' . $cpp_output_file_name_group->{OPENMP_CPP} . ' --parallel --tile';
RPerl::diag( 'in Compiler::cpp_to_openmp_cpp(), have $polycc_command =' . "\n\n" . $polycc_command . "\n" );
my string $polycc_command_stdout = q{};
my string $polycc_command_stderr = q{};
run3( $polycc_command, \undef, \$polycc_command_stdout, \$polycc_command_stderr );
my $test_exit_status = $CHILD_ERROR >> 8;
RPerl::verbose( ' done.' . "\n" );
my boolean $polycc_command_stdout_content = ( ( defined $polycc_command_stdout ) and ( $polycc_command_stdout =~ m/[^\s]+/g ) );
my boolean $polycc_command_stderr_content = ( ( defined $polycc_command_stderr ) and ( $polycc_command_stderr =~ m/[^\s]+/g ) );
if ( $polycc_command_stdout_content or $polycc_command_stderr_content ) {
RPerl::diag("\n");
if ($polycc_command_stdout_content) {
RPerl::diag( '[[[ POLYCC STDOUT ]]]' . "\n\n" . $polycc_command_stdout . "\n" );
}
if ($polycc_command_stderr_content) {
RPerl::diag( '[[[ POLYCC STDERR ]]]' . "\n\n" . $polycc_command_stderr . "\n" );
}
}
if ($test_exit_status) {
if ( not( $polycc_command_stdout_content or $polycc_command_stderr_content ) ) {
RPerl::diag( "\n" . '[[[ POLYCC STDOUT & STDERR ARE BOTH EMPTY ]]]' . "\n\n" );
}
croak 'ERROR Exxxxx, COMPILER, POLYCC: Pluto PolyCC compiler returned error code,' . "\n"
. 'please run again with `rperl -D` command or RPERL_DEBUG=1 environmental variable for error messages if none appear above,' . "\n"
. 'croaking';
}
if (( not -e $cpp_output_file_name_group->{OPENMP_CPP} ) or ( not -f $cpp_output_file_name_group->{OPENMP_CPP} ) or ( not -T $cpp_output_file_name_group->{OPENMP_CPP} )) {
die 'ERROR Exxxxx, COMPILER, PARALLELIZATION: Missing or invalid Pluto PolyCC output file, ' . q{'} . $cpp_output_file_name_group->{OPENMP_CPP} . q{'} . "\n" . ', dying' . "\n";
}
open my filehandleref $FILE_HANDLE_POLYCC, '<', $cpp_output_file_name_group->{OPENMP_CPP}
or die 'ERROR Exxxxx, COMPILER, PARALLELIZATION: Cannot open Pluto PolyCC output file ' . q{'} . $cpp_output_file_name_group->{OPENMP_CPP} . q{'} . ' for reading,' . $OS_ERROR . ', dying' . "\n";
my string $file_line_polycc;
my string $string_polycc = q{};
while ( $file_line_polycc = <$FILE_HANDLE_POLYCC> ) {
$file_line_polycc =~ s/min/polyccmin/gxms;
$file_line_polycc =~ s/max/polyccmax/gxms;
$string_polycc .= $file_line_polycc;
}
close $FILE_HANDLE_POLYCC
or die 'ERROR Exxxxx, COMPILER, PARALLELIZATION: Cannot close file ' . q{'} . $cpp_output_file_name_group->{OPENMP_CPP} . q{'} . ' after reading, ' . $OS_ERROR . ', dying' . "\n";
open $FILE_HANDLE_POLYCC, '>', $cpp_output_file_name_group->{OPENMP_CPP}
or die 'ERROR Exxxxx, COMPILER, PARALLELIZATION: Cannot open Pluto PolyCC output file ' . q{'} . $cpp_output_file_name_group->{OPENMP_CPP} . q{'} . ' for writing,' . $OS_ERROR . ', dying' . "\n";
print {$FILE_HANDLE_POLYCC} $string_polycc;
close $FILE_HANDLE_POLYCC
or die 'ERROR Exxxxx, COMPILER, PARALLELIZATION: Cannot close file ' . q{'} . $cpp_output_file_name_group->{OPENMP_CPP} . q{'} . ' after writing, ' . $OS_ERROR . ', dying' . "\n";
return;
}
sub cpp_to_xsbinary__subcompile {
{ my void $RETURN_TYPE };
( my string_hashref $cpp_output_file_name_group, my string_hashref $modes ) = @ARG;
if ( ( $modes->{_input_file_name} =~ /[.]pl$/xms ) or ( $modes->{subcompile} ne 'DYNAMIC' ) ) {
RPerl::verbose('SUBCOMPILE: Generate binary... ');
if ( $modes->{subcompile} eq 'OFF' ) {
croak 'ERROR ECOCOSU00, COMPILER, SUBCOMPILE: Received incorrect subcompile mode OFF while inside subcompile subroutine, croaking';
}
elsif ( ( $modes->{subcompile} ne 'ASSEMBLE' )
and ( $modes->{subcompile} ne 'ARCHIVE' )
and ( $modes->{subcompile} ne 'SHARED' )
and ( $modes->{subcompile} ne 'STATIC' )
and ( $modes->{subcompile} ne 'DYNAMIC' ) )
{
croak 'ERROR ECOCOSU01, COMPILER, SUBCOMPILE: Received invalid subcompile mode ' . q{'}
. $modes->{subcompile} . q{'}
. ' while inside subcompile subroutine, croaking';
}
my string $subcompile_command = $modes->{CXX};
my string $subcompile_command_append = q{};
if ( ( $modes->{subcompile} eq 'ASSEMBLE' )
or ( $modes->{subcompile} eq 'ARCHIVE' ) )
{
$subcompile_command .= q{ } . '-c';
}
elsif (( $modes->{subcompile} eq 'STATIC' )
or ( $modes->{subcompile} eq 'DYNAMIC' ) )
{
$subcompile_command .= q{ } . '-pthread';
}
my string $ccflags = [ config_re('ccflags') ]->[0];
substr $ccflags, 0, 9, q{};
substr $ccflags, -1, 1, q{};
$subcompile_command .= q{ } . $ccflags;
$subcompile_command .= q{ } . '-xc++';
$subcompile_command .= q{ } . '-I"' . $RPerl::BASE_PATH . '"';
$subcompile_command .= q{ } . '-I"' . $RPerl::INCLUDE_PATH . '"';
$subcompile_command .= q{ } . '-I. -Ilib';
my string $pl_file_path = $modes->{_input_file_name};
$pl_file_path = post_processor__INC_paths_delete($pl_file_path, 1, 0);
$pl_file_path = post_processor__absolute_path_delete($pl_file_path);
$pl_file_path = post_processor__current_directory_path_delete($pl_file_path);
if ( ( exists $modes->{_enable_gmp} )
and ( defined $modes->{_enable_gmp} )
and ( exists $modes->{_enable_gmp}->{$pl_file_path} )
and ( defined $modes->{_enable_gmp}->{$pl_file_path} )
and $modes->{_enable_gmp}->{$pl_file_path} )
{
$subcompile_command .= q{ } . '-I"' . $RPerl::Inline::gmp_include_dir . '"';
}
if ( ( exists $modes->{_enable_gsl} )
and ( defined $modes->{_enable_gsl} )
and ( exists $modes->{_enable_gsl}->{$pl_file_path} )
and ( defined $modes->{_enable_gsl}->{$pl_file_path} )
and $modes->{_enable_gsl}->{$pl_file_path} )
{
$subcompile_command .= q{ } . '-I"' . $RPerl::Inline::gsl_include_dir . '"';
}
if ( ( exists $modes->{_enable_mongodb} )
and ( defined $modes->{_enable_mongodb} )
and ( exists $modes->{_enable_mongodb}->{$pl_file_path} )
and ( defined $modes->{_enable_mongodb}->{$pl_file_path} )
and $modes->{_enable_mongodb}->{$pl_file_path} )
{
$subcompile_command .= q{ } . '$(pkg-config --cflags libmongocxx)';
$subcompile_command_append .= q{ } . '$(pkg-config --libs libmongocxx) -Wl,-rpath,' . $RPerl::Inline::mongodb_lib_dir;
}
$subcompile_command .= q{ } . '-I"' . $RPerl::Inline::pcre2_include_dir . '"';
$subcompile_command .= q{ } . '-I"' . $RPerl::Inline::jpcre2_include_dir . '"';
$subcompile_command .= q{ } . $RPerl::Inline::CCFLAGSEX;
$subcompile_command .= q{ } . '-D__' . $modes->{types} . '__TYPES';
$subcompile_command .= q{ } . '-D__TYPE__INTEGER__' . $modes->{type_integer};
$subcompile_command .= q{ } . '-D__TYPE__NUMBER__' . $modes->{type_number};
$subcompile_command .= q{ } . $RPerl::Inline::ARGS{optimize};
$subcompile_command .= q{ } . '-DVERSION=\"0.00\" -DXS_VERSION=\"0.00\"';
my string $cccdlflags = [ config_re('cccdlflags') ]->[0];
substr $cccdlflags, 0, 12, q{};
substr $cccdlflags, -1, 1, q{};
$subcompile_command .= q{ } . $cccdlflags;
if ( $RPerl::CORE_PATH eq q{} ) {
croak 'ERROR ECOCOSU02, COMPILER, SUBCOMPILE: Perl source code CORE directory or CORE/perl.h file not found in @INC path listing, croaking';
}
$subcompile_command .= q{ } . '"-I' . $RPerl::CORE_PATH . '"';
if ($modes->{parallel} eq 'OFF') {
$subcompile_command .= q{ } . $cpp_output_file_name_group->{CPP};
$subcompile_command .= q{ } . '-o ';
if ( ( $modes->{subcompile} eq 'ASSEMBLE' )
or ( $modes->{subcompile} eq 'ARCHIVE' ) )
{
$subcompile_command .= q{ } . $cpp_output_file_name_group->{O};
}
elsif ( $modes->{subcompile} eq 'SHARED' ) {
$subcompile_command .= q{ } . $cpp_output_file_name_group->{SO};
}
elsif (( $modes->{subcompile} eq 'STATIC' )
or ( $modes->{subcompile} eq 'DYNAMIC' ) )
{
$subcompile_command .= q{ } . $cpp_output_file_name_group->{EXE};
}
}
elsif ($modes->{parallel} eq 'OPENMP') {
$subcompile_command .= q{ } . '-mtune=native -ftree-vectorize -DTIME -fopenmp';
$subcompile_command .= q{ } . $cpp_output_file_name_group->{OPENMP_CPP};
$subcompile_command .= q{ } . '-o ';
if (( $modes->{subcompile} eq 'STATIC' )
or ( $modes->{subcompile} eq 'DYNAMIC' ) )
{
$subcompile_command .= q{ } . $cpp_output_file_name_group->{OPENMP_EXE};
}
}
$subcompile_command .= $subcompile_command_append;
if ( $modes->{subcompile} eq 'SHARED' ) {
$subcompile_command .= q{ } . '-shared';
}
elsif ( $modes->{subcompile} eq 'STATIC' ) {
$subcompile_command .= q{ } . '-static';
}
if ( ( $modes->{subcompile} eq 'STATIC' )
or ( $modes->{subcompile} eq 'DYNAMIC' ) )
{
if ($modes->{parallel} eq 'OPENMP') {
$subcompile_command .= q{ } . '-lm';
}
$subcompile_command .= q{ } . '-lperl';
$subcompile_command .= q{ } . '-lpcre2-8 -lpcre2-16 -lpcre2-32';
}
if ( $modes->{subcompile} eq 'STATIC' ) {
$subcompile_command .= q{ } . '-lcrypt';
}
if ( $modes->{subcompile} eq 'ARCHIVE' ) {
$subcompile_command .= q{ } . ' ; ar -cvq ' . $cpp_output_file_name_group->{A} . q{ } . $cpp_output_file_name_group->{O};
if ( $OSNAME eq 'MSWin32' ) { $subcompile_command .= q{ } . ' > nul'; }
else { $subcompile_command .= q{ } . ' > /dev/null'; }
}
RPerl::diag( "\n\n" . $subcompile_command . "\n\n" );
if ( $ENV{RPERL_VERBOSE} or $RPerl::VERBOSE ) { RPerl::diag( q{SUBCOMPILE: Generate binary... } ); }
my string $subcompile_command_stdout = q{};
my string $subcompile_command_stderr = q{};
run3( $subcompile_command, \undef, \$subcompile_command_stdout, \$subcompile_command_stderr );
my $test_exit_status = $CHILD_ERROR >> 8;
RPerl::verbose( ' done.' . "\n" );
if ( $modes->{subcompile} eq 'ARCHIVE' ) {
if ( -f $cpp_output_file_name_group->{O} ) {
unlink( $cpp_output_file_name_group->{O} )
or croak( "\n"
. 'ERROR ECOCOSU03, COMPILER, SUBCOMPILE: Cannot delete temporary object file ' . q{'}
. $cpp_output_file_name_group->{O} . q{'} . ',' . "\n"
. 'croaking:'
. $OS_ERROR );
}
}
my boolean $subcompile_command_stdout_content = ( ( defined $subcompile_command_stdout ) and ( $subcompile_command_stdout =~ m/[^\s]+/g ) );
my boolean $subcompile_command_stderr_content = ( ( defined $subcompile_command_stderr ) and ( $subcompile_command_stderr =~ m/[^\s]+/g ) );
if ( $subcompile_command_stdout_content or $subcompile_command_stderr_content ) {
RPerl::diag("\n");
if ($subcompile_command_stdout_content) {
RPerl::diag( '[[[ SUBCOMPILE STDOUT ]]]' . "\n\n" . $subcompile_command_stdout . "\n" );
}
if ($subcompile_command_stderr_content) {
RPerl::diag( '[[[ SUBCOMPILE STDERR ]]]' . "\n\n" . $subcompile_command_stderr . "\n" );
}
if ( $test_exit_status == 0 ) {
RPerl::warning(
'WARNING WCOCOSU00, COMPILER, SUBCOMPILE: C++ compiler returned success code but produced output which may indicate an error,' . "\n"
. 'please run again with `rperl -D` command or RPERL_DEBUG=1 environmental variable for error messages or other output if none appear above'
. "\n" );
}
}
if ($test_exit_status) {
if ( not( $subcompile_command_stdout_content or $subcompile_command_stderr_content ) ) {
RPerl::diag( "\n" . '[[[ SUBCOMPILE STDOUT & STDERR ARE BOTH EMPTY ]]]' . "\n\n" );
}
croak 'ERROR ECOCOSU04, COMPILER, SUBCOMPILE: C++ compiler returned error code,' . "\n"
. 'please run again with `rperl -D` command or RPERL_DEBUG=1 environmental variable for error messages if none appear above,' . "\n"
. 'croaking';
}
}
else {
RPerl::verbose('SUBCOMPILE: Generate XS & binary...');
( my string $volume_pmc, my string $directories_pmc, my string $file_pmc )
= File::Spec->splitpath( $cpp_output_file_name_group->{PMC}, my $no_file = 0 );
if ( ( ( length $directories_pmc ) > 1 )
and ( ( ( substr $directories_pmc, -1, 1 ) eq q{/} ) or ( ( substr $directories_pmc, -1, 1 ) eq q{\\} ) ) )
{
substr $directories_pmc, -1, 1, q{};
}
my @INC_sorted = sort { length $b <=> length $a } @INC;
$directories_pmc = post_processor__INC_paths_delete($directories_pmc, 0, 1);
my string_arrayref $directories_pmc_split = [ File::Spec->splitdir($directories_pmc) ];
my $directories_pmc_split_tmp = [];
foreach my $directory ( @{$directories_pmc_split} ) {
if ( ( $directory ne q{.} ) and ( $directory ne q{} ) ) {
push @{$directories_pmc_split_tmp}, $directory;
}
}
$directories_pmc_split = $directories_pmc_split_tmp;
substr $file_pmc, -4, 4, q{};
my string $eval_string = join '::', @{$directories_pmc_split}, $file_pmc;
$eval_string = 'use ' . $eval_string . ';';
RPerl::verbose( ' deferred.' . "\n" );
}
return;
}
1;