File Coverage

blib/lib/RPerl/Compiler.pm
Criterion Covered Total %
statement 313 744 42.0
branch 130 428 30.3
condition 40 294 13.6
subroutine 31 37 83.7
pod n/a
total 514 1503 34.2


line stmt bran cond sub pod time code
1             ## no critic qw(ProhibitExcessMainComplexity) # SYSTEM SPECIAL 4: allow complex code outside subroutines, must be on line 1
2             # [[[ PREPROCESSOR ]]]
3             # <<< TYPE_CHECKING: OFF >>>
4              
5             # [[[ HEADER ]]]
6             package RPerl::Compiler;
7 3     3   17 use strict;
  3         7  
  3         67  
8 3     3   15 use warnings;
  3         6  
  3         63  
9 3     3   14 use RPerl::AfterSubclass;
  3         6  
  3         371  
10             our $VERSION = 0.029_000;
11              
12             # [[[ OO INHERITANCE ]]]
13 3     3   21 use parent qw(RPerl::CompileUnit::Module::Class);
  3         7  
  3         16  
14 3     3   161 use RPerl::CompileUnit::Module::Class;
  3         7  
  3         50  
15              
16             # [[[ CRITICS ]]]
17             ## no critic qw(ProhibitUselessNoCritic ProhibitMagicNumbers RequireCheckedSyscalls) # USER DEFAULT 1: allow numeric values & print operator
18             ## no critic qw(RequireInterpolationOfMetachars) # USER DEFAULT 2: allow single-quoted control characters & sigils
19             ## no critic qw(ProhibitStringyEval) # SYSTEM DEFAULT 1: allow eval()
20             ## no critic qw(RequireBriefOpen) # SYSTEM SPECIAL 10: allow complex processing with open filehandle
21              
22             # [[[ INCLUDES ]]]
23 3     3   16 use RPerl::Parser;
  3         10  
  3         56  
24 3     3   12 use RPerl::Generator;
  3         6  
  3         65  
25 3     3   16 use File::Temp qw(tempfile);
  3         5  
  3         135  
26 3     3   17 use File::Basename;
  3         9  
  3         152  
27 3     3   16 use English qw(-no_match_vars); # for $OSNAME; why isn't this included from 'require RPerl::Config', which is included from 'use RPerl' above?
  3         6  
  3         23  
28 3     3   870 use IPC::Cmd qw(can_run); # to check for `perltidy` and `astyle`
  3         6  
  3         125  
29 3     3   14 use List::MoreUtils qw(uniq);
  3         6  
  3         36  
30 3     3   2016 use File::Spec;
  3         6  
  3         55  
31 3     3   13 use Config;
  3         6  
  3         107  
32 3     3   17 use Config qw(config_re);
  3         7  
  3         90  
33             #use IPC::Open3; ## 93r
34             #use IO::Select; ## 93r
35 3     3   1029 use IPC::Run3 qw(run3);
  3         7678  
  3         154  
36 3     3   22 use Cwd;
  3         7  
  3         140  
37 3     3   17 use File::Copy; # for move()
  3         6  
  3         113  
38 3     3   709 use Alien::astyle;
  3         605  
  3         29  
39 3     3   19813 use Env qw(@PATH);
  3         5588  
  3         19  
40             unshift @PATH, Alien::astyle->bin_dir();
41              
42             #our string_arrayref_hashref_hashref $filename_suffixes_supported = {
43             our hashref_hashref $filename_suffixes_supported = {
44             INPUT_SOURCE => { PL => ['.pl'], PM => ['.pm'] },
45             OUTPUT_SOURCE => { CPP => ['.cpp'], H => ['.h'], PMC => ['.pmc'], OPENMP_CPP => ['.openmp.cpp'] },
46             OUTPUT_BINARY => { O => ['.o'], A => ['.a'], SO => ['.so'], EXE => [ q{}, '.exe' ], OPENMP_EXE => [ '.openmp', '.openmp.exe' ] }
47              
48             # NEED ANSWER: what are the correct Windows file extensions?
49             # OUTPUT_BINARY => { O => ['.o', '.lib'], A => ['.a', '.lib'], SO => ['.so', '.dll'], EXE => [q{}, '.exe'], OPENMP_EXE => ['.openmp', '.openmp.exe']}
50             };
51              
52             # [[[ SUBROUTINES ]]]
53              
54             sub find_parents {
55 1374     1374   3127 { my string_arrayref $RETURN_TYPE };
  1374         2759  
56 1374         4333 ( my string $file_name, my boolean $find_grandparents_recurse, my string_hashref $modes ) = @ARG;
57             # RPerl::diag( 'in Compiler::find_parents(), received $file_name = ' . $file_name . "\n" );
58              
59             # trim unnecessary (and possibly problematic) absolute or current-directory paths from input file name
60 1374         28459 $file_name = post_processor__absolute_path_delete($file_name);
61 1374         29232 $file_name = post_processor__current_directory_path_delete($file_name);
62             # RPerl::diag( 'in Compiler::find_parents(), have possibly-trimmed $file_name = ' . $file_name . "\n" );
63              
64 1374         3541 my string_arrayref $parents = [];
65              
66 1374 50       31042 if ( not -f $file_name ) {
67 0         0 die 'ERROR ECOCOPA00, COMPILER, FIND PARENTS: File not found, ' . q{'} . $file_name . q{'} . ', dying' . "\n";
68             }
69              
70 1374 50       56073 open my filehandleref $FILE_HANDLE, '<', $file_name
71             or die 'ERROR ECOCOPA01, COMPILER, FIND PARENTS: Cannot open file ' . q{'} . $file_name . q{'} . ' for reading, ' . $OS_ERROR . ', dying' . "\n";
72              
73             # read in input file, match on 'use' includes for parents
74 1374         3500 my string $file_line;
75 1374         2955 my string $top_level_package_name = undef;
76 1374         3553 my boolean $use_rperl = 0;
77              
78             # NEED FIX: do not make recursive calls until after closing file, to avoid
79             # ERROR ECOCOPA01, COMPILER, FIND PARENTS: Cannot open file Foo/Bar.pm for reading, Too many open files, dying
80 1374         53320 while ( $file_line = <$FILE_HANDLE> ) {
81             # RPerl::diag('in Compiler::find_parents(), top of while loop, have $file_line = ' . $file_line . "\n");
82              
83 31850 100       52955 if ( $file_line =~ /^\s*package\s+[\w:]+\s*;\s*$/xms ) {
84 414 100       1469 if ( not defined $top_level_package_name ) {
85 410         1016 $top_level_package_name = $file_line;
86 410         2673 $top_level_package_name =~ s/^\s*package\s+([\w:]+)\s*;\s*$/$1/gxms;
87             }
88             # DEV NOTE: for monolithic modules (more than one package), we only find parents of the first package, to avoid incorrect parent lists & infinite recursion
89             else {
90 4         11 last;
91             }
92             }
93              
94 31846 100       75561 if ( $file_line =~ /^\s*use\s+[\w:]+/xms ) {
95             # RPerl::diag('in Compiler::find_parents(), found use line, have $file_line = ' . $file_line . "\n");
96 4660 100 100     24220 if (( $file_line =~ /use\s+RPerl\s*;/ ) or
    50          
    100          
97             ( $file_line =~ /use\s+RPerl::AfterSubclass\s*;/ )) {
98 1376         2237 $use_rperl = 1;
99 1376         4709 next;
100             }
101             elsif ( $file_line =~ /use\s+lib/ ) {
102 0         0 die
103             q{ERROR ECOCOPA02, COMPILER, FIND PARENTS: 'use lib...' not currently supported, please set @INC using the PERL5LIB environment variable, file }
104             . q{'}
105             . $file_name . q{'}
106             . ', dying' . "\n";
107             }
108             elsif ( $file_line !~ /use\s+parent/ )
109             {
110             # safely ignore these not-parent uses
111 3140         7734 next;
112             }
113              
114             # 'use RPerl;' must appear before any other 'use Foo;' statements, or else this is not a valid RPerl input file and we return empty deps
115 144 50       370 if (not $use_rperl) {
116 0         0 last;
117             }
118              
119 144         243 my string $package_file_name_included;
120 144         329 my string $package_name = $file_line;
121             # remove everything except the package name
122 144         696 $package_name =~ s/^(\s*)//gxms; # strip leading whitespace
123 144         363 substr $package_name, 0, 14, q{}; # strip leading 'use parent qw('
124 144         731 $package_name =~ s/([\w:]+)(.*)$/$1/gxms; # strip trailing everything
125             # RPerl::diag('in Compiler::find_parents(), have $package_name = ' . $package_name . "\n\n");
126              
127             # safely skip base class for no parent inheritance
128 144 100       531 if ($package_name eq 'RPerl::CompileUnit::Module::Class') {
129 100         325 next;
130             }
131              
132 44         117 my string $package_file_name = $package_name;
133 44         224 $package_file_name =~ s/::/\//gxms; # replace double-colon :: scope delineator with forward-slash / directory delineator
134 44         133 $package_file_name .= '.pm';
135              
136             # find specific included dependency file in @INC
137 44         203 foreach my string $INC_directory (@INC) {
138             # RPerl::diag( 'in Compiler::find_parents(), top of @INC foreach loop, have $INC_directory = ' . $INC_directory . "\n" );
139 132         326 $package_file_name_included = $INC_directory . '/' . $package_file_name;
140             # RPerl::diag( 'in Compiler::find_parents(), inside @INC foreach loop, have $package_file_name_included = ' . $package_file_name_included . "\n" );
141 132 100       1235 if (-e $package_file_name_included) {
142             # RPerl::diag( 'in Compiler::find_parents(), inside @INC foreach loop, have EXISTING $package_file_name_included = ' . $package_file_name_included . "\n" );
143 44         99 last;
144             }
145             else {
146 88         286 $package_file_name_included = q{};
147             }
148             }
149 44 50       159 if ($package_file_name_included eq q{}) {
150 0         0 die 'ERROR ECOCOPA04, COMPILER, FIND PARENTS: Failed to find package file ', q{'}, $package_file_name, q{'},
151             ' in @INC, included from file ', q{'}, $file_name, q{'}, ', dying', "\n";
152             }
153              
154             # RPerl::diag( 'in Compiler::find_parents(), have $package_file_name_included = ' . $package_file_name_included . "\n" );
155              
156 44         1098 my string $package_file_name_included_relative = post_processor__absolute_path_delete( $package_file_name_included );
157 44         893 $package_file_name_included_relative = post_processor__current_directory_path_delete( $package_file_name_included_relative );
158 44         89 push @{$parents}, $package_file_name_included_relative;
  44         140  
159            
160             # RPerl::diag( 'in Compiler::find_parents(), have PRE-SUBDEPS $parents = ' . Dumper($parents) . "\n" );
161              
162 44 50       138 if ($find_grandparents_recurse) {
163            
164             # recursively find grandparents
165 44         969 my string_arrayref $grandparents = find_parents( $package_file_name_included, $find_grandparents_recurse, $modes );
166            
167             # discard duplicate parents that now appear in grandparents
168 44         97 $parents = [ uniq @{$grandparents}, @{$parents} ];
  44         141  
  44         522  
169            
170             # RPerl::diag( 'in Compiler::find_parents(), have POST-SUBDEPS $parents = ' . Dumper($parents) . "\n" );
171             }
172             }
173             }
174              
175 1374 50       12336 close $FILE_HANDLE
176             or die 'ERROR ECOCOPA05, COMPILER, FIND PARENTS: Cannot close file ' . q{'}
177             . $file_name . q{'}
178             . ' after reading, '
179             . $OS_ERROR
180             . ', dying' . "\n";
181              
182             # RPerl::diag( 'in Compiler::find_parents(), returning $parents = ' . Dumper($parents) . "\n" );
183             # RPerl::diag('in Compiler::find_parents(), about to return, have $modes->{_enable_sse} = ' . Dumper($modes->{_enable_sse}) . "\n");
184             # RPerl::diag('in Compiler::find_parents(), about to return, have $modes->{_enable_gmp} = ' . Dumper($modes->{_enable_gmp}) . "\n");
185             # RPerl::diag('in Compiler::find_parents(), about to return, have $modes->{_enable_gsl} = ' . Dumper($modes->{_enable_gsl}) . "\n");
186 1374         9170 return $parents;
187             }
188              
189             sub find_dependencies {
190 0     0   0 { my string_arrayref $RETURN_TYPE };
  0         0  
191 0         0 ( my string $file_name, my boolean $find_subdependencies_recurse, my string_hashref $modes ) = @ARG;
192             # RPerl::diag( 'in Compiler::find_dependencies(), received $file_name = ' . $file_name . "\n" );
193              
194             # trim unnecessary (and possibly problematic) absolute and current-directory paths from input file name
195 0         0 $file_name = post_processor__absolute_path_delete($file_name);
196 0         0 $file_name = post_processor__current_directory_path_delete($file_name);
197             # RPerl::diag( 'in Compiler::find_dependencies(), have possibly-trimmed $file_name = ' . $file_name . "\n" );
198              
199 0         0 my string_arrayref $dependencies = [];
200             # my string_arrayref $pmc_disable_paths = []; # DISABLE_DYNAMIC_DEPS_ANALYSIS
201              
202 0 0       0 if ( not -f $file_name ) {
203 0         0 die 'ERROR ECOCODE00, COMPILER, FIND DEPENDENCIES: File not found, ' . q{'} . $file_name . q{'} . ', dying' . "\n";
204             }
205              
206 0 0       0 open my filehandleref $FILE_HANDLE, '<', $file_name
207             or die 'ERROR ECOCODE01, COMPILER, FIND DEPENDENCIES: Cannot open file ' . q{'} . $file_name . q{'} . ' for reading, ' . $OS_ERROR . ', dying' . "\n";
208              
209             # read in input file, match on 'use' includes for dependencies
210 0         0 my string $file_line;
211 0         0 my string $top_level_package_name = undef;
212 0         0 my boolean $use_rperl = 0;
213              
214             # NEED FIX: do not make recursive calls until after closing file, to avoid
215             # ERROR ECOCODE01, COMPILER, FIND DEPENDENCIES: Cannot open file Foo/Bar.pm for reading, Too many open files, dying
216 0         0 while ( $file_line = <$FILE_HANDLE> ) {
217             # RPerl::diag('in Compiler::find_dependencies(), top of while loop, have $file_line = ' . $file_line . "\n");
218              
219 0 0 0     0 if ( ( $file_line =~ /^\s*package\s+[\w:]+\s*;\s*$/xms ) and ( not defined $top_level_package_name ) ) {
220             # disable top-level PMC file before finding subdependencies
221 0         0 $top_level_package_name = $file_line;
222 0         0 $top_level_package_name =~ s/^\s*package\s+([\w:]+)\s*;\s*$/$1/gxms;
223             =DISABLE_DYNAMIC_DEPS_ANALYSIS
224             my string $pmc_disable_path = pmc_disable($top_level_package_name);
225             if ($pmc_disable_path eq q{}) {
226             # my integer $eval_retval = eval_use_dependencies($top_level_package_name); # NEED ANSWER: do we need to care about $eval_retval?
227             eval_use_dependencies($top_level_package_name);
228             }
229             else {
230             push @{$pmc_disable_paths}, $pmc_disable_path;
231             }
232             =cut
233             }
234              
235             # DEV NOTE, CORRELATION #rp050: hard-coded list of RPerl files/packages/namespaces
236             # these instances of the 'use' keyword are NOT subdependencies of the current file, do not try to compile them
237 0 0       0 if ( $file_line =~ /^\s*use\s+[\w:]+/xms ) {
238             # RPerl::diag('in Compiler::find_dependencies(), found use line, have $file_line = ' . $file_line . "\n");
239 0 0 0     0 if (( $file_line =~ /use\s+RPerl\s*;/ ) or
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
240             ( $file_line =~ /use\s+RPerl::AfterSubclass\s*;/ )) {
241 0         0 $use_rperl = 1;
242 0         0 next;
243             }
244             elsif ( ( $file_line =~ /use\s+strict\s*;/ )
245             or ( $file_line =~ /use\s+warnings\s*;/ )
246             or ( $file_line =~ /use\s+RPerl::CompileUnit::Module::Class\s*;/ )
247             or ( $file_line =~ /use\s+RPerl::Class\s*;/ )
248             or ( $file_line =~ /use\s+RPerl::Config\s*;/ )
249             or ( $file_line =~ /use\s+RPerl::Exporter.*;/ )
250             or ( $file_line =~ /use\s+\w+Perl::Config\s*;/ ) # DEV NOTE, CORRELATION #rp027: MathPerl::Config, PhysicsPerl::Config, etc
251             or ( $file_line =~ /use\s+perlapinames_generated/ )
252             or ( $file_line =~ /use\s+parent/ )
253             or ( $file_line =~ /use\s+constant/ )
254             or ( $file_line =~ /use\s+overload/ )
255             or ( $file_line =~ /use\s+integer/ )
256             or ( $file_line =~ /use\s+[0-9]/ )
257             )
258             {
259             # safely ignore these possibly-valid but not-subdependency uses
260 0         0 next;
261             }
262             elsif ((defined $top_level_package_name) and ( $file_line =~ /use\s+$top_level_package_name\s*;/ )) {
263             # DEV NOTE, CORRELATION #rp042: do not recursively load the same .pm file from within itself
264 0         0 next;
265             }
266             elsif ( $file_line =~ /use\s+rperlsse\s*;/ ) {
267              
268             # RPerl::diag('in Compiler::find_dependencies(), found rperlsse line, have $modes->{_enable_sse} = ' . Dumper($modes->{_enable_sse}) . "\n");
269 0 0       0 if ( ( substr $Config{archname}, 0, 3 ) eq 'arm' ) {
270 0         0 die q{ERROR ECOCODE06, COMPILER, FIND DEPENDENCIES: 'use rperlsse;' command found but SSE not supported on ARM architecture, file }
271             . q{'}
272             . $file_name . q{'}
273             . ', dying' . "\n";
274             }
275 0 0 0     0 if ( ( not exists $modes->{_enable_sse} ) or ( not defined $modes->{_enable_sse} ) ) {
276 0         0 $modes->{_enable_sse} = {};
277             }
278 0         0 $modes->{_enable_sse}->{$file_name} = 1;
279              
280             # RPerl::diag('in Compiler::find_dependencies(), after finding rperlsse line, have $modes->{_enable_sse} = ' . Dumper($modes->{_enable_sse}) . "\n");
281 0         0 next;
282             }
283             elsif ( $file_line =~ /use\s+rperlgmp\s*;/ ) {
284             # RPerl::diag('in Compiler::find_dependencies(), found rperlgmp line, have $modes->{_enable_gmp} = ' . Dumper($modes->{_enable_gmp}) . "\n");
285 0 0 0     0 if ( ( not exists $modes->{_enable_gmp} ) or ( not defined $modes->{_enable_gmp} ) ) {
286 0         0 $modes->{_enable_gmp} = {};
287             }
288 0         0 $modes->{_enable_gmp}->{$file_name} = 1;
289              
290             # RPerl::diag('in Compiler::find_dependencies(), after finding rperlgmp line, have $modes->{_enable_gmp} = ' . Dumper($modes->{_enable_gmp}) . "\n");
291 0         0 next;
292             }
293             elsif ( $file_line =~ /use\s+rperlgsl\s*;/ ) {
294             # RPerl::diag('in Compiler::find_dependencies(), found rperlgsl line, have $modes->{_enable_gsl} = ' . Dumper($modes->{_enable_gsl}) . "\n");
295 0 0 0     0 if ( ( not exists $modes->{_enable_gsl} ) or ( not defined $modes->{_enable_gsl} ) ) {
296 0         0 $modes->{_enable_gsl} = {};
297             }
298 0         0 $modes->{_enable_gsl}->{$file_name} = 1;
299              
300             # RPerl::diag('in Compiler::find_dependencies(), after finding rperlgsl line, have $modes->{_enable_gsl} = ' . Dumper($modes->{_enable_gsl}) . "\n");
301 0         0 next;
302             }
303             elsif ( $file_line =~ /use\s+lib/ ) {
304 0         0 die
305             q{ERROR ECOCODE02, COMPILER, FIND DEPENDENCIES: 'use lib...' not currently supported, please set @INC using the PERL5LIB environment variable, file }
306             . q{'}
307             . $file_name . q{'}
308             . ', dying' . "\n";
309             }
310              
311             # 'use RPerl;' or 'use RPerl::AfterSubclass;' must appear before any other 'use Foo;' statements, or else this is not a valid RPerl input file and we return empty deps
312 0 0       0 if (not $use_rperl) {
313 0         0 last;
314             }
315              
316 0         0 my string $package_file_name_included;
317 0         0 my string $package_name = $file_line;
318 0         0 $package_name =~ s/^\s*use\s+([\w:]+)\s*.*\s*;\s*$/$1/gxms; # remove everything except the package name
319              
320             # disable PMC file before finding subdependencies
321             # my string $pmc_disable_path = pmc_disable($package_name); # DISABLE_DYNAMIC_DEPS_ANALYSIS
322              
323 0         0 my string $package_file_name = $package_name;
324 0         0 $package_file_name =~ s/::/\//gxms; # replace double-colon :: scope delineator with forward-slash / directory delineator
325 0         0 $package_file_name .= '.pm';
326              
327             # find specific included dependency file in either %INC or @INC
328             =DISABLE_DYNAMIC_DEPS_ANALYSIS
329             if ($pmc_disable_path eq q{}) {
330             eval_use_dependencies($package_name);
331             if ( not exists $INC{$package_file_name} ) {
332             die 'ERROR ECOCODE03, COMPILER, FIND DEPENDENCIES: Failed to find package file ', q{'}, $package_file_name, q{'},
333             ' in %INC, included from file ', q{'}, $file_name, q{'}, ', dying', "\n";
334             }
335             $package_file_name_included = $INC{$package_file_name};
336             }
337             else {
338             =cut
339 0         0 foreach my string $INC_directory (@INC) {
340             # RPerl::diag( 'in Compiler::find_dependencies(), top of @INC foreach loop, have $INC_directory = ' . $INC_directory . "\n" );
341 0         0 $package_file_name_included = $INC_directory . '/' . $package_file_name;
342             # RPerl::diag( 'in Compiler::find_dependencies(), inside @INC foreach loop, have $package_file_name_included = ' . $package_file_name_included . "\n" );
343 0 0       0 if (-e $package_file_name_included) {
344             # RPerl::diag( 'in Compiler::find_dependencies(), inside @INC foreach loop, have EXISTING $package_file_name_included = ' . $package_file_name_included . "\n" );
345 0         0 last;
346             }
347             else {
348 0         0 $package_file_name_included = q{};
349             }
350             }
351 0 0       0 if ($package_file_name_included eq q{}) {
352 0         0 die 'ERROR ECOCODE04, COMPILER, FIND DEPENDENCIES: Failed to find package file ', q{'}, $package_file_name, q{'},
353             ' in @INC, included from file ', q{'}, $file_name, q{'}, ', dying', "\n";
354             }
355             =DISABLE_DYNAMIC_DEPS_ANALYSIS
356             push @{$pmc_disable_paths}, $pmc_disable_path;
357             }
358             =cut
359              
360             # RPerl::diag( 'in Compiler::find_dependencies(), have $package_file_name_included = ' . $package_file_name_included . "\n" );
361              
362 0         0 my string $package_file_name_included_relative = post_processor__absolute_path_delete( $package_file_name_included );
363 0         0 $package_file_name_included_relative = post_processor__current_directory_path_delete( $package_file_name_included_relative );
364 0         0 push @{$dependencies}, $package_file_name_included_relative;
  0         0  
365            
366             # RPerl::diag( 'in Compiler::find_dependencies(), have PRE-SUBDEPS $dependencies = ' . Dumper($dependencies) . "\n" );
367              
368 0 0       0 if ($find_subdependencies_recurse) {
369            
370             # recursively find subdependencies
371 0         0 my string_arrayref $subdependencies = find_dependencies( $package_file_name_included, $find_subdependencies_recurse, $modes );
372            
373             # discard duplicate dependencies that now appear in subdependencies
374 0         0 $dependencies = [ uniq @{$subdependencies}, @{$dependencies} ];
  0         0  
  0         0  
375            
376             # RPerl::diag( 'in Compiler::find_dependencies(), have POST-SUBDEPS $dependencies = ' . Dumper($dependencies) . "\n" );
377             }
378             }
379             }
380              
381 0 0       0 close $FILE_HANDLE
382             or die 'ERROR ECOCODE05, COMPILER, FIND DEPENDENCIES: Cannot close file ' . q{'}
383             . $file_name . q{'}
384             . ' after reading, '
385             . $OS_ERROR
386             . ', dying' . "\n";
387              
388             =DISABLE_DYNAMIC_DEPS_ANALYSIS
389             # re-enable all PMC files after finding dependencies
390             while (scalar @{$pmc_disable_paths}) {
391             pmc_reenable(pop @{$pmc_disable_paths});
392             }
393             =cut
394              
395             # RPerl::diag( 'in Compiler::find_dependencies(), returning $dependencies = ' . Dumper($dependencies) . "\n" );
396             # RPerl::diag('in Compiler::find_dependencies(), about to return, have $modes->{_enable_sse} = ' . Dumper($modes->{_enable_sse}) . "\n");
397             # RPerl::diag('in Compiler::find_dependencies(), about to return, have $modes->{_enable_gmp} = ' . Dumper($modes->{_enable_gmp}) . "\n");
398             # RPerl::diag('in Compiler::find_dependencies(), about to return, have $modes->{_enable_gsl} = ' . Dumper($modes->{_enable_gsl}) . "\n");
399 0         0 return $dependencies;
400             }
401              
402             =DISABLE_DYNAMIC_DEPS_ANALYSIS
403             # temporarily disable a package's PMC file, if it exists
404             sub pmc_disable {
405             { my string $RETURN_TYPE };
406             ( my string $package_name ) = @ARG;
407             # RPerl::diag( 'in Compiler::pmc_disable(), received $package_name = ' . $package_name . "\n" );
408              
409             my string $pmc_file_path_absolute;
410             my string $pmc_file_path_absolute_disabled = q{};
411             my string $pmc_file_path_relative = $package_name;
412             $pmc_file_path_relative =~ s/::/\//gxms; # replace double-colon :: scope delineator with forward-slash / directory delineator
413             $pmc_file_path_relative .= '.pmc';
414              
415             foreach my string $INC_directory (@INC) {
416             # RPerl::diag( 'in Compiler::pmc_disable(), top of foreach loop, have $INC_directory = ' . $INC_directory . "\n" );
417             $pmc_file_path_absolute = $INC_directory . '/' . $pmc_file_path_relative;
418             # RPerl::diag( 'in Compiler::pmc_disable(), inside foreach loop, have $pmc_file_path_absolute = ' . $pmc_file_path_absolute . "\n" );
419             if (-e $pmc_file_path_absolute) {
420             # RPerl::diag( 'in Compiler::pmc_disable(), inside foreach loop, have EXISTING $pmc_file_path_absolute = ' . $pmc_file_path_absolute . "\n" );
421             $pmc_file_path_absolute_disabled = $pmc_file_path_absolute . '.PMC_DISABLED';
422             my boolean $move_success = move($pmc_file_path_absolute, $pmc_file_path_absolute_disabled);
423             if (not $move_success) {
424             die 'ERROR ECOCODE07, COMPILER, PMC DISABLE: Failed to temporarily disable package file ', q{'}, $pmc_file_path_absolute, q{'; },
425             $OS_ERROR, ', dying', "\n";
426             }
427             # RPerl::diag( 'in Compiler::pmc_disable(), DISABLED $pmc_file_path_absolute = ' . $pmc_file_path_absolute . "\n" );
428             last;
429             }
430             }
431             return $pmc_file_path_absolute_disabled;
432             }
433              
434             # re-enable a package's temporarily-disabled PMC file, if it exists
435             sub pmc_reenable {
436             { my boolean $RETURN_TYPE };
437             ( my string $file_name ) = @ARG;
438             # RPerl::diag( 'in Compiler::pmc_reenable(), received $file_name = ' . $file_name . "\n" );
439             if ((defined $file_name) and ($file_name ne q{})) {
440             if ((substr $file_name, -13, 13) ne '.PMC_DISABLED') {
441             die 'ERROR ECOCODE08, COMPILER, PMC RE-ENABLE: Temporarily-disabled package file name ', q{'}, $file_name, q{'},
442             ' does not with .PMC_DISABLED, dying', "\n";
443             }
444             if (-e $file_name) {
445             my string $file_name_original = $file_name;
446             substr $file_name_original, -13, 13, q{}; # strip trailing .PMC_DISABLED
447             my boolean $move_success = move($file_name, $file_name_original);
448             if (not $move_success) {
449             die 'ERROR ECOCODE09, COMPILER, PMC RE-ENABLE: Failed to re-enable temporarily-disabled package file ', q{'}, $file_name, q{'; },
450             $OS_ERROR, ', dying', "\n";
451             }
452             # RPerl::diag( 'in Compiler::pmc_disable(), RE-ENABLED $file_name = ' . $file_name . "\n" );
453             }
454             else {
455             die 'ERROR ECOCODE10, COMPILER, PMC RE-ENABLE: Failed to re-enable temporarily-disabled package file ', q{'}, $file_name, q{'; },
456             ' file does not exist, dying', "\n";
457             }
458             return 1;
459             }
460             else {
461             return 0;
462             }
463             }
464              
465             # call RPerl::eval_use() to perform a runtime use on a package, with dependencies-specific warning message
466             sub eval_use_dependencies {
467             { my integer $RETURN_TYPE };
468             ( my string $package_name ) = @ARG;
469             # RPerl::diag( 'in Compiler::eval_use(), received $package_name = ' . $package_name . "\n" );
470              
471             my integer $eval_retval = RPerl::eval_use($package_name, 0);
472              
473             # RPerl::diag('in Compiler::find_dependencies(), have POST-EVAL NON-DEP %INC = ' . Dumper(\%INC) . "\n");
474             # warn instead of dying on eval error here and below, in order to preserve proper parser errors instead of weird eval errors
475             # in RPerl/Test/*/*Bad*.pm and RPerl/Test/*/*bad*.pl
476             if ( ( not defined $eval_retval ) or ( $EVAL_ERROR ne q{} ) ) {
477             RPerl::warning( 'WARNING WCOCODE00, COMPILER, FIND DEPENDENCIES: Failed to eval-use package ' . q{'}
478             . $package_name . q{'} . ', fatal error trapped and delayed' . "\n" );
479             RPerl::diag( ' Trapped the following error message...' . "\n\n" . $EVAL_ERROR . "\n" );
480             RPerl::warning("\n");
481             }
482             # RPerl::diag( 'in Compiler::pmc_disable(), EVAL USED $package_name = ' . $package_name . "\n" );
483             return $eval_retval;
484             }
485             =cut
486              
487             # [[[ COMPILE RPERL TO RPERL, TEST MODE ]]]
488             # [[[ COMPILE RPERL TO RPERL, TEST MODE ]]]
489             # [[[ COMPILE RPERL TO RPERL, TEST MODE ]]]
490              
491             sub rperl_to_rperl__parse_generate {
492 0     0   0 { my string_hashref $RETURN_TYPE };
  0         0  
493 0         0 ( 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;
494 0         0 my object $rperl_ast;
495              
496             # RPerl::diag( 'in Compiler->rperl_to_rperl__parse_generate(), received $rperl_input_file_name = ' . $rperl_input_file_name . "\n" );
497             # RPerl::diag( 'in Compiler->rperl_to_rperl__parse_generate(), received $rperl_output_file_name_group = ' . "\n" . Dumper($rperl_output_file_name_group) . "\n" );
498             # RPerl::diag( 'in Compiler->rperl_to_rperl__parse_generate(), received $rperl_source_group = ' . "\n" . Dumper($rperl_source_group) . "\n" );
499             # RPerl::diag( 'in Compiler->rperl_to_rperl__parse_generate(), received $modes = ' . "\n" . Dumper($modes) . "\n" );
500              
501             # [[[ PARSE RPERL TO AST ]]]
502              
503 0 0 0     0 if ( ( $modes->{compile} eq 'PARSE' )
      0        
504             or ( $modes->{compile} eq 'GENERATE' )
505             or ( $modes->{compile} eq 'SAVE' ) )
506             {
507 0         0 $rperl_ast = RPerl::Parser::rperl_to_ast__parse($rperl_input_file_name);
508             }
509              
510             # [[[ GENERATE AST TO RPERL ]]]
511              
512 0 0 0     0 if ( ( $modes->{compile} eq 'GENERATE' )
513             or ( $modes->{compile} eq 'SAVE' ) )
514             {
515 0         0 $rperl_source_group = RPerl::Generator::ast_to_rperl__generate( $rperl_ast, $modes );
516             }
517              
518             # [[[ SAVE RPERL TO DISK ]]]
519              
520 0 0 0     0 if ( ( $modes->{compile} eq 'SAVE' )
521             or ( $modes->{compile} eq 'SAVE_DEFERRED' ) )
522             {
523 0         0 save_source_files( $rperl_source_group, $rperl_output_file_name_group, $modes );
524             }
525              
526             # always return $rperl_source_group to maintain consistent return type,
527             # only utilized for GENERATE compile mode during dependencies
528 0         0 return $rperl_source_group;
529             }
530              
531             # [[[ COMPILE RPERL TO XS & BINARY ]]]
532             # [[[ COMPILE RPERL TO XS & BINARY ]]]
533             # [[[ COMPILE RPERL TO XS & BINARY ]]]
534              
535             sub rperl_to_xsbinary__parse_generate_compile {
536 1518     1518   4260 { my string_hashref $RETURN_TYPE };
  1518         3123  
537 1518         5008 ( 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;
538 1518         4290 my object $rperl_ast;
539              
540             # RPerl::diag( 'in Compiler->rperl_to_xsbinary__parse_generate_compile(), received $modes->{_symbol_table} = ' . "\n" . Dumper($modes->{_symbol_table}) . "\n" );
541              
542             # [[[ PARSE RPERL TO AST ]]]
543              
544 1518 0 33     8586 if ( ( $modes->{compile} eq 'PARSE' )
      33        
      0        
545             or ( $modes->{compile} eq 'GENERATE' )
546             or ( $modes->{compile} eq 'SAVE' )
547             or ( $modes->{compile} eq 'SUBCOMPILE' ) )
548             {
549 1518         34934 $rperl_ast = RPerl::Parser::rperl_to_ast__parse($rperl_input_file_name);
550             }
551              
552             # [[[ GENERATE AST TO C++ ]]]
553              
554 622 50 33     9276 if ( ( $modes->{compile} eq 'GENERATE' )
      33        
555             or ( $modes->{compile} eq 'SAVE' )
556             or ( $modes->{compile} eq 'SUBCOMPILE' ) )
557             {
558 0         0 $cpp_source_group = RPerl::Generator::ast_to_cpp__generate( $rperl_ast, $modes );
559             }
560              
561             # [[[ SAVE C++ TO DISK ]]]
562              
563 622 50 33     6760 if ( ( $modes->{compile} eq 'SAVE' )
      33        
      33        
564             or ( $modes->{compile} eq 'SAVE_DEFERRED' )
565             or ( $modes->{compile} eq 'SUBCOMPILE' )
566             or ( $modes->{compile} eq 'SUBCOMPILE_DEFERRED' ) )
567             {
568 0         0 save_source_files( $cpp_source_group, $cpp_output_file_name_group, $modes );
569             }
570              
571             # [[[ AUTO-PARALLELIZE C++ VIA PLUTO & OPENMP ]]]
572              
573 622 50       2971 if ( $modes->{parallel} eq 'OPENMP' ) {
574 0         0 cpp_to_openmp_cpp( $cpp_output_file_name_group, $modes );
575             }
576              
577             # [[[ SUBCOMPILE C++ TO XS & BINARY ]]]
578              
579 622 50 33     3786 if ( ( $modes->{compile} eq 'SUBCOMPILE' )
580             or ( $modes->{compile} eq 'SUBCOMPILE_DEFERRED' ) )
581             {
582 0         0 cpp_to_xsbinary__subcompile( $cpp_output_file_name_group, $modes );
583             }
584              
585             # always return $cpp_source_group to maintain consistent return type,
586             # only utilized for GENERATE compile mode during dependencies
587 622         42426 return $cpp_source_group;
588             }
589              
590             # generate output file name group(s) based on input file name(s)
591             sub generate_output_file_names {
592 1330     1330   2236 { my hashref_arrayref $RETURN_TYPE };
  1330         2127  
593 1330         4146 ( my string_arrayref $input_file_names, my string_arrayref $output_file_name_prefixes, my integer $input_files_count, my string_hashref $modes ) = @ARG;
594              
595             # RPerl::diag('in Compiler::generate_output_file_names(), received $input_file_names = ' . "\n" . Dumper($input_file_names) . "\n");
596             # RPerl::diag('in Compiler::generate_output_file_names(), received $output_file_name_prefixes = ' . "\n" . Dumper($output_file_name_prefixes) . "\n");
597             # RPerl::diag('in Compiler::generate_output_file_names(), received $input_files_count = ' . $input_files_count . "\n");
598             # RPerl::diag( 'in Compiler::generate_output_file_names(), received $modes = ' . "\n" . Dumper($modes) . "\n" );
599              
600             # NEED FIX: add string_hashref_arrayref type
601             # my string_hashref_arrayref $output_file_name_groups = [];
602 1330         2419 my hashref_arrayref $output_file_name_groups = [];
603 1330         4867 my string $input_file_name;
604             my string $input_file_name_path;
605 1330         0 my string $input_file_name_prefix;
606 1330         0 my string $input_file_name_suffix;
607              
608 1330         4867 for my $i ( 0 .. ( $input_files_count - 1 ) ) {
609 1330         2766 $input_file_name = $input_file_names->[$i];
610              
611 1330         3651 $output_file_name_groups->[$i] = {};
612              
613             # if output file prefix(es) provided, then use to generate output file name(s)
614 1330 50       4124 if ( defined $output_file_name_prefixes->[$i] ) {
615              
616             # explicitly provided option should already be only prefix, but fileparse() to make sure
617 0         0 ( $input_file_name_prefix, $input_file_name_path, $input_file_name_suffix ) = fileparse( $output_file_name_prefixes->[$i], qr/[.][^.]*/xms );
618 0 0       0 if ( $input_file_name_prefix eq q{} ) {
619 0         0 die "ERROR EAR17: Invalid RPerl source code output file command-line argument specified, dying\n";
620             }
621             }
622              
623             # if output file prefix(es) not provided, then generate output file name(s) from input file name(s)
624             else {
625             # RPerl::diag('in Compiler::generate_output_file_names(), have $input_file_name = ' . $input_file_name . "\n");
626             # should not already be only prefix, fileparse() to isolate prefix
627 1330         53880 ( $input_file_name_prefix, $input_file_name_path, $input_file_name_suffix ) = fileparse( $input_file_name, qr/[.][^.]*/xms );
628             }
629              
630 1330         6654 my string $output_file_name_path_prefix = $input_file_name_path . $input_file_name_prefix;
631              
632             # *.pl input files may generate *.o, *.a, *.so, *.exe, and/or non-suffix output files
633 1330 100       5901 if ( $input_file_name =~ /[.]pl$/xms ) {
634 964 50 33     9632 if ( $modes->{subcompile} eq 'ASSEMBLE' ) {
    50 0        
    50 0        
    50 33        
635              
636             # NEED ANSWER: does Micro$oft Windows use *.lib file extension (suffix) for both *.o and *.a assembled object files?
637             # but does that only apply when using the M$ VC++ compiler? so does it apply here?
638             # apply answer to ARCHIVE mode elsif block immediately below; and also for ASSEMBLE & ARCHIVE blocks in *.pm else block below that;
639             # ask similar question for *.so in *NIX vs *.dll in M$, apply to .so elsif blocks below and $filename_suffixes_supported in script/rperl
640             # if ( $OSNAME eq 'MSWin32' ) {
641             # $output_file_name_groups->[$i]->{LIB} = $output_file_name_path_prefix . $filename_suffixes_supported->{OUTPUT_BINARY}->{O}->[1];
642             # }
643             # *NIX uses *.o file extension (suffix) for assembled object files
644             # else {
645 0         0 $output_file_name_groups->[$i]->{O} = $output_file_name_path_prefix . $filename_suffixes_supported->{OUTPUT_BINARY}->{O}->[0];
646              
647             # }
648             }
649              
650             elsif ( $modes->{subcompile} eq 'ARCHIVE' ) {
651 0         0 $output_file_name_groups->[$i]->{O} = $output_file_name_path_prefix . $filename_suffixes_supported->{OUTPUT_BINARY}->{O}->[0];
652 0         0 $output_file_name_groups->[$i]->{_O_label} = ' (temporary)';
653 0         0 $output_file_name_groups->[$i]->{A} = $output_file_name_path_prefix . $filename_suffixes_supported->{OUTPUT_BINARY}->{A}->[0];
654             }
655             elsif ( $modes->{subcompile} eq 'SHARED' ) {
656 0         0 $output_file_name_groups->[$i]->{SO} = $output_file_name_path_prefix . $filename_suffixes_supported->{OUTPUT_BINARY}->{SO}->[0];
657             }
658             elsif (
659             ( $modes->{subcompile} eq 'STATIC' )
660             or ( $modes->{subcompile} eq 'DYNAMIC' )
661             or (( $modes->{subcompile} eq 'OFF' )
662             and ( ( $modes->{compile} eq 'PARSE' )
663             or ( $modes->{compile} eq 'GENERATE' )
664             or ( $modes->{compile} eq 'SAVE' )
665             or ( $modes->{compile} eq 'SUBCOMPILE' ) )
666             )
667             )
668             {
669             # Micro$oft Windows uses *.exe file extension (suffix) for compiled executables
670 964 50       2839 if ( $OSNAME eq 'MSWin32' ) {
671 0 0       0 if ( $modes->{parallel} eq 'OFF' ) {
    0          
672 0         0 $output_file_name_groups->[$i]->{EXE} = $output_file_name_path_prefix . $filename_suffixes_supported->{OUTPUT_BINARY}->{EXE}->[1];
673             }
674             elsif ( $modes->{parallel} eq 'OPENMP' ) {
675             $output_file_name_groups->[$i]->{OPENMP_EXE}
676 0         0 = $output_file_name_path_prefix . $filename_suffixes_supported->{OUTPUT_BINARY}->{OPENMP_EXE}->[1];
677             }
678             }
679              
680             # traditionally, *NIX has no file extension (suffix) for compiled executables, non-suffix
681             else {
682 964 50       2561 if ( $modes->{parallel} eq 'OFF' ) {
    0          
683 964         5396 $output_file_name_groups->[$i]->{EXE} = $output_file_name_path_prefix . $filename_suffixes_supported->{OUTPUT_BINARY}->{EXE}->[0];
684             }
685             elsif ( $modes->{parallel} eq 'OPENMP' ) {
686             $output_file_name_groups->[$i]->{OPENMP_EXE}
687 0         0 = $output_file_name_path_prefix . $filename_suffixes_supported->{OUTPUT_BINARY}->{OPENMP_EXE}->[0];
688             }
689             }
690             }
691              
692             # NEED ANSWER: allow this subroutine to be called even when we return empty results?
693             else {
694             die "ERROR EAR18: Invalid compile mode '"
695             . $modes->{compile}
696             . "' and/or subcompile mode '"
697             . $modes->{subcompile}
698 0         0 . "' command-line arguments specified, dying\n";
699             }
700             }
701             else { # *.pm input files may generate *.o, *.a, *.so, and/or *.pmc output files
702 366 50 0     3815 if ( $modes->{subcompile} eq 'ASSEMBLE' ) {
    50 0        
    50 33        
    50          
    50          
703 0         0 $output_file_name_groups->[$i]->{O} = $output_file_name_path_prefix . $filename_suffixes_supported->{OUTPUT_BINARY}->{O}->[0];
704             }
705             elsif ( $modes->{subcompile} eq 'ARCHIVE' ) {
706 0         0 $output_file_name_groups->[$i]->{O} = $output_file_name_path_prefix . $filename_suffixes_supported->{OUTPUT_BINARY}->{O}->[0];
707 0         0 $output_file_name_groups->[$i]->{_O_label} = ' (temporary)';
708 0         0 $output_file_name_groups->[$i]->{A} = $output_file_name_path_prefix . $filename_suffixes_supported->{OUTPUT_BINARY}->{A}->[0];
709             }
710             elsif ( $modes->{subcompile} eq 'SHARED' ) {
711 0         0 $output_file_name_groups->[$i]->{SO} = $output_file_name_path_prefix . $filename_suffixes_supported->{OUTPUT_BINARY}->{SO}->[0];
712             }
713             elsif ( $modes->{subcompile} eq 'STATIC' ) {
714              
715             # DEV NOTE: correlates to errors EAR* in script/rperl
716 0         0 die 'ERROR EAR15: Incompatible command-line arguments provided, both --static subcompile mode flag and *.pm Perl module input file, dying'
717             . "\n";
718             }
719             elsif (
720             ( $modes->{subcompile} eq 'DYNAMIC' )
721             or (( $modes->{subcompile} eq 'OFF' )
722             and ( ( $modes->{compile} eq 'PARSE' )
723             or ( $modes->{compile} eq 'GENERATE' )
724             or ( $modes->{compile} eq 'SAVE' )
725             or ( $modes->{compile} eq 'SUBCOMPILE' ) )
726             )
727             )
728             {
729 366         2672 $output_file_name_groups->[$i]->{PMC} = $output_file_name_path_prefix . $filename_suffixes_supported->{OUTPUT_SOURCE}->{PMC}->[0];
730             }
731              
732             # NEED ANSWER: allow this subroutine to be called even when we return empty results?
733             else {
734             die "ERROR EAR18: Invalid compile mode '"
735             . $modes->{compile}
736             . "' and/or subcompile mode '"
737             . $modes->{subcompile}
738 0         0 . "' command-line arguments specified, dying\n";
739             }
740             }
741              
742             # all CPP ops modes require CPP output files; H output files may optionally be generated as needed
743 1330 100       4965 if ( $modes->{ops} eq 'CPP' ) {
744 665         1676 $output_file_name_groups->[$i]->{CPP} = $output_file_name_path_prefix . $filename_suffixes_supported->{OUTPUT_SOURCE}->{CPP}->[0];
745 665         1495 $output_file_name_groups->[$i]->{H} = $output_file_name_path_prefix . $filename_suffixes_supported->{OUTPUT_SOURCE}->{H}->[0];
746 665         1048 $output_file_name_groups->[$i]->{_H_label} = ' (if needed)';
747 665 50       1826 if ( $modes->{parallel} eq 'OPENMP' ) {
748 0         0 $output_file_name_groups->[$i]->{OPENMP_CPP} = $output_file_name_path_prefix . $filename_suffixes_supported->{OUTPUT_SOURCE}->{OPENMP_CPP}->[0];
749             }
750             }
751              
752             # RPerl::diag('in Compiler::generate_output_file_names(), bottom of loop ' . $i . ' of ' . ($input_files_count - 1) . ", have \$output_file_name_groups->[$i] = \n" . Dumper( $output_file_name_groups->[$i] ) . "\n");
753             }
754 1330         4777 return $output_file_name_groups;
755             }
756              
757             # Write Source Code Files To File System
758             sub save_source_files {
759 0     0   0 { my void $RETURN_TYPE };
  0         0  
760 0         0 ( my string_hashref $source_group, my string_hashref $file_name_group, my string_hashref $modes ) = @ARG;
761              
762             # RPerl::diag( q{in Compiler::save_source_files(), received $source_group =} . "\n" . Dumper($source_group) . "\n" );
763             # RPerl::diag( q{in Compiler::save_source_files(), received $file_name_group =} . "\n" . Dumper($file_name_group) . "\n" );
764             # RPerl::diag( 'in Compiler::save_source_files(), received $modes =' . "\n" . Dumper($modes) . "\n" );
765             # RPerl::diag( 'in Compiler::save_source_files(), received $modes->{_symbol_table} =' . "\n" . Dumper($modes->{_symbol_table}) . "\n" );
766             # RPerl::diag( "\n" . 'in Compiler::save_source_files(), received $modes->{subcompile} =' . "\n" . Dumper($modes->{subcompile}) . "\n" );
767              
768 0         0 foreach my string $suffix_key ( sort keys %{$source_group} ) {
  0         0  
769 0 0       0 if ( ( substr $suffix_key, 0, 1 ) eq '_' ) { next; }
  0         0  
770 0 0 0     0 if ( ( not exists $file_name_group->{$suffix_key} )
      0        
771             or ( not defined $file_name_group->{$suffix_key} )
772             or ( $file_name_group->{$suffix_key} eq q{} ) )
773             {
774 0         0 croak("\nERROR ECOCOFI00, COMPILER, SAVE OUTPUT FILES: Expecting file name for suffix '$suffix_key', but received empty or no value, croaking");
775             }
776             }
777              
778             # CPPOPS POST-PROCESSING: set H paths in CPP files & finally create PMC file, as needed
779 0 0       0 if ( $modes->{ops} eq 'CPP' ) {
780 0         0 RPerl::verbose('SAVE PHASE 0: Final file modifications... ');
781              
782 0         0 $source_group->{CPP} = post_processor_cpp__header_unneeded( $source_group );
783 0         0 $source_group->{CPP} = post_processor_cpp__header_or_cpp_path( $source_group->{CPP}, $file_name_group->{H} );
784              
785             # MODULE POST-PROCESSING
786 0 0       0 if ( $modes->{_input_file_name} =~ /[.]pm$/xms ) {
787 0         0 $source_group = post_processor_cpp__types_change( $source_group, $modes );
788 0         0 post_processor_cpp__pmc_generate( $source_group, $file_name_group, $modes );
789             }
790 0         0 RPerl::verbose( ' done.' . "\n" );
791             }
792              
793 0         0 RPerl::verbose('SAVE PHASE 1: Format & write files to disk...');
794              
795             # RPerl::diag( 'in Compiler::save_source_files(), have [sort keys %{$source_group}] = ' . Dumper([sort keys %{$source_group}]) . "\n" );
796             # RPerl::diag( 'in Compiler::save_source_files(), have $source_group->{H} = ' . Dumper($source_group->{H}) . "\n" );
797             # RPerl::diag( 'in Compiler::save_source_files(), have $source_group = ' . Dumper($source_group) . "\n" );
798              
799             # foreach my string $suffix_key ( sort keys %{$file_name_group} ) { ## no critic qw(ProhibitPostfixControls) # SYSTEM SPECIAL 6: PERL CRITIC FILED ISSUE #639, not postfix foreach or if
800 0         0 foreach my string $suffix_key ( sort keys %{$source_group} ) { ## no critic qw(ProhibitPostfixControls) # SYSTEM SPECIAL 6: PERL CRITIC FILED ISSUE #639, not postfix foreach or if
  0         0  
801 0 0       0 if ( ( substr $suffix_key, 0, 1 ) eq '_' ) { next; }
  0         0  
802 0 0 0     0 if ( ( not exists $source_group->{$suffix_key} )
      0        
803             or ( not defined $source_group->{$suffix_key} )
804             or ( $source_group->{$suffix_key} eq q{} ) )
805             {
806 0         0 croak("\nERROR ECOCOFI05, COMPILER, SAVE OUTPUT FILES: Expecting source code for suffix '$suffix_key', but received empty or no value, croaking");
807             }
808 0         0 my filehandleref $SOURCE_FILE_HANDLE;
809 0         0 my string $file_name = $file_name_group->{$suffix_key};
810 0         0 my string $source = $source_group->{$suffix_key};
811              
812 0 0       0 if ( $file_name eq '_TEMPFILE' ) {
813 0         0 ( $SOURCE_FILE_HANDLE, $file_name )
814             = tempfile( 'tempfileXXXX', SUFFIX => ( lc $suffix_key ), UNLINK => 1, TMPDIR => 1 );
815              
816 0 0       0 print {$SOURCE_FILE_HANDLE} $source
  0         0  
817             or croak("\nERROR ECOCOFI06, COMPILER, FILE SYSTEM: Attempting to save new file '$file_name', cannot write to file,\ncroaking: $OS_ERROR");
818              
819 0 0       0 close $SOURCE_FILE_HANDLE
820             or croak("\nERROR ECOCOFI09, COMPILER, FILE SYSTEM: Attempting to save new file '$file_name', cannot close file,\ncroaking: $OS_ERROR");
821             }
822             else {
823             # overwrite existing file
824 0 0       0 if ( -f $file_name ) {
825 0 0       0 unlink $file_name
826             or croak(
827             "\nERROR ECOCOFI07, COMPILER, FILE SYSTEM: Attempting to save new file '$file_name', cannot delete existing file,\ncroaking: $OS_ERROR");
828             }
829              
830 0 0       0 open $SOURCE_FILE_HANDLE, '>', $file_name
831             or
832             croak("\nERROR ECOCOFI08, COMPILER, FILE SYSTEM: Attempting to save new file '$file_name', cannot open file for writing,\ncroaking: $OS_ERROR");
833              
834 0 0       0 print {$SOURCE_FILE_HANDLE} $source
  0         0  
835             or croak("\nERROR ECOCOFI06, COMPILER, FILE SYSTEM: Attempting to save new file '$file_name', cannot write to file,\ncroaking: $OS_ERROR");
836              
837 0 0       0 close $SOURCE_FILE_HANDLE
838             or croak("\nERROR ECOCOFI09, COMPILER, FILE SYSTEM: Attempting to save new file '$file_name', cannot close file,\ncroaking: $OS_ERROR");
839             }
840              
841             # format output code
842 0 0 0     0 if ( ( $suffix_key eq 'PMC' ) or ( $suffix_key eq 'EXE' ) ) {
    0 0        
843 0         0 my string $perltidy_path = undef;
844 0         0 $perltidy_path = can_run('perltidy'); # DEV NOTE: comment this line to disable perltidy
845 0 0       0 if ( defined $perltidy_path ) {
846             # system $perltidy_path, '-pbp', '--ignore-side-comment-lengths', '--converge', '-l=160', '-b', '-nst', q{-bext='/'}, '-q', $file_name;
847 0         0 system $perltidy_path, '-pbp', '--ignore-side-comment-lengths', '--converge', '-l=' . RPerl::Generator::PERLTIDY_LINE_WIDTH(), '-b', '-nst', q{-bext='/'}, '-q', $file_name;
848             }
849             else {
850 0         0 RPerl::warning(
851             "\n" . 'WARNING WCOCOFO00, COMPILER, PERL CODE FORMATTING: Perltidy command `perltidy` not found, abandoning formatting' . "\n" );
852             }
853             }
854             elsif ( ( $suffix_key eq 'H' ) or ( $suffix_key eq 'CPP' ) ) {
855 0         0 my string $astyle_path = can_run('astyle');
856 0 0       0 if ( defined $astyle_path ) {
857              
858             # system $astyle_path, '-q', $file_name;
859             # don't insert extra newlines, which causes accessors, mutators, and ops_types reporting subroutines to be broken into multiple lines
860 0         0 system $astyle_path, '-q', '--keep-one-line-blocks', '--keep-one-line-statements', $file_name;
861 0 0       0 if ( -f $file_name . '.orig' ) {
862 0 0       0 unlink( $file_name . '.orig' )
863             or croak( "\n"
864             . 'ERROR ECOCOFI10, COMPILER, FILE SYSTEM: Cannot delete Artistic Style original file ' . q{'}
865             . $file_name . '.orig' . q{'} . ',' . "\n"
866             . 'croaking:'
867             . $OS_ERROR );
868             }
869             }
870             else {
871 0         0 RPerl::warning( 'WARNING WCOCOFO01, COMPILER, C++ CODE FORMATTING: Artistic Style command `astyle` not found, abandoning formatting' . "\n" );
872             }
873             }
874             }
875              
876 0         0 RPerl::verbose( ' done.' . "\n" );
877 0         0 return;
878             }
879              
880             # remove unneeded __NEED_HEADER_PATH line
881             sub post_processor_cpp__header_unneeded {
882 16     16   38 { my string $RETURN_TYPE };
  16         36  
883 16         81 ( my string $source_group ) = @ARG;
884              
885             # DEV NOTE, CORRELATION #rp033: defer setting header include path until files are saved in Compiler
886 16 50 33     95 if ((not exists $source_group->{H}) or (not defined $source_group->{H})) {
887             # RPerl::diag( 'in Compiler::post_processor_cpp__header_unneeded(), removing unneeded __NEED_HEADER_PATH line' . "\n" );
888 16         42 my string $source_group_CPP_no_header = q{};
889 16         173 foreach my string $source_group_CPP_line (split /\n/, $source_group->{CPP}) {
890             # RPerl::diag( 'in Compiler::post_processor_cpp__header_unneeded(), have $source_group_CPP_line = ' . "\n" . $source_group_CPP_line . "\n" );
891 300 100       519 if ($source_group_CPP_line =~ m/__NEED_HEADER_PATH/) { next; }
  16         39  
892 284         434 $source_group_CPP_no_header .= $source_group_CPP_line . "\n";
893             }
894 16         109 return $source_group_CPP_no_header;
895             }
896             else {
897 0         0 return $source_group->{CPP};
898             }
899             }
900              
901             # replace __NEED_HEADER_PATH or __NEED_CPP_PATH with proper C++ header path
902             sub post_processor_cpp__header_or_cpp_path {
903 48     48   179 { my string $RETURN_TYPE };
  48         117  
904 48         270 ( my string $source_CPP, my string $file_path ) = @ARG;
905              
906             # remove leading '.\' or './' if present
907 48 50       416 if ( $OSNAME eq 'MSWin32' ) {
908 0 0       0 if ( ( substr $file_path, 0, 2 ) eq q{.\\} ) {
909 0         0 substr $file_path, 0, 2, q{};
910             }
911             }
912             else {
913 48 50       305 if ( ( substr $file_path, 0, 2 ) eq './' ) {
914 0         0 substr $file_path, 0, 2, q{};
915             }
916             }
917              
918 48         1171 $file_path = post_processor_cpp__lib_path_delete($file_path);
919              
920             # DEV NOTE, CORRELATION #rp033: deferred, finally set path to H module header file in CPP module file
921 48         195 $source_CPP =~ s/__NEED_HEADER_PATH/$file_path/gxms;
922 48         252 $source_CPP =~ s/__NEED_CPP_PATH/$file_path/gxms;
923 48         205 return $source_CPP;
924             }
925              
926             # remove leading library path if present, because it should already be enabled in RPerl/Inline.pm via -Ifoo subcompiler argument
927             sub post_processor_cpp__lib_path_delete {
928 48     48   130 { my string $RETURN_TYPE };
  48         115  
929 48         147 ( my string $path ) = @ARG;
930              
931             # DEV NOTE: sometimes MS Windows OS has forward slashes in the 'blib/lib/' part of the path, so we do not differentiate by OS
932 48 50       1010 if ( ( substr $path, 0, 4 ) eq 'lib\\' ) {
    50          
    50          
    50          
    50          
    50          
    50          
    0          
933 0         0 substr $path, 0, 4, q{};
934             }
935             # elsif ( ( substr $path, 0, 5 ) eq '\\lib\\' ) { # NEED ANSWER: same question as below
936             # substr $path, 0, 5, q{};
937             # }
938             elsif ( ( substr $path, 0, 6 ) eq '.\\lib\\' ) {
939 0         0 substr $path, 0, 6, q{};
940             }
941             elsif ( ( substr $path, 0, 9 ) eq 'blib\\lib\\' ) {
942 0         0 substr $path, 0, 9, q{};
943             }
944             # elsif ( ( substr $path, 0, 10 ) eq '\\blib\\lib\\' ) { # NEED ANSWER: same question as below
945             # substr $path, 0, 10, q{};
946             # }
947             elsif ( ( substr $path, 0, 11 ) eq '.\\blib\\lib\\' ) {
948 0         0 substr $path, 0, 11, q{};
949             }
950             elsif ( ( substr $path, 0, 4 ) eq 'lib/' ) {
951 0         0 substr $path, 0, 4, q{};
952             }
953             # elsif ( ( substr $path, 0, 5 ) eq '/lib/' ) { # NEED ANSWER: is there ever a case where '/lib/' would appear instead of 'lib/' or './lib/' ???
954             # substr $path, 0, 5, q{};
955             # }
956             elsif ( ( substr $path, 0, 6 ) eq './lib/' ) {
957 0         0 substr $path, 0, 6, q{};
958             }
959             elsif ( ( substr $path, 0, 9 ) eq 'blib/lib/' ) {
960 48         183 substr $path, 0, 9, q{};
961             }
962             # elsif ( ( substr $path, 0, 10 ) eq '/blib/lib/' ) { # NEED ANSWER: same question as above
963             # substr $path, 0, 10, q{};
964             # }
965             elsif ( ( substr $path, 0, 11 ) eq './blib/lib/' ) {
966 0         0 substr $path, 0, 11, q{};
967             }
968 48         214 return $path;
969             }
970              
971             # replace hard-coded PERLOPS_PERLTYPES with CPPOPS_*TYPES
972             sub post_processor_cpp__types_change {
973 16     16   37 { my string_hashref $RETURN_TYPE };
  16         35  
974 16         88 ( my string_hashref $source_group, my string_hashref $modes ) = @ARG;
975 16         129 my string $mode_tagline = $modes->{ops} . 'OPS_' . $modes->{types} . 'TYPES';
976 16 50       86 if ( exists $source_group->{H} ) {
977 0         0 $source_group->{H} =~ s/PERLOPS_PERLTYPES/$mode_tagline/gxms;
978             }
979 16 50       81 if ( exists $source_group->{CPP} ) {
980 16         72 $source_group->{CPP} =~ s/PERLOPS_PERLTYPES/$mode_tagline/gxms;
981             }
982 16         83 return $source_group;
983             }
984              
985             # remove Perl comments
986             sub post_processor_perl__comments_whitespace_delete {
987 1244     1244   2594 { my string $RETURN_TYPE };
  1244         2353  
988 1244         4013 ( my string $input_source_code ) = @ARG;
989              
990 1244         10120 my string_arrayref $input_source_code_split = [ ( split /\n/xms, $input_source_code ) ];
991 1244         4237 my string_arrayref $input_source_code_split_tmp = [];
992              
993 1244         2435 my boolean $inside_comment = 0;
994 1244         2567 my boolean $inside_string = 0;
995 1244         2254 my boolean $inside_heredoc = 0;
996 1244         3874 my boolean $inside_indent;
997             my string $open_quote_string;
998 1244         0 my string $open_quote_heredoc;
999 1244         2854 foreach my string $input_source_code_line ( @{$input_source_code_split} ) {
  1244         3349  
1000              
1001             # RPerl::diag( 'in Compiler::post_processor_perl__comments_whitespace_delete(), have $input_source_code_line = ' . q{'} . $input_source_code_line . q{'} . "\n" );
1002             # RPerl::diag( 'in C::ppp__cwd(), $iscl = ' . q{'} . $input_source_code_line . q{'} . "\n" );
1003 21482 50       35501 if ($inside_comment) {
1004 0 0       0 if ( $input_source_code_line =~ m/^=cut$/xms ) { $inside_comment = 0; next; } # delete end of multi-line POD =COMMENT
  0         0  
  0         0  
1005 0         0 next; # delete middle of multi-line POD =COMMENT
1006             }
1007 21482 100       31526 if ($inside_heredoc) {
1008 14 50       25 if ( $input_source_code_line eq $open_quote_heredoc ) { $inside_heredoc = 0; }
  0         0  
1009 14         18 push @{$input_source_code_split_tmp}, $input_source_code_line;
  14         23  
1010 14         20 next;
1011             }
1012 21468 100       45972 if ( $input_source_code_line =~ m/^\s*$/xms ) { next; } # delete blank or all-whitespace line
  1440         3139  
1013 20028 100       43494 if ( $input_source_code_line =~ m/^\s*[#][^#!]/xms ) { next; } # delete whole-line # COMMENT
  3200         5557  
1014 16828 50       31472 if ( $input_source_code_line =~ m/^=\w+/xms ) { $inside_comment = 1; next; } # delete beginning of multi-line POD =COMMENT
  0         0  
  0         0  
1015              
1016 16828         19756 $inside_indent = 1;
1017              
1018             # delete partial-line & multi-line comments, properly handling strings which contain comment characters
1019 16828         20904 my string $input_source_code_line_tmp = q{};
1020 16828         22576 my string $current_character;
1021             my string $next_character;
1022 16828         18940 my boolean $advance_one = 0;
1023 16828         31934 for my integer $i ( 0 .. ( ( length $input_source_code_line ) - 1 ) ) {
1024 525689         633441 $current_character = substr $input_source_code_line, $i, 1;
1025 525689 100 100     809367 if ( ($inside_indent) and ( $current_character !~ m/[ \t]/xms ) ) {
1026 16828         20805 $inside_indent = 0;
1027             }
1028              
1029             # advance one extra character for q{ OR #! OR ##
1030 525689 100       688747 if ($advance_one) {
1031 3204         4221 $advance_one--;
1032 3204         4013 $input_source_code_line_tmp .= $current_character;
1033 3204         5056 next;
1034             }
1035 522485 100       640593 if ( not $inside_string ) {
1036 469341 100 100     1653444 if ( $current_character eq '#' ) {
    100          
    100          
    100          
    100          
    100          
1037 4274         8371 $next_character = substr $input_source_code_line, ( $i + 1 ), 1;
1038 4274 100 100     15348 if ( ( $next_character eq '!' ) or ( $next_character eq '#' ) ) { $advance_one = 1; } # do not delete shebang #! or critics ##
  3028         6519  
1039 1246         2265 else { last; } # delete partial-line # COMMENT
1040             }
1041             elsif ( $current_character eq q{'} ) {
1042 2550         3042 $inside_string = 1;
1043 2550         3935 $open_quote_string = q{'};
1044             }
1045             elsif ( $current_character eq q{"} ) {
1046 1854         2271 $inside_string = 1;
1047 1854         2615 $open_quote_string = q{"};
1048             }
1049             elsif ( $current_character eq 'q' ) {
1050 4602         7044 $next_character = substr $input_source_code_line, ( $i + 1 ), 1;
1051 4602 100       8095 if ( $next_character eq '{' ) {
1052 176         258 $inside_string = 1;
1053 176         262 $advance_one = 1;
1054 176         268 $open_quote_string = 'q{';
1055             }
1056             }
1057             elsif ( $current_character eq '<' ) {
1058 148         295 $next_character = substr $input_source_code_line, ( $i + 1 ), 1;
1059 148 100       430 if ( $next_character eq '<' ) {
1060 2         6 $inside_heredoc = 1;
1061 2         8 $open_quote_heredoc = substr $input_source_code_line, ( $i + 2 );
1062 2 50       8 if ( ( substr $open_quote_heredoc, 0, 1 ) eq q{'} ) { substr $open_quote_heredoc, 0, 1, q{}; }
  0         0  
1063 2 50       10 if ( ( substr $open_quote_heredoc, 0, 1 ) eq q{"} ) { substr $open_quote_heredoc, 0, 1, q{}; }
  0         0  
1064 2         7 $open_quote_heredoc =~ s/\s+$//xms; # delete trailing whitespace after heredoc open quote and semicolon
1065 2 50       10 if ( ( substr $open_quote_heredoc, -1, 1 ) eq q{;} ) { substr $open_quote_heredoc, -1, 1, q{}; }
  2         8  
1066 2         9 $open_quote_heredoc =~ s/\s+$//xms; # delete whitespace between heredoc open quote and semicolon
1067 2 50       9 if ( ( substr $open_quote_heredoc, -1, 1 ) eq q{'} ) { substr $open_quote_heredoc, -1, 1, q{}; }
  0         0  
1068 2 50       8 if ( ( substr $open_quote_heredoc, -1, 1 ) eq q{"} ) { substr $open_quote_heredoc, -1, 1, q{}; }
  0         0  
1069             }
1070             }
1071              
1072             # delete extra whitespace inserted by Perl::Tidy
1073             elsif ( ( not $inside_indent ) and ( $current_character =~ m/[ \t]/xms ) ) {
1074 51679         75555 $next_character = substr $input_source_code_line, ( $i + 1 ), 1;
1075 51679 100       84749 if ( $next_character =~ m/[ \t]/xms ) { next; } # delete extra whitespace
  4501         7429  
1076             }
1077             }
1078             else { # $inside_string
1079 53144 100 100     153552 if ( ( $current_character eq q{'} ) and ( $open_quote_string eq q{'} ) ) { $inside_string = 0; }
  2546 100 100     3382  
    100 100        
1080 1854         3143 elsif ( ( $current_character eq q{"} ) and ( $open_quote_string eq q{"} ) ) { $inside_string = 0; }
1081 176         239 elsif ( ( $current_character eq '}' ) and ( $open_quote_string eq 'q{' ) ) { $inside_string = 0; }
1082             }
1083 516738         640391 $input_source_code_line_tmp .= $current_character;
1084             }
1085 16828         22394 $input_source_code_line = $input_source_code_line_tmp;
1086              
1087 16828         40983 $input_source_code_line =~ s/[ \t]+$//xms; # delete trailing whitespace, if present
1088              
1089 16828         20195 push @{$input_source_code_split_tmp}, $input_source_code_line;
  16828         41393  
1090             }
1091 1244         2047 return join "\n", @{$input_source_code_split_tmp};
  1244         17350  
1092             }
1093              
1094             # remove C++ comments
1095             # NEED TEST: create full tests for this subroutine
1096             sub post_processor_cpp__comments_whitespace_delete {
1097 32     32   75 { my string $RETURN_TYPE };
  32         58  
1098 32         119 ( my string $input_source_code ) = @ARG;
1099              
1100 32         1941 my string_arrayref $input_source_code_split = [ ( split /\n/xms, $input_source_code ) ];
1101 32         162 my string_arrayref $input_source_code_split_tmp = [];
1102              
1103 32         64 my boolean $inside_comment = 0;
1104 32         55 my boolean $inside_string = 0;
1105 32         57 my string $open_quote;
1106 32         50 foreach my string $input_source_code_line ( @{$input_source_code_split} ) {
  32         103  
1107 1226 50       1926 if ($inside_comment) {
1108 0 0       0 if ( $input_source_code_line =~ m!\*/!xms ) {
1109 0         0 $input_source_code_line =~ s!^(.*\*/)!!xms; # delete end of multi-line /* COMMENT */
1110 0         0 $inside_comment = 0;
1111             }
1112 0         0 else { next; } # delete middle of multi-line /* COMMENT */
1113             }
1114 1226 100       2717 if ( $input_source_code_line =~ m/^\s*$/xms ) { next; } # delete blank or all-whitespace line
  597         904  
1115 629 100       1358 if ( $input_source_code_line =~ m!^\s*//!xms ) { next; } # delete whole-line // COMMENT
  95         203  
1116 534 50       970 if ( $input_source_code_line =~ m!^\s*/\*.*\*/\s*$!xms ) { next; } # delete whole-line /* COMMENT */
  0         0  
1117              
1118             # delete partial-line & multi-line comments, properly handling strings which contain comment characters
1119 534         735 my string $input_source_code_line_tmp = q{};
1120 534         740 my string $current_character;
1121             my string $next_character;
1122 534         626 my boolean $advance_one = 0;
1123 534         1062 for my integer $i ( 0 .. ( ( length $input_source_code_line ) - 1 ) ) {
1124 21774         26699 $current_character = substr $input_source_code_line, $i, 1;
1125              
1126             # advance one extra character for \' or \" or /* or */
1127 21774 100       30366 if ($advance_one) {
1128 4         14 $advance_one = 0;
1129 4         11 $input_source_code_line_tmp .= $current_character;
1130 4         15 next;
1131             }
1132 21770 100       27266 if ( not $inside_string ) {
1133 19752 50       24527 if ($inside_comment) {
1134 0 0       0 if ( $current_character eq '*' ) {
1135 0         0 $next_character = substr $input_source_code_line, ( $i + 1 ), 1;
1136 0 0       0 if ( $next_character eq '/' ) {
1137              
1138             # delete end of partial-line /* COMMENT */
1139 0         0 $advance_one = 1;
1140 0         0 $inside_comment = 0;
1141 0         0 next;
1142             }
1143             }
1144 0         0 else { next; } # delete middle of partial-line /* COMMENT */
1145             }
1146             else { # not $inside_comment
1147 19752 50       36955 if ( $current_character eq '/' ) {
    50          
    100          
1148 0         0 $next_character = substr $input_source_code_line, ( $i + 1 ), 1;
1149 0 0       0 if ( $next_character eq '/' ) { last; } # delete partial-line // COMMENT
  0 0       0  
1150             elsif ( $next_character eq '*' ) {
1151              
1152             # delete beginning of partial-line or multi-line /* COMMENT */
1153 0         0 $advance_one = 1;
1154 0         0 $inside_comment = 1;
1155 0         0 next;
1156             }
1157             }
1158             elsif ( $current_character eq q{'} ) {
1159 0         0 $inside_string = 1;
1160 0         0 $open_quote = q{'};
1161             }
1162             elsif ( $current_character eq q{"} ) {
1163 146         169 $inside_string = 1;
1164 146         232 $open_quote = q{"};
1165             }
1166              
1167             # NEED UPGRADE: can not delete extra whitespace characters here, because it destroys indentation
1168             # elsif ( $current_character =~ m/[ \t]/ ) {
1169             # $next_character = substr $input_source_code_line, ( $i + 1 ), 1;
1170             # if ( $next_character =~ m/[ \t]/ ) { next; } # delete extra whitespace
1171             # }
1172             }
1173             }
1174             else { # $inside_string
1175 2018 50 66     5144 if ( ( $current_character eq q{'} ) and ( $open_quote eq q{'} ) ) { $inside_string = 0; }
  0 100 66     0  
    100          
1176 146         193 elsif ( ( $current_character eq q{"} ) and ( $open_quote eq q{"} ) ) { $inside_string = 0; }
1177             elsif ( $current_character eq '\\' ) {
1178 10         39 $next_character = substr $input_source_code_line, ( $i + 1 ), 1;
1179              
1180             # backslash-escaped quotes do not close a string
1181 10 50 33     58 if ( ( $next_character eq q{'} ) and ( $open_quote eq q{'} ) ) { $advance_one = 1; }
  0         0  
1182 10 100 66     66 if ( ( $next_character eq q{"} ) and ( $open_quote eq q{"} ) ) { $advance_one = 1; }
  4         22  
1183             }
1184             }
1185 21770         26452 $input_source_code_line_tmp .= $current_character;
1186             }
1187 534         844 $input_source_code_line = $input_source_code_line_tmp;
1188              
1189 534         1469 $input_source_code_line =~ s/[ \t]+$//xms; # delete trailing whitespace, if present
1190              
1191 534         636 push @{$input_source_code_split_tmp}, $input_source_code_line;
  534         1652  
1192             }
1193 32         56 return join "\n", @{$input_source_code_split_tmp};
  32         760  
1194             }
1195              
1196             # remove unnecessary absolute paths
1197             sub post_processor__absolute_path_delete {
1198 7971     7971   10809 { my string $RETURN_TYPE };
  7971         9866  
1199 7971         11544 ( my string $input_path ) = @ARG;
1200              
1201             # RPerl::diag( 'in Compiler::post_processor__absolute_path_delete(), received $input_path = ' . $input_path . "\n" );
1202              
1203 7971 50       19116 if ( $OSNAME eq 'MSWin32' ) {
1204 0         0 $input_path =~ s/\\/\//gxms;
1205             # RPerl::diag( 'in Compiler::post_processor__absolute_path_delete(), Windows OS detected, have possibly-reformatted $input_path = ' . $input_path . "\n" );
1206             }
1207              
1208 7971         33187 my string $current_working_directory = getcwd;
1209              
1210             # RPerl::diag( 'in Compiler::post_processor__absolute_path_delete(), have $current_working_directory = ' . $current_working_directory . "\n" );
1211              
1212 7971 100       19120 if ( ( substr $input_path, 0, ( length $current_working_directory ) ) eq $current_working_directory ) {
1213 2572         5350 return substr $input_path, ( ( length $current_working_directory ) + 1 );
1214             }
1215 5399         13447 return $input_path; # this comment is a test of find_replace_old_subroutine_headers.sh
1216             }
1217              
1218             # remove unnecessary current-directory paths
1219             sub post_processor__current_directory_path_delete {
1220 1418     1418   2333 { my string $RETURN_TYPE };
  1418         2453  
1221 1418         3123 ( my string $input_path ) = @ARG;
1222              
1223             # RPerl::diag( 'in Compiler::post_processor__current_directory_path_delete(), received $input_path = ' . $input_path . "\n" );
1224              
1225 1418 50       4221 if ( $OSNAME eq 'MSWin32' ) {
1226 0         0 $input_path =~ s/\\/\//gxms;
1227             # RPerl::diag( 'in Compiler::post_processor__current_directory_path_delete(), Windows OS detected, have possibly-reformatted $input_path = ' . $input_path . "\n" );
1228             }
1229              
1230 1418 50       5621 if ( ( substr $input_path, 0, 2 ) eq './' ) {
1231 0         0 return substr $input_path, 2;
1232             }
1233 1418         3482 return $input_path; # this comment is a test of find_replace_old_subroutine_headers.sh
1234             }
1235              
1236             # generate PMC file
1237             sub post_processor_cpp__pmc_generate {
1238 0     0     { my void $RETURN_TYPE };
  0            
1239 0           ( my string_hashref $source_group, my string_hashref $file_name_group, my string_hashref $modes ) = @ARG;
1240              
1241             # NEED FIX WIN32: handle back-slash for Win32 instead of forward-slash only for *NIX
1242 0           my string $cpp_file_path = $file_name_group->{CPP};
1243 0           $cpp_file_path = post_processor_cpp__lib_path_delete($cpp_file_path);
1244              
1245             # DEV NOTE: barely-documented Inline::CPP bug, must have leading './' if no other directories in path
1246 0 0         if ( $cpp_file_path !~ /\// ) {
1247 0 0         if ( $OSNAME eq 'MSWin32' ) {
1248 0           $cpp_file_path .= q{.\\};
1249             }
1250             else {
1251 0           $cpp_file_path .= q{./};
1252             }
1253             }
1254              
1255             # DEV NOTE: only generate PMC output file in dynamic (default) subcompile mode
1256 0 0         if ( $modes->{subcompile} eq 'DYNAMIC' ) {
1257 0 0 0       if ( ( exists $source_group->{PMC} ) and ( defined $source_group->{PMC} ) and ( $source_group->{PMC} ne q{} ) ) {
      0        
1258              
1259             # RPerl::diag( q{in Compiler::save_source_files(), have $source_group = } . Dumper($source_group) . "\n" );
1260 0           die 'ERROR ECOCOFI01, COMPILER, SAVE OUTPUT FILES, MODULE TEMPLATE COPY: Received non-empty PMC source, dying' . "\n";
1261             }
1262              
1263             # RPerl::diag( q{in Compiler::save_source_files(), have %INC = } . Dumper(\%INC) . "\n" );
1264             # RPerl::diag( q{in Compiler::save_source_files(), have @INC = } . Dumper(\@INC) . "\n" );
1265             # RPerl::diag( q{in Compiler::save_source_files(), have $source_group->{_package_names_underscores} = } . Dumper($source_group->{_package_names_underscores}) . "\n" );
1266             # RPerl::diag( q{in Compiler::save_source_files(), have $source_group->{_package_names} = } . Dumper($source_group->{_package_names}) . "\n" );
1267              
1268 0           my string_arrayref $module_names_split = [ ( split /\n/, $source_group->{_package_names} ) ];
1269 0           my string_arrayref $module_names_underscores_split = [ ( split /\n/, $source_group->{_package_names_underscores} ) ];
1270              
1271             # RPerl::diag( q{in Compiler::save_source_files(), have $module_names_split = } . Dumper($module_names_split) . "\n" );
1272              
1273 0           my integer $module_count = scalar @{$module_names_split};
  0            
1274 0           my string $module_name = shift @{$module_names_split};
  0            
1275 0           my string $module_name_underscores = shift @{$module_names_underscores_split};
  0            
1276 0           my integer $i = 0;
1277              
1278             # deferred, finally insert constants shims
1279             # RPerl::diag('in Compiler::save_source_files(), have $source_group->{_H_constants_shims}->{$module_name_underscores} = ' . $source_group->{_H_constants_shims}->{$module_name_underscores} . "\n");
1280              
1281 0           while ( defined $module_name_underscores ) {
1282              
1283             # RPerl::diag( q{in Compiler::save_source_files(), have $cpp_file_path = } . $cpp_file_path . "\n" );
1284             # RPerl::diag( q{in Compiler::save_source_files(), have $module_name_underscores = } . $module_name_underscores . "\n" );
1285              
1286             # utilize modified copies of Module PMC template file
1287 0           my string $module_pmc_filename_manual;
1288 0 0         if ( $module_count == 1 ) {
1289 0           $module_pmc_filename_manual = $RPerl::INCLUDE_PATH . '/RPerl/CompileUnit/Module.pmc.CPPOPS_DUALTYPES_TEMPLATE';
1290             }
1291             else {
1292 0 0         if ( $i == ( $module_count - 1 ) ) {
1293 0           $module_pmc_filename_manual = $RPerl::INCLUDE_PATH . '/RPerl/CompileUnit/Module.pmc.CPPOPS_DUALTYPES_TEMPLATE_MONOLITH';
1294             }
1295             else {
1296 0           $module_pmc_filename_manual = $RPerl::INCLUDE_PATH . '/RPerl/CompileUnit/Module.pmc.CPPOPS_DUALTYPES_TEMPLATE_MONOLITH_SECONDARY';
1297             }
1298             }
1299              
1300             # RPerl::diag( 'in Compiler::save_source_files(), have $module_pmc_filename_manual = ' . $module_pmc_filename_manual . "\n" );
1301             # RPerl::diag( 'in Compiler::save_source_files(), have $source_group->{_PMC_accessors_mutators_shims} = ' . Dumper($source_group->{_PMC_accessors_mutators_shims}) . "\n" );
1302             # RPerl::diag( 'in Compiler::save_source_files(), have $source_group->{_PMC_subroutines_shims} = ' . Dumper($source_group->{_PMC_subroutines_shims}) . "\n" );
1303             # RPerl::diag( 'in Compiler::save_source_files(), have $source_group->{_PMC_includes} = ' . Dumper($source_group->{_PMC_includes}) . "\n" );
1304              
1305 0 0         if ( not -f $module_pmc_filename_manual ) {
1306 0           die 'ERROR ECOCOFI02, COMPILER, SAVE OUTPUT FILES, MODULE TEMPLATE COPY: File not found, ' . q{'}
1307             . $module_pmc_filename_manual . q{'} . "\n"
1308             . ', dying' . "\n";
1309             }
1310              
1311 0 0         open my filehandleref $FILE_HANDLE, '<', $module_pmc_filename_manual
1312             or die 'ERROR ECOCOFI03, COMPILER, SAVE OUTPUT FILES, MODULE TEMPLATE COPY: Cannot open file '
1313             . $module_pmc_filename_manual
1314             . ' for reading, '
1315             . $OS_ERROR
1316             . ', dying' . "\n";
1317              
1318             # deferred, finally read in Module PMC template file, replace package name and paths, add accessor/mutator shim methods
1319 0           my string $file_line;
1320 0           my string $file_string = q{};
1321 0           my string $pm_file_path = $file_name_group->{PMC};
1322 0           chop $pm_file_path; # remove the 'c' from 'pmc' file suffix
1323 0           while ( $file_line = <$FILE_HANDLE> ) {
1324              
1325             # $file_line =~ s/lib\/RPerl\/CompileUnit\/Module\.cpp/$cpp_file_path/gxms;
1326 0           $file_line =~ s/RPerl\/CompileUnit\/Module\.cpp/$cpp_file_path/gxms;
1327 0           $file_line =~ s/RPerl::CompileUnit::Module/$module_name/gxms;
1328 0           $file_line =~ s/RPerl__CompileUnit__Module/$module_name_underscores/gxms;
1329 0 0         if ( $file_line eq
    0          
    0          
    0          
    0          
    0          
    0          
1330             ( '# <<< OO PROPERTIES, ACCESSORS & MUTATORS, SHIMS >>> # <<< CHANGE_ME: add real shims after this line or delete it >>>' . "\n" ) )
1331             {
1332 0 0 0       if ( ( exists $source_group->{_PMC_accessors_mutators_shims}->{$module_name_underscores} )
1333             and ( defined $source_group->{_PMC_accessors_mutators_shims}->{$module_name_underscores} ) )
1334             {
1335             $file_line
1336 0           = ( substr $file_line, 0, 52 ) . "\n" . $source_group->{_PMC_accessors_mutators_shims}->{$module_name_underscores} . "\n\n";
1337             }
1338 0           else { $file_line = undef; }
1339             }
1340             elsif (
1341             $file_line eq ( '# <<< OO PROPERTIES, SUBROUTINES, SHIMS >>> # <<< CHANGE_ME: add real shims after this line or delete it >>>' . "\n" ) )
1342             {
1343 0 0 0       if ( ( exists $source_group->{_PMC_subroutines_shims}->{$module_name_underscores} )
1344             and ( defined $source_group->{_PMC_subroutines_shims}->{$module_name_underscores} ) )
1345             {
1346 0           $file_line = ( substr $file_line, 0, 43 ) . "\n" . $source_group->{_PMC_subroutines_shims}->{$module_name_underscores} . "\n\n";
1347             }
1348 0           else { $file_line = undef; }
1349             }
1350             elsif ( $file_line eq ( '# <<< CHANGE_ME: add distribution-specific config include here >>>' . "\n" ) ) {
1351 0           my string $distribution_package = ( split /::/, $source_group->{_package_name} )[0];
1352 0           $file_line = 'use ' . $distribution_package . '::Config;' . "\n";
1353             }
1354             elsif ( $file_line eq ( '# <<< CHANGE_ME: add user-defined includes here >>>' . "\n" ) ) {
1355 0 0 0       if ( ( exists $source_group->{_PMC_includes}->{$module_name_underscores} )
1356             and ( defined $source_group->{_PMC_includes}->{$module_name_underscores} ) )
1357             {
1358 0           $file_line = $source_group->{_PMC_includes}->{$module_name_underscores} . "\n\n";
1359             }
1360 0           else { $file_line = undef; }
1361             }
1362             elsif ( $file_line eq ( ' # <<< CHANGE_ME: enable optional SSE support here >>>' . "\n" ) ) {
1363              
1364             # RPerl::diag( 'in Compiler::save_source_files(), have $modes->{_enable_sse} = ' . Dumper($modes->{_enable_sse}) . "\n" );
1365 0 0 0       if ( ( exists $modes->{_enable_sse} )
      0        
      0        
      0        
1366             and ( defined $modes->{_enable_sse} )
1367             and ( exists $modes->{_enable_sse}->{$pm_file_path} )
1368             and ( defined $modes->{_enable_sse}->{$pm_file_path} )
1369             and $modes->{_enable_sse}->{$pm_file_path} )
1370             {
1371 0           $file_line = q( $RPerl::Inline::ARGS{optimize} .= ' -mfpmath=sse -msse3'; # enable SSE support) . "\n";
1372 0           $file_line
1373             .= q( $RPerl::Inline::ARGS{auto_include} = ['#include <immintrin.h>', @{$RPerl::Inline::ARGS{auto_include}}]; # enable SSE support)
1374             . "\n";
1375             }
1376 0           else { $file_line = undef; }
1377             }
1378             elsif ( $file_line eq ( ' # <<< CHANGE_ME: enable optional GMP support here >>>' . "\n" ) ) {
1379              
1380             # RPerl::diag( 'in Compiler::save_source_files(), have $modes->{_enable_gmp} = ' . Dumper($modes->{_enable_gmp}) . "\n" );
1381             # RPerl::diag( 'in Compiler::save_source_files(), have $pm_file_path = ' . $pm_file_path . "\n" );
1382 0 0 0       if ( ( exists $modes->{_enable_gmp} )
      0        
      0        
      0        
1383             and ( defined $modes->{_enable_gmp} )
1384             and ( exists $modes->{_enable_gmp}->{$pm_file_path} )
1385             and ( defined $modes->{_enable_gmp}->{$pm_file_path} )
1386             and $modes->{_enable_gmp}->{$pm_file_path} )
1387             {
1388 0           $file_line = q( $RPerl::Inline::ARGS{libs} = '-lgmpxx -lgmp'; # enable GMP support) . "\n";
1389 0           $file_line
1390             .= q( $RPerl::Inline::ARGS{auto_include} = [ @{ $RPerl::Inline::ARGS{auto_include} }, '#include <gmpxx.h>', '#include <gmp.h>' ]; # enable GMP support)
1391             . "\n";
1392             }
1393 0           else { $file_line = undef; }
1394             }
1395             elsif ( $file_line eq ( ' # <<< CHANGE_ME: enable optional GSL support here >>>' . "\n" ) ) {
1396             # RPerl::diag( 'in Compiler::save_source_files(), have $modes->{_enable_gsl} = ' . Dumper($modes->{_enable_gsl}) . "\n" );
1397             # RPerl::diag( 'in Compiler::save_source_files(), have $pm_file_path = ' . $pm_file_path . "\n" );
1398 0           $pm_file_path = post_processor__absolute_path_delete($pm_file_path);
1399 0           $pm_file_path = post_processor__current_directory_path_delete($pm_file_path);
1400             # RPerl::diag( 'in Compiler::save_source_files(), have possibly-trimmed $pm_file_path = ' . $pm_file_path . "\n" );
1401            
1402 0 0 0       if ( ( exists $modes->{_enable_gsl} )
      0        
      0        
      0        
1403             and ( defined $modes->{_enable_gsl} )
1404             and ( exists $modes->{_enable_gsl}->{$pm_file_path} )
1405             and ( defined $modes->{_enable_gsl}->{$pm_file_path} )
1406             and $modes->{_enable_gsl}->{$pm_file_path} )
1407             {
1408             # DEV NOTE: linking instructions https://www.gnu.org/software/gsl/doc/html/usage.html#linking-programs-with-the-library
1409 0           $file_line = q( $RPerl::Inline::ARGS{libs} = '-lgsl -lgslcblas -lm'; # enable GSL support) . "\n";
1410 0           $file_line .= q( $RPerl::Inline::ARGS{inc} .= ' -I' . $RPerl::Inline::gsl_include_dir; # enable GSL support) . "\n";
1411 0           $file_line
1412             .= q( $RPerl::Inline::ARGS{auto_include} = [ @{ $RPerl::Inline::ARGS{auto_include} }, '#include <gsl_matrix.h>', '#include <gsl_blas.h>' ]; # enable GSL support)
1413             . "\n";
1414             }
1415 0           else { $file_line = undef; }
1416             }
1417              
1418 0 0         if ( defined $file_line ) { $source_group->{PMC} .= $file_line; }
  0            
1419             }
1420              
1421 0 0         close $FILE_HANDLE
1422             or die 'ERROR ECOCOFI04, COMPILER, SAVE OUTPUT FILES, MODULE TEMPLATE COPY: Cannot close file '
1423             . $module_pmc_filename_manual
1424             . ' after reading, '
1425             . $OS_ERROR
1426             . ', dying' . "\n";
1427              
1428 0           $module_name = shift @{$module_names_split};
  0            
1429 0           $module_name_underscores = shift @{$module_names_underscores_split};
  0            
1430 0           $i++;
1431             }
1432             }
1433 0           return;
1434             }
1435              
1436             # Auto-Parallelize from Serial C++ File to Parallel C++ File via Pluto PolyCC & OpenMP
1437             sub cpp_to_openmp_cpp {
1438 0     0     { my void $RETURN_TYPE };
  0            
1439 0           ( my string_hashref $cpp_output_file_name_group, my string_hashref $modes ) = @ARG;
1440              
1441 0           RPerl::diag( q{in Compiler::cpp_to_openmp_cpp(), received $cpp_output_file_name_group =} . "\n" . Dumper($cpp_output_file_name_group) . "\n" );
1442              
1443             # RPerl::diag( q{in Compiler::cpp_to_openmp_cpp(), received $modes =} . "\n" . Dumper($modes) . "\n" );
1444              
1445             # RPerl::diag( q{in Compiler::cpp_to_openmp_cpp(), NOT DOING ANYTHING YET} . "\n" );
1446             # return;
1447             # die 'TMP DEBUG';
1448              
1449             # START HERE: modify pluto min/max macros & calls, modify final g++ command
1450             # START HERE: modify pluto min/max macros & calls, modify final g++ command
1451             # START HERE: modify pluto min/max macros & calls, modify final g++ command
1452              
1453             # THEN START HERE, NEED FIX PARALLEL: enable non-pluto min/max sub calls, re-enable prints
1454 0           RPerl::verbose('PARALLELIZE: Generate OpenMP Code... ');
1455              
1456 0           my string $polycc_path = can_run('polycc');
1457 0 0         if ( not defined $polycc_path ) {
1458 0           die 'ERROR Exxxxx, COMPILER, PARALLELIZATION: Pluto PolyCC command `polycc` not found, dying';
1459             }
1460             my string $polycc_command
1461 0           = $polycc_path . q{ } . $cpp_output_file_name_group->{CPP} . ' -o ' . $cpp_output_file_name_group->{OPENMP_CPP} . ' --parallel --tile';
1462              
1463 0           RPerl::diag( 'in Compiler::cpp_to_openmp_cpp(), have $polycc_command =' . "\n\n" . $polycc_command . "\n" );
1464              
1465             # ACTUALLY RUN POLYCC COMMAND
1466             # my $pid = open3( 0, \*POLYCC_STDOUT, \*POLYCC_STDERR, $polycc_command ); # disable STDIN w/ 0
1467             #
1468             # my $stdout_select;
1469             # my $stderr_select;
1470             # if ( $OSNAME ne 'MSWin32' ) {
1471             # $stdout_select = IO::Select->new();
1472             # $stderr_select = IO::Select->new();
1473             # $stdout_select->add( \*POLYCC_STDOUT );
1474             # $stderr_select->add( \*POLYCC_STDERR );
1475             # }
1476             #
1477              
1478 0           my string $polycc_command_stdout = q{};
1479 0           my string $polycc_command_stderr = q{};
1480              
1481             #if ( $OSNAME eq 'MSWin32' || $stdout_select->can_read(0) ) { sysread POLYCC_STDOUT, $polycc_command_stdout, 4096; }
1482             # if ( $OSNAME eq 'MSWin32' || $stderr_select->can_read(0) ) { sysread POLYCC_STDERR, $polycc_command_stderr, 4096; }
1483             # waitpid $pid, 0;
1484             # if ( $OSNAME eq 'MSWin32' || $stdout_select->can_read(0) ) { my $s; sysread POLYCC_STDOUT, $s, 4096; $polycc_command_stdout .= $s; }
1485             # if ( $OSNAME eq 'MSWin32' || $stderr_select->can_read(0) ) { my $s; sysread POLYCC_STDERR, $s, 4096; $polycc_command_stderr .= $s; }
1486              
1487             #my $pid = open3( 0, \*POLYCC_STDOUT, \*POLYCC_STDERR, $polycc_command ); # disable STDIN w/ 0
1488 0           run3( $polycc_command, \undef, \$polycc_command_stdout, \$polycc_command_stderr );
1489              
1490 0           my $test_exit_status = $CHILD_ERROR >> 8;
1491              
1492             # RPerl::diag( 'in Compiler::cpp_to_openmp_cpp(), have $CHILD_ERROR = ' . $CHILD_ERROR . "\n" );
1493             # RPerl::diag( 'in Compiler::cpp_to_openmp_cpp(), have $test_exit_status = ' . $test_exit_status . "\n" );
1494              
1495 0           RPerl::verbose( ' done.' . "\n" );
1496              
1497             # if ($polycc_command_stdout) { RPerl::diag( "===STDOUT=BEGIN===\n" . $polycc_command_stdout . "===STDOUT=END===\n" ); }
1498             # if ($polycc_command_stderr) { RPerl::diag( "===STDERR=BEGIN===\n" . $polycc_command_stderr . "===STDERR=END===\n" ); }
1499 0   0       my boolean $polycc_command_stdout_content = ( ( defined $polycc_command_stdout ) and ( $polycc_command_stdout =~ m/[^\s]+/g ) );
1500 0   0       my boolean $polycc_command_stderr_content = ( ( defined $polycc_command_stderr ) and ( $polycc_command_stderr =~ m/[^\s]+/g ) );
1501              
1502 0 0 0       if ( $polycc_command_stdout_content or $polycc_command_stderr_content ) {
1503 0           RPerl::diag("\n");
1504 0 0         if ($polycc_command_stdout_content) {
1505 0           RPerl::diag( '[[[ POLYCC STDOUT ]]]' . "\n\n" . $polycc_command_stdout . "\n" );
1506             }
1507 0 0         if ($polycc_command_stderr_content) {
1508 0           RPerl::diag( '[[[ POLYCC STDERR ]]]' . "\n\n" . $polycc_command_stderr . "\n" );
1509             }
1510             # NEED FIX PARALLEL: actually test polycc output for failure or error messages, etc.
1511             # if ( $test_exit_status == 0 ) { # UNIX process return code 0, success
1512             # RPerl::warning( 'WARNING WCOCOSU00, COMPILER, POLYCC: Pluto PolyCC 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" );
1513             # }
1514             }
1515              
1516 0 0         if ($test_exit_status) { # UNIX process return code not 0, error
1517 0 0 0       if ( not( $polycc_command_stdout_content or $polycc_command_stderr_content ) ) {
1518 0           RPerl::diag( "\n" . '[[[ POLYCC STDOUT & STDERR ARE BOTH EMPTY ]]]' . "\n\n" );
1519             }
1520 0           croak 'ERROR Exxxxx, COMPILER, POLYCC: Pluto PolyCC compiler returned error code,' . "\n"
1521             . 'please run again with `rperl -D` command or RPERL_DEBUG=1 environmental variable for error messages if none appear above,' . "\n"
1522             . 'croaking';
1523             }
1524            
1525             # NEED FIX PARALLEL: temporarily disable all user-defined or non-pluto uses of string 'min' and 'max' within parallel loop
1526              
1527 0 0 0       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} )) {
      0        
1528 0           die 'ERROR Exxxxx, COMPILER, PARALLELIZATION: Missing or invalid Pluto PolyCC output file, ' . q{'} . $cpp_output_file_name_group->{OPENMP_CPP} . q{'} . "\n" . ', dying' . "\n";
1529             }
1530              
1531             open my filehandleref $FILE_HANDLE_POLYCC, '<', $cpp_output_file_name_group->{OPENMP_CPP}
1532 0 0         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";
1533              
1534             # read in file, strip blank lines
1535 0           my string $file_line_polycc;
1536 0           my string $string_polycc = q{};
1537 0           while ( $file_line_polycc = <$FILE_HANDLE_POLYCC> ) {
1538 0           $file_line_polycc =~ s/min/polyccmin/gxms;
1539 0           $file_line_polycc =~ s/max/polyccmax/gxms;
1540 0           $string_polycc .= $file_line_polycc;
1541             }
1542              
1543             close $FILE_HANDLE_POLYCC
1544 0 0         or die 'ERROR Exxxxx, COMPILER, PARALLELIZATION: Cannot close file ' . q{'} . $cpp_output_file_name_group->{OPENMP_CPP} . q{'} . ' after reading, ' . $OS_ERROR . ', dying' . "\n";
1545              
1546             open $FILE_HANDLE_POLYCC, '>', $cpp_output_file_name_group->{OPENMP_CPP}
1547 0 0         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";
1548              
1549 0           print {$FILE_HANDLE_POLYCC} $string_polycc;
  0            
1550              
1551             close $FILE_HANDLE_POLYCC
1552 0 0         or die 'ERROR Exxxxx, COMPILER, PARALLELIZATION: Cannot close file ' . q{'} . $cpp_output_file_name_group->{OPENMP_CPP} . q{'} . ' after writing, ' . $OS_ERROR . ', dying' . "\n";
1553 0           return;
1554             }
1555              
1556             # Sub-Compile from C++-Parsable String to Perl-Linkable XS & Machine-Readable Binary
1557             sub cpp_to_xsbinary__subcompile {
1558 0     0     { my void $RETURN_TYPE };
  0            
1559 0           ( my string_hashref $cpp_output_file_name_group, my string_hashref $modes ) = @ARG;
1560              
1561             # RPerl::diag( q{in Compiler::cpp_to_xsbinary__subcompile(), received $cpp_output_file_name_group =} . "\n" . Dumper($cpp_output_file_name_group) . "\n" );
1562             # RPerl::diag( q{in Compiler::cpp_to_xsbinary__subcompile(), received $modes =} . "\n" . Dumper($modes) . "\n" );
1563              
1564 0 0 0       if ( ( $modes->{_input_file_name} =~ /[.]pl$/xms ) or ( $modes->{subcompile} ne 'DYNAMIC' ) ) {
1565 0           RPerl::verbose('SUBCOMPILE: Generate binary... ');
1566              
1567 0 0 0       if ( $modes->{subcompile} eq 'OFF' ) {
    0 0        
      0        
      0        
1568 0           croak 'ERROR ECOCOSU00, COMPILER, SUBCOMPILE: Received incorrect subcompile mode OFF while inside subcompile subroutine, croaking';
1569             }
1570             elsif ( ( $modes->{subcompile} ne 'ASSEMBLE' )
1571             and ( $modes->{subcompile} ne 'ARCHIVE' )
1572             and ( $modes->{subcompile} ne 'SHARED' )
1573             and ( $modes->{subcompile} ne 'STATIC' )
1574             and ( $modes->{subcompile} ne 'DYNAMIC' ) )
1575             {
1576             croak 'ERROR ECOCOSU01, COMPILER, SUBCOMPILE: Received invalid subcompile mode ' . q{'}
1577 0           . $modes->{subcompile} . q{'}
1578             . ' while inside subcompile subroutine, croaking';
1579             }
1580              
1581 0           my string $subcompile_command = $modes->{CXX};
1582              
1583 0 0 0       if ( ( $modes->{subcompile} eq 'ASSEMBLE' )
    0 0        
1584             or ( $modes->{subcompile} eq 'ARCHIVE' ) )
1585             {
1586             # stop the subcompiler after the assemble phase, output .o file; not in original Inline::CPP subcompile command
1587 0           $subcompile_command .= q{ } . '-c';
1588             }
1589             elsif (( $modes->{subcompile} eq 'STATIC' )
1590             or ( $modes->{subcompile} eq 'DYNAMIC' ) )
1591             {
1592             # Perl requires pthreads, at least Perls compiled with thread support do; not in original Inline::CPP subcompile command
1593             # NEED ANSWER: test for non-threaded Perl to avoid including pthread support?
1594 0           $subcompile_command .= q{ } . '-pthread';
1595             }
1596              
1597 0           my string $ccflags = [ config_re('ccflags') ]->[0];
1598 0           substr $ccflags, 0, 9, q{}; # remove leading ccflags='
1599 0           substr $ccflags, -1, 1, q{}; # remove trailing '
1600 0           $subcompile_command .= q{ } . $ccflags;
1601              
1602 0           $subcompile_command .= q{ } . '-xc++'; # force C++ language mode
1603              
1604             # using RPerl::BASE_PATH instead of substr $RPerl::INCLUDE_PATH
1605             # if ( ( ( substr $RPerl::INCLUDE_PATH, -4, 4 ) eq '/lib' ) or ( ( substr $RPerl::INCLUDE_PATH, -4, 4 ) eq '\lib' ) ) {
1606             # $subcompile_command .= q{ } . '-I"' . ( substr $RPerl::INCLUDE_PATH, 0, -4 ) . '"'; # remove trailing /lib or \lib
1607             # }
1608              
1609 0           $subcompile_command .= q{ } . '-I"' . $RPerl::BASE_PATH . '"';
1610 0           $subcompile_command .= q{ } . '-I"' . $RPerl::INCLUDE_PATH . '"'; # different than original Inline::CPP subcompile command, double-quotes added to encapsulate user-name directories
1611 0           $subcompile_command .= q{ } . '-Ilib';
1612 0           $subcompile_command .= q{ } . '-I"' . $RPerl::Inline::pcre2_include_dir . '"'; # for regex support
1613 0           $subcompile_command .= q{ } . '-I"' . $RPerl::Inline::jpcre2_include_dir . '"'; # for regex support
1614              
1615 0           $subcompile_command .= q{ } . $RPerl::Inline::CCFLAGSEX;
1616 0           $subcompile_command .= q{ } . '-D__' . $modes->{types} . '__TYPES'; # same as #define __PERL__TYPES or #define__CPP__TYPES; don't just use hard-coded $RPerl::TYPES_CCFLAG
1617 0           $subcompile_command .= q{ } . '-D__TYPE__INTEGER__' . $modes->{type_integer};
1618 0           $subcompile_command .= q{ } . '-D__TYPE__NUMBER__' . $modes->{type_number};
1619 0           $subcompile_command .= q{ } . $RPerl::Inline::ARGS{optimize};
1620              
1621 0           $subcompile_command .= q{ } . '-DVERSION=\"0.00\" -DXS_VERSION=\"0.00\"'; # NEED ANSWER: what does this do?
1622              
1623 0           my string $cccdlflags = [ config_re('cccdlflags') ]->[0];
1624 0           substr $cccdlflags, 0, 12, q{}; # remove leading cccdlflags='
1625 0           substr $cccdlflags, -1, 1, q{}; # remove trailing '
1626 0           $subcompile_command .= q{ } . $cccdlflags;
1627              
1628 0 0         if ( $RPerl::CORE_PATH eq q{} ) {
1629 0           croak 'ERROR ECOCOSU02, COMPILER, SUBCOMPILE: Perl source code CORE directory or CORE/perl.h file not found in @INC path listing, croaking';
1630             }
1631 0           $subcompile_command .= q{ } . '"-I' . $RPerl::CORE_PATH . '"';
1632              
1633              
1634              
1635              
1636 0 0         if ($modes->{parallel} eq 'OFF') {
    0          
1637 0           $subcompile_command .= q{ } . $cpp_output_file_name_group->{CPP};
1638 0           $subcompile_command .= q{ } . '-o ';
1639            
1640 0 0 0       if ( ( $modes->{subcompile} eq 'ASSEMBLE' )
    0 0        
    0          
1641             or ( $modes->{subcompile} eq 'ARCHIVE' ) )
1642             {
1643 0           $subcompile_command .= q{ } . $cpp_output_file_name_group->{O};
1644             }
1645             elsif ( $modes->{subcompile} eq 'SHARED' ) {
1646 0           $subcompile_command .= q{ } . $cpp_output_file_name_group->{SO};
1647             }
1648             elsif (( $modes->{subcompile} eq 'STATIC' )
1649             or ( $modes->{subcompile} eq 'DYNAMIC' ) )
1650             {
1651 0           $subcompile_command .= q{ } . $cpp_output_file_name_group->{EXE};
1652             }
1653             }
1654             elsif ($modes->{parallel} eq 'OPENMP') {
1655 0           $subcompile_command .= q{ } . '-mtune=native -ftree-vectorize -DTIME -fopenmp';
1656 0           $subcompile_command .= q{ } . $cpp_output_file_name_group->{OPENMP_CPP};
1657 0           $subcompile_command .= q{ } . '-o ';
1658            
1659             # NEED FIX PARALLEL: handle other subcompile modes???
1660 0 0 0       if (( $modes->{subcompile} eq 'STATIC' )
1661             or ( $modes->{subcompile} eq 'DYNAMIC' ) )
1662             {
1663 0           $subcompile_command .= q{ } . $cpp_output_file_name_group->{OPENMP_EXE};
1664             }
1665             }
1666            
1667 0 0         if ( $modes->{subcompile} eq 'SHARED' ) {
    0          
1668 0           $subcompile_command .= q{ } . '-shared';
1669             }
1670             elsif ( $modes->{subcompile} eq 'STATIC' ) {
1671 0           $subcompile_command .= q{ } . '-static';
1672             }
1673              
1674 0 0 0       if ( ( $modes->{subcompile} eq 'STATIC' )
1675             or ( $modes->{subcompile} eq 'DYNAMIC' ) )
1676             {
1677 0 0         if ($modes->{parallel} eq 'OPENMP') {
1678 0           $subcompile_command .= q{ } . '-lm'; # not in original Inline::CPP subcompile command
1679             }
1680 0           $subcompile_command .= q{ } . '-lperl'; # not in original Inline::CPP subcompile command
1681             # DEV NOTE, CORRELATION #rp300: must link against all bit width libs to allow automatic selection
1682 0           $subcompile_command .= q{ } . '-lpcre2-8 -lpcre2-16 -lpcre2-32'; # for regex support, not in original Inline::CPP subcompile command
1683             }
1684              
1685 0 0         if ( $modes->{subcompile} eq 'STATIC' ) {
1686 0           $subcompile_command .= q{ } . '-lcrypt'; # not in original Inline::CPP subcompile command
1687             }
1688              
1689 0 0         if ( $modes->{subcompile} eq 'ARCHIVE' ) {
1690 0           $subcompile_command .= q{ } . ' ; ar -cvq ' . $cpp_output_file_name_group->{A} . q{ } . $cpp_output_file_name_group->{O};
1691              
1692             # NEED ANSWER: is this always the correct output redirect mechanism M$ Windows? I think it is correct for cmd.exe, but what about Cygwin, etc?
1693 0 0         if ( $OSNAME eq 'MSWin32' ) { $subcompile_command .= q{ } . ' > nul'; }
  0            
1694 0           else { $subcompile_command .= q{ } . ' > /dev/null'; }
1695             }
1696             # my $pid = open3( 0, \*SUBCOMPILE_STDOUT, \*SUBCOMPILE_STDERR, $subcompile_command ); # disable STDIN w/ 0
1697             #
1698             # my $stdout_select;
1699             # my $stderr_select;
1700             # if ( $OSNAME ne 'MSWin32' ) {
1701             # $stdout_select = IO::Select->new();
1702             # $stderr_select = IO::Select->new();
1703             # $stdout_select->add( \*SUBCOMPILE_STDOUT );
1704             # $stderr_select->add( \*SUBCOMPILE_STDERR );
1705             # }
1706             #
1707              
1708             # RPerl::diag( "\n" . 'in Compiler::cpp_to_xsbinary__subcompile(), have $subcompile_command =' . "\n\n" . $subcompile_command . "\n\n" );
1709 0           RPerl::diag( "\n\n" . $subcompile_command . "\n\n" );
1710 0 0 0       if ( $ENV{RPERL_VERBOSE} or $RPerl::VERBOSE ) { RPerl::diag( q{SUBCOMPILE: Generate binary... } ); }
  0            
1711              
1712             # if ( $OSNAME eq 'MSWin32' || $stdout_select->can_read(0) ) { sysread SUBCOMPILE_STDOUT, $subcompile_command_stdout, 4096; }
1713             # if ( $OSNAME eq 'MSWin32' || $stderr_select->can_read(0) ) { sysread SUBCOMPILE_STDERR, $subcompile_command_stderr, 4096; }
1714             # waitpid $pid, 0;
1715             # if ( $OSNAME eq 'MSWin32' || $stdout_select->can_read(0) ) { my $s; sysread SUBCOMPILE_STDOUT, $s, 4096; $subcompile_command_stdout .= $s; }
1716             # if ( $OSNAME eq 'MSWin32' || $stderr_select->can_read(0) ) { my $s; sysread SUBCOMPILE_STDERR, $s, 4096; $subcompile_command_stderr .= $s; }
1717              
1718             # ACTUALLY RUN SUBCOMPILE COMMAND
1719 0           my string $subcompile_command_stdout = q{};
1720 0           my string $subcompile_command_stderr = q{};
1721              
1722             #my $pid = open3( 0, \*SUBCOMPILE_STDOUT, \*SUBCOMPILE_STDERR, $subcompile_command ); # disable STDIN w/ 0
1723 0           run3( $subcompile_command, \undef, \$subcompile_command_stdout, \$subcompile_command_stderr );
1724              
1725 0           my $test_exit_status = $CHILD_ERROR >> 8;
1726              
1727             # RPerl::diag( 'in Compiler::cpp_to_xsbinary__subcompile(), have $CHILD_ERROR = ' . $CHILD_ERROR . "\n" );
1728             # RPerl::diag( 'in Compiler::cpp_to_xsbinary__subcompile(), have $test_exit_status = ' . $test_exit_status . "\n" );
1729              
1730 0           RPerl::verbose( ' done.' . "\n" );
1731              
1732             # delete temporary .o file
1733 0 0         if ( $modes->{subcompile} eq 'ARCHIVE' ) {
1734 0 0         if ( -f $cpp_output_file_name_group->{O} ) {
1735             unlink( $cpp_output_file_name_group->{O} )
1736             or croak( "\n"
1737             . 'ERROR ECOCOSU03, COMPILER, SUBCOMPILE: Cannot delete temporary object file ' . q{'}
1738 0 0         . $cpp_output_file_name_group->{O} . q{'} . ',' . "\n"
1739             . 'croaking:'
1740             . $OS_ERROR );
1741             }
1742             }
1743              
1744             # if ($subcompile_command_stdout) { RPerl::diag( "===STDOUT=BEGIN===\n" . $subcompile_command_stdout . "===STDOUT=END===\n" ); }
1745             # if ($subcompile_command_stderr) { RPerl::diag( "===STDERR=BEGIN===\n" . $subcompile_command_stderr . "===STDERR=END===\n" ); }
1746 0   0       my boolean $subcompile_command_stdout_content = ( ( defined $subcompile_command_stdout ) and ( $subcompile_command_stdout =~ m/[^\s]+/g ) );
1747 0   0       my boolean $subcompile_command_stderr_content = ( ( defined $subcompile_command_stderr ) and ( $subcompile_command_stderr =~ m/[^\s]+/g ) );
1748              
1749 0 0 0       if ( $subcompile_command_stdout_content or $subcompile_command_stderr_content ) {
1750 0           RPerl::diag("\n");
1751 0 0         if ($subcompile_command_stdout_content) {
1752 0           RPerl::diag( '[[[ SUBCOMPILE STDOUT ]]]' . "\n\n" . $subcompile_command_stdout . "\n" );
1753             }
1754 0 0         if ($subcompile_command_stderr_content) {
1755 0           RPerl::diag( '[[[ SUBCOMPILE STDERR ]]]' . "\n\n" . $subcompile_command_stderr . "\n" );
1756             }
1757 0 0         if ( $test_exit_status == 0 ) { # UNIX process return code 0, success
1758 0           RPerl::warning(
1759             'WARNING WCOCOSU00, COMPILER, SUBCOMPILE: C++ compiler returned success code but produced output which may indicate an error,' . "\n"
1760             . 'please run again with `rperl -D` command or RPERL_DEBUG=1 environmental variable for error messages or other output if none appear above'
1761             . "\n" );
1762             }
1763             }
1764              
1765 0 0         if ($test_exit_status) { # UNIX process return code not 0, error
1766 0 0 0       if ( not( $subcompile_command_stdout_content or $subcompile_command_stderr_content ) ) {
1767 0           RPerl::diag( "\n" . '[[[ SUBCOMPILE STDOUT & STDERR ARE BOTH EMPTY ]]]' . "\n\n" );
1768             }
1769 0           croak 'ERROR ECOCOSU04, COMPILER, SUBCOMPILE: C++ compiler returned error code,' . "\n"
1770             . 'please run again with `rperl -D` command or RPERL_DEBUG=1 environmental variable for error messages if none appear above,' . "\n"
1771             . 'croaking';
1772             }
1773             }
1774             else { # *.pm module files
1775 0           RPerl::verbose('SUBCOMPILE: Generate XS & binary...');
1776              
1777             ( my string $volume_pmc, my string $directories_pmc, my string $file_pmc )
1778 0           = File::Spec->splitpath( $cpp_output_file_name_group->{PMC}, my $no_file = 0 );
1779              
1780             #RPerl::diag( q{in Compiler::cpp_to_xsbinary__subcompile(), have $directories_pmc = } . $directories_pmc . "\n" );
1781              
1782             # strip trailing / or \ as long as they are not the only characters, which could indicate the root directory
1783 0 0 0       if ( ( ( length $directories_pmc ) > 1 )
      0        
1784             and ( ( ( substr $directories_pmc, -1, 1 ) eq q{/} ) or ( ( substr $directories_pmc, -1, 1 ) eq q{\\} ) ) )
1785             {
1786 0           substr $directories_pmc, -1, 1, q{};
1787             }
1788              
1789 0           my @INC_sorted = sort { length $b <=> length $a } @INC;
  0            
1790              
1791             #RPerl::diag( q{in Compiler::cpp_to_xsbinary__subcompile(), have @INC =} . "\n" . Dumper(\@INC) . "\n" );
1792             #RPerl::diag( q{in Compiler::cpp_to_xsbinary__subcompile(), have @INC_sorted =} . "\n" . Dumper(\@INC_sorted) . "\n" );
1793              
1794             # strip leading INC directory if present
1795 0           foreach my string $INC_directory (@INC_sorted) {
1796              
1797             #RPerl::diag( q{in Compiler::cpp_to_xsbinary__subcompile(), have $INC_directory = } . $INC_directory . "\n" );
1798 0 0         if ( $directories_pmc =~ /^$INC_directory/ ) {
1799 0           substr $directories_pmc, 0, ( length $INC_directory ), q{};
1800 0           last;
1801             }
1802             }
1803              
1804             #RPerl::diag( q{in Compiler::cpp_to_xsbinary__subcompile(), have POSSIBLY-MODIFIED $directories_pmc = } . $directories_pmc . "\n" );
1805              
1806 0           my string_arrayref $directories_pmc_split = [ File::Spec->splitdir($directories_pmc) ];
1807              
1808             #RPerl::diag( q{in Compiler::cpp_to_xsbinary__subcompile(), have $directories_pmc_split =} . "\n" . Dumper($directories_pmc_split) . "\n" );
1809              
1810             # discard '.' or empty directory names
1811 0           my $directories_pmc_split_tmp = [];
1812 0           foreach my $directory ( @{$directories_pmc_split} ) {
  0            
1813 0 0 0       if ( ( $directory ne q{.} ) and ( $directory ne q{} ) ) {
1814 0           push @{$directories_pmc_split_tmp}, $directory;
  0            
1815             }
1816             }
1817 0           $directories_pmc_split = $directories_pmc_split_tmp;
1818              
1819             # strip trailing .pmc file suffix
1820 0           substr $file_pmc, -4, 4, q{};
1821              
1822 0           my string $eval_string = join '::', @{$directories_pmc_split}, $file_pmc;
  0            
1823 0           $eval_string = 'use ' . $eval_string . ';';
1824              
1825             #RPerl::diag( q{in Compiler::cpp_to_xsbinary__subcompile(), have $eval_string =} . "\n" . $eval_string . "\n" );
1826              
1827             # NEED FIX: why does Inline::CPP require double-subcompiling???
1828             # DEV NOTE: exec() and system() don't work, only backticks
1829              
1830             # `export RPERL_WARNINGS=0; perl -e '$eval_string'`; # should build
1831             #RPerl::diag( q{in Compiler::cpp_to_xsbinary__subcompile(), done with backticks 1...} . "\n" );
1832              
1833             # `export RPERL_WARNINGS=0; perl -e '$eval_string'`; # should not build, but does
1834             #RPerl::diag( q{in Compiler::cpp_to_xsbinary__subcompile(), done with backticks 2...} . "\n" );
1835              
1836             # `export RPERL_WARNINGS=0; perl -e '$eval_string'`; # should not build, does not seem to
1837             #RPerl::diag( q{in Compiler::cpp_to_xsbinary__subcompile(), done with backticks 3...} . "\n" );
1838              
1839 0           RPerl::verbose( ' deferred.' . "\n" );
1840             }
1841 0           return;
1842             }
1843              
1844             1; # end of class