File Coverage

blib/lib/RPerl/CompileUnit/Module/Class/Generator.pm
Criterion Covered Total %
statement 440 605 72.7
branch 128 254 50.3
condition 42 132 31.8
subroutine 12 13 92.3
pod n/a
total 622 1004 61.9


line stmt bran cond sub pod time code
1             # [[[ HEADER ]]]
2             package RPerl::CompileUnit::Module::Class::Generator;
3 3     3   19 use strict;
  3         7  
  3         91  
4 3     3   15 use warnings;
  3         6  
  3         87  
5 3     3   14 use RPerl::AfterSubclass;
  3         6  
  3         440  
6             our $VERSION = 0.012_000;
7              
8             # [[[ OO INHERITANCE ]]]
9 3     3   21 use parent qw(RPerl::CompileUnit::Module::Class);
  3         6  
  3         26  
10 3     3   202 use RPerl::CompileUnit::Module::Class;
  3         6  
  3         55  
11              
12             # [[[ CRITICS ]]]
13             ## no critic qw(ProhibitUselessNoCritic ProhibitMagicNumbers RequireCheckedSyscalls) # USER DEFAULT 1: allow numeric values & print operator
14             ## no critic qw(RequireInterpolationOfMetachars) # USER DEFAULT 2: allow single-quoted control characters & sigils
15              
16             # [[[ INCLUDES ]]]
17 3     3   13 use RPerl::Parser;
  3         7  
  3         57  
18 3     3   15 use RPerl::Generator;
  3         6  
  3         58  
19 3     3   15 use Storable qw(dclone);
  3         6  
  3         139  
20 3     3   15 use perlapinames_generated;
  3         7  
  3         17990  
21              
22             # [[[ OO PROPERTIES ]]]
23             our hashref $properties = {};
24              
25             # [[[ SUBROUTINES & OO METHODS ]]]
26              
27             sub ast_to_rperl__generate {
28 76     76   208 { my string_hashref::method $RETURN_TYPE };
  76         200  
29 76         327 ( my object $self, my string $package_name_underscores, my string_hashref $modes ) = @ARG;
30 76         247 my string_hashref $rperl_source_group = {};
31              
32             # RPerl::diag( 'in Class::Generator->ast_to_rperl__generate(), received $self = ' . "\n" . RPerl::Parser::rperl_ast__dump($self) . "\n" );
33              
34 76         259 my string $self_class = ref $self;
35              
36             # unwrap Class_72 from Module_25
37 76 50       422 if ( ($self_class) eq 'Module_25' ) {
38 76         293 $self = $self->{children}->[0];
39 76         500 $self_class = ref $self;
40             }
41              
42             # RPerl::diag( 'in Class::Generator->ast_to_rperl__generate(), have possibly-unwrapped $self = ' . "\n" . RPerl::Parser::rperl_ast__dump($self) . "\n" );
43             # die 'TMP DEBUG';
44              
45 76 50       375 if ( ($self_class) ne 'Class_72' ) {
46 0         0 die RPerl::Parser::rperl_rule__replace( 'ERROR ECOGEASRP00, CODE GENERATOR, ABSTRACT SYNTAX TO RPERL: Grammar rule '
47             . ($self_class)
48             . ' found where Module_25 or Class_72 expected, dying' )
49             . "\n";
50             }
51              
52             # Class: 'use parent qw(' WordScoped ')' ';' Include Critic* Include* Constant* Properties MethodOrSubroutine* LITERAL_NUMBER ';' ;
53             # Class: 'use parent qw(' WordScoped ')' ';' Include Critic* Exports? Include* Constant* Properties SubroutineOrMethod* LITERAL_NUMBER ';' ;
54 76         256 my string $use_parent_qw_keyword = $self->{children}->[0];
55 76         303 my string $parent_name = $self->{children}->[1]->{children}->[0];
56 76         225 my string $right_parenthesis = $self->{children}->[2];
57 76         246 my string $use_parent_semicolon = $self->{children}->[3];
58 76         273 my object $parent_include = $self->{children}->[4];
59 76         257 my object $critic_star = $self->{children}->[5];
60 76         259 my object $exports_optional = $self->{children}->[6];
61 76         209 my object $include_star = $self->{children}->[7];
62 76         203 my object $constant_star = $self->{children}->[8];
63 76         297 my object $properties = $self->{children}->[9];
64 76         215 my object $method_or_subroutine_star = $self->{children}->[10];
65 76         264 my string $retval_literal_number = $self->{children}->[11];
66 76         244 my string $retval_semicolon = $self->{children}->[12];
67              
68             # RPerl::diag( 'in Class::Generator->ast_to_rperl__generate(), have $exports_optional = ' . "\n" . RPerl::Parser::rperl_ast__dump($exports_optional) . "\n" );
69             # RPerl::diag( 'in Class::Generator->ast_to_rperl__generate(), have $exports_optional->{children}->[0] = ' . "\n" . RPerl::Parser::rperl_ast__dump($exports_optional->{children}->[0]) . "\n" );
70              
71 76         281 $rperl_source_group->{PMC} = q{};
72 76 50       328 if ( $modes->{label} eq 'ON' ) {
73 0         0 $rperl_source_group->{PMC} .= '# [[[ OO INHERITANCE ]]]' . "\n";
74             }
75 76         445 $rperl_source_group->{PMC} .= $use_parent_qw_keyword . $parent_name . $right_parenthesis . $use_parent_semicolon . "\n";
76              
77 76         2119 my string_hashref $rperl_source_subgroup = $parent_include->ast_to_rperl__generate($modes);
78 76         1656 RPerl::Generator::source_group_append( $rperl_source_group, $rperl_source_subgroup );
79              
80 76 100       437 if ( exists $critic_star->{children}->[0] ) {
81 64 50       316 if ( $modes->{label} eq 'ON' ) {
82 0         0 $rperl_source_group->{PMC} .= '# [[[ CRITICS ]]]' . "\n";
83             }
84             }
85 76         241 foreach my object $critic ( @{ $critic_star->{children} } ) {
  76         394  
86 116         2671 $rperl_source_subgroup = $critic->ast_to_rperl__generate($modes);
87 116         2253 RPerl::Generator::source_group_append( $rperl_source_group, $rperl_source_subgroup );
88             }
89              
90 76 100       355 if ( exists $exports_optional->{children}->[0] ) {
91             # RPerl::diag( 'in Class::Generator->ast_to_rperl__generate(), have YES EXPORTS ' . "\n" );
92 14 50       87 if ( $modes->{label} eq 'ON' ) {
93 0         0 $rperl_source_group->{PMC} .= "\n" . '# [[[ EXPORTS ]]]' . "\n";
94             }
95 14         37 my object $exports = $exports_optional->{children}->[0];
96 14         78 my string $use_exporter = $exports->{children}->[0];
97 14         43 my string $export = $exports->{children}->[1];
98 14         39 my string $export_ok = $exports->{children}->[2];
99              
100 14         54 $rperl_source_group->{PMC} .= $use_exporter; # already has a newline
101 14 100       60 if ( exists $export->{children}->[0] ) {
102 10         66 $rperl_source_group->{PMC} .= $export->{children}->[0]->{attr} . $export->{children}->[1]->{attr} . ';' . "\n"; # DEV NOTE: does not capture semicolon in AST for some reason, must hard-code here
103             }
104 14 100       74 if ( exists $export_ok->{children}->[0] ) {
105 6         33 $rperl_source_group->{PMC} .= $export_ok->{children}->[0]->{attr} . $export_ok->{children}->[1]->{attr} . ';' . "\n"; # DEV NOTE: does not capture semicolon in AST for some reason, must hard-code here
106             }
107             # RPerl::diag( 'in Class::Generator->ast_to_rperl__generate(), AFTER EXPORTS, have $rperl_source_group->{PMC} = ' . "\n" . RPerl::Parser::rperl_ast__dump($rperl_source_group->{PMC}) . "\n" );
108             }
109            
110 76 100       409 if ( exists $include_star->{children}->[0] ) {
111 10 50       59 if ( $modes->{label} eq 'ON' ) {
112 0         0 $rperl_source_group->{PMC} .= "\n" . '# [[[ INCLUDES ]]]' . "\n";
113             }
114             }
115 76         174 foreach my object $include ( @{ $include_star->{children} } ) { ## no critic qw(ProhibitPostfixControls) # SYSTEM SPECIAL 6: PERL CRITIC FILED ISSUE #639, not postfix foreach or if
  76         321  
116 12         323 $rperl_source_subgroup = $include->ast_to_rperl__generate($modes);
117 12         258 RPerl::Generator::source_group_append( $rperl_source_group, $rperl_source_subgroup );
118             }
119              
120 76 100       370 if ( exists $constant_star->{children}->[0] ) {
121 3 50       18 if ( $modes->{label} eq 'ON' ) {
122 0         0 $rperl_source_group->{PMC} .= "\n" . '# [[[ CONSTANTS ]]]' . "\n";
123             }
124             }
125 76         188 foreach my object $constant ( @{ $constant_star->{children} } ) { ## no critic qw(ProhibitPostfixControls) # SYSTEM SPECIAL 6: PERL CRITIC FILED ISSUE #639, not postfix foreach or if
  76         313  
126 5         111 $rperl_source_subgroup = $constant->ast_to_rperl__generate($modes);
127 4         76 RPerl::Generator::source_group_append( $rperl_source_group, $rperl_source_subgroup );
128             }
129              
130 75 50       417 if ( $modes->{label} eq 'ON' ) {
131 0         0 $rperl_source_group->{PMC} .= "\n" . '# [[[ OO PROPERTIES ]]]' . "\n";
132             }
133              
134             # prepare for later use in:
135             # disallow name masking of inherited $properties, AND
136             # generate accessors & mutators for inherited $properties
137 75         291 my string $package_name_colons = $package_name_underscores;
138 75         497 $package_name_colons =~ s/__/::/gxms;
139 75         631 my $parent_package_names = RPerl::CompileUnit::Module::Class::parent_and_grandparent_package_names($package_name_colons);
140             # RPerl::diag( 'in Class::Generator->ast_to_rperl__generate(), have $parent_package_names = ' . Dumper($parent_package_names) . "\n" );
141              
142 75 100       517 if ( ref $properties eq 'Properties_76' ) { ## no critic qw(ProhibitPostfixControls) # SYSTEM SPECIAL 6: PERL CRITIC FILED ISSUE #639, not postfix foreach or if
143             # non-empty $properties
144 26         132 my string $properties_our_hashref = $properties->{children}->[0];
145 26         115 my string $properties_equal = $properties->{children}->[1];
146 26         122 my string $properties_left_brace = $properties->{children}->[2];
147 26         68 my object $property_0 = $properties->{children}->[3];
148 26         91 my object $properties_1_to_n = $properties->{children}->[4];
149 26         99 my string $properties_right_brace = $properties->{children}->[5];
150 26         78 my string $properties_semicolon = $properties->{children}->[6];
151              
152 26         149 $rperl_source_group->{PMC} .= $properties_our_hashref . q{ } . $properties_equal . q{ } . $properties_left_brace . "\n";
153              
154 26         456 my string $property_key;
155             my string $property_fat_arrow;
156 26         0 my object $property_type_inner;
157 26         0 my string $property_my;
158 26         0 my string $property_type;
159 26         0 my string $property_TYPED;
160 26         0 my string $property_name;
161 26         0 my string $property_arrayref_thinarrow;
162 26         0 my object $property_arrayref_index_max;
163 26         0 my string $property_arrayref_rightbracket;
164 26         0 my string $property_assign;
165 26         0 my object $property_subexpression;
166 26         0 my string $property_subexpression_string;
167              
168 26         108 $property_key = $property_0->{children}->[0]->{children}->[0];
169 26         228 $property_key =~ s/^(\w+)\s*$/$1/gxms; # strip trailing whitespace, caused by grammar matching operator names with trailing spaces
170 26 50       158 if ( $property_key !~ /^[a-z]/ ) {
171 0         0 die 'ERROR ECOGEASRP24, CODE GENERATOR, ABSTRACT SYNTAX TO RPERL: invalid OO properties name (hash key) ' . q{'}
172             . $property_key . q{'}
173             . ' does not start with a lowercase letter a-z, dying' . "\n";
174             }
175 26         79 $property_fat_arrow = $property_0->{children}->[1];
176 26         77 $property_type_inner = $property_0->{children}->[2];
177 26         102 $property_name = $property_type_inner->{children}->[3]->{children}->[0];
178 26         153 $property_name =~ s/^(\w+)\s*$/$1/gxms; # strip trailing whitespace, caused by grammar matching operator names with trailing spaces
179              
180             # DEV NOTE: we can do error checking once here instead of twice for TypeInnerProperties_238 & TypeInnerProperties_239 below
181             # because they both have OpStringOrWord as sub-element 3, grabbed as $property_name above
182 26 50       111 if ( $property_name ne $property_key ) {
183 0         0 die 'ERROR ECOGEASRP21, CODE GENERATOR, ABSTRACT SYNTAX TO RPERL: redundant name mismatch, inner type name ' . q{'}
184             . $property_name . q{'}
185             . ' does not equal OO properties key ' . q{'}
186             . $property_key . q{'}
187             . ', dying' . "\n";
188             }
189              
190             # RPerl::diag( 'in Class::Generator->ast_to_rperl__generate(), have $property_name = ' . $property_name . "\n" );
191             # RPerl::diag( 'in Class::Generator->ast_to_rperl__generate(), have $perlapinames_generated::FUNCTIONS_DOCUMENTED = ' . Dumper($perlapinames_generated::FUNCTIONS_DOCUMENTED) . "\n" );
192              
193 26 100 100     512 if ((exists $perlapinames_generated::FUNCTIONS_DOCUMENTED->{$property_name}) or
      100        
      100        
194             (exists $perlapinames_generated::FUNCTIONS_UNDOCUMENTED->{$property_name}) or
195             (exists $perlapinames_generated::VARIABLES_DOCUMENTED->{$property_name}) or
196             (exists $perlapinames_generated::VARIABLES_UNDOCUMENTED->{$property_name})) {
197 4         81 die 'ERROR ECOGEASRP41, CODE GENERATOR, ABSTRACT SYNTAX TO RPERL: Perl API name conflict, OO property name ' . q{'}
198             . $property_name . q{'}
199             . ' is the same as a protected function or variable name in the Perl API, please choose a different name, dying' . "\n";
200             }
201              
202             # TypeInnerProperties -> MY Type '$TYPED_' OpStringOrWord OP19_VARIABLE_ASSIGN SubExpression
203 22 50       115 if ( ref $property_type_inner eq 'TypeInnerProperties_238' ) {
    0          
204 22         76 $property_my = $property_type_inner->{children}->[0];
205 22         86 $property_type = $property_type_inner->{children}->[1]->{children}->[0];
206 22         56 $property_TYPED = $property_type_inner->{children}->[2];
207 22         63 $property_assign = $property_type_inner->{children}->[4];
208 22         67 $property_subexpression = $property_type_inner->{children}->[5];
209              
210             $rperl_source_group->{PMC}
211 22         135 .= $property_key . q{ }
212             . $property_fat_arrow . q{ }
213             . $property_my . q{ }
214             . $property_type . q{ }
215             . $property_TYPED
216             . $property_name . q{ }
217             . $property_assign . q{ };
218              
219 22         709 $rperl_source_subgroup = $property_subexpression->ast_to_rperl__generate($modes);
220 22         501 RPerl::Generator::source_group_append( $rperl_source_group, $rperl_source_subgroup );
221             }
222              
223             # TypeInnerProperties -> MY Type '$TYPED_' OpStringOrWord OP02_ARRAY_THINARROW SubExpression ']' OP19_VARIABLE_ASSIGN 'undef'
224             elsif ( ref $property_type_inner eq 'TypeInnerProperties_239' ) {
225 0         0 $property_my = $property_type_inner->{children}->[0];
226 0         0 $property_type = $property_type_inner->{children}->[1]->{children}->[0];
227 0         0 $property_TYPED = $property_type_inner->{children}->[2];
228 0         0 $property_arrayref_thinarrow = $property_type_inner->{children}->[4];
229 0         0 $property_arrayref_index_max = $property_type_inner->{children}->[5];
230 0         0 $property_arrayref_rightbracket = $property_type_inner->{children}->[6];
231 0         0 $property_assign = $property_type_inner->{children}->[7];
232 0         0 $property_subexpression_string = $property_type_inner->{children}->[8];
233              
234             $rperl_source_group->{PMC}
235 0         0 .= $property_key . q{ }
236             . $property_fat_arrow . q{ }
237             . $property_my . q{ }
238             . $property_type . q{ }
239             . $property_TYPED
240             . $property_name
241             . $property_arrayref_thinarrow;
242              
243 0         0 $rperl_source_subgroup = $property_arrayref_index_max->ast_to_rperl__generate($modes);
244 0         0 RPerl::Generator::source_group_append( $rperl_source_group, $rperl_source_subgroup );
245              
246 0         0 $rperl_source_group->{PMC} .= $property_arrayref_rightbracket . q{ } . $property_assign . q{ } . $property_subexpression_string;
247             }
248             else {
249 0         0 die RPerl::Parser::rperl_rule__replace( 'ERROR ECOGEASCP00, CODE GENERATOR, ABSTRACT SYNTAX TO C++: Grammar rule '
250             . ( ref $self )
251             . ' found where TypeInnerProperties_238 or TypeInnerProperties_239 expected, dying' )
252             . "\n";
253             }
254              
255             # CREATE SYMBOL TABLE ENTRY
256 22 50       185 if ( exists $modes->{_symbol_table}->{ $modes->{_symbol_table}->{_namespace} }->{_properties}->{$property_key} ) {
257             die 'ERROR ECOGEASRP10, CODE GENERATOR, ABSTRACT SYNTAX TO RPERL: OO property '
258             . q{'} . $property_key . q{'}
259             . ' already declared in this scope, namespace '
260 0         0 . q{'} . $modes->{_symbol_table}->{_namespace} . q{'}
261             . ', dying' . "\n";
262             }
263              
264             # RPerl::diag( 'in Class::Generator->ast_to_rperl__generate(), property 0, have $parent_package_names = ' . "\n" . Dumper($parent_package_names) . "\n" ) if (scalar @{$parent_package_names});
265              
266             # disallow name masking of inherited $properties, causes mismatching behavior in PERLOPS_PERLTYPES vs CPPOPS_CPPTYPES
267 22         55 foreach my $parent_package_name (@{$parent_package_names}) {
  22         109  
268 22 100       149 if ( exists $modes->{_symbol_table}->{ $parent_package_name . q{::} }->{_properties}->{$property_key} ) {
269 2         51 die 'ERROR ECOGEASRP11, CODE GENERATOR, ABSTRACT SYNTAX TO RPERL: OO property '
270             . q{'} . $property_key . q{'}
271             . ' already declared in parent namespace '
272             . q{'} . $parent_package_name . q{::} . q{'}
273             . ', name masking disallowed, dying' . "\n";
274             }
275             }
276              
277 20         128 $modes->{_symbol_table}->{ $modes->{_symbol_table}->{_namespace} }->{_properties}->{$property_key}
278             = { isa => 'RPerl::DataStructure::Hash::Properties', type => $property_type };
279              
280 20         51 my integer $i = 0;
281 20         43 foreach my object $property ( @{ $properties_1_to_n->{children} } ) {
  20         98  
282 8 100       30 if ( ( ref $property ) eq 'TERMINAL' ) {
283 4         16 $rperl_source_group->{PMC} .= $property->{attr}; # comma between properties
284             }
285             else {
286 4         9 $i++;
287 4         16 $property_key = $property->{children}->[0]->{children}->[0];
288 4         27 $property_key =~ s/^(\w+)\s*$/$1/gxms; # strip trailing whitespace, caused by grammar matching operator names with trailing spaces
289 4 50       18 if ( $property_key !~ /^[a-z]/ ) {
290 0         0 die 'ERROR ECOGEASRP24, CODE GENERATOR, ABSTRACT SYNTAX TO RPERL: invalid OO properties name (hash key) ' . q{'}
291             . $property_key . q{'}
292             . ' does not start with a lowercase letter a-z, dying' . "\n";
293             }
294 4         15 $property_fat_arrow = $property->{children}->[1];
295 4         12 $property_type_inner = $property->{children}->[2];
296 4         17 $property_name = $property_type_inner->{children}->[3]->{children}->[0];
297 4         18 $property_name =~ s/^(\w+)\s*$/$1/gxms; # strip trailing whitespace, caused by grammar matching operator names with trailing spaces
298              
299 4 50       14 if ( $property_name ne $property_key ) {
300 0         0 die 'ERROR ECOGEASRP21, CODE GENERATOR, ABSTRACT SYNTAX TO RPERL: redundant name mismatch, inner type name ' . q{'}
301             . $property_name . q{'}
302             . ' does not equal OO properties key ' . q{'}
303             . $property_key . q{'}
304             . ', dying' . "\n";
305             }
306 4 50 33     42 if ((exists $perlapinames_generated::FUNCTIONS_DOCUMENTED->{$property_name}) or
      33        
      33        
307             (exists $perlapinames_generated::FUNCTIONS_UNDOCUMENTED->{$property_name}) or
308             (exists $perlapinames_generated::VARIABLES_DOCUMENTED->{$property_name}) or
309             (exists $perlapinames_generated::VARIABLES_UNDOCUMENTED->{$property_name})) {
310 0         0 die 'ERROR ECOGEASRP41, CODE GENERATOR, ABSTRACT SYNTAX TO RPERL: Perl API name conflict, OO property name ' . q{'}
311             . $property_name . q{'}
312             . ' is the same as a protected function or variable name in the Perl API, please choose a different name, dying' . "\n";
313             }
314              
315             # TypeInnerProperties -> MY Type '$TYPED_' WORD OP19_VARIABLE_ASSIGN SubExpression
316 4 50       15 if ( ref $property_type_inner eq 'TypeInnerProperties_238' ) {
    0          
317 4         9 $property_my = $property_type_inner->{children}->[0];
318 4         15 $property_type = $property_type_inner->{children}->[1]->{children}->[0];
319 4         8 $property_TYPED = $property_type_inner->{children}->[2];
320 4         11 $property_assign = $property_type_inner->{children}->[4];
321 4         8 $property_subexpression = $property_type_inner->{children}->[5];
322              
323             $rperl_source_group->{PMC}
324 4         21 .= $property_key . q{ }
325             . $property_fat_arrow . q{ }
326             . $property_my . q{ }
327             . $property_type . q{ }
328             . $property_TYPED
329             . $property_name . q{ }
330             . $property_assign . q{ };
331              
332 4         98 $rperl_source_subgroup = $property_subexpression->ast_to_rperl__generate($modes);
333 4         78 RPerl::Generator::source_group_append( $rperl_source_group, $rperl_source_subgroup );
334             }
335              
336             # TypeInnerProperties -> MY Type '$TYPED_' WORD OP02_ARRAY_THINARROW SubExpression ']' OP19_VARIABLE_ASSIGN 'undef'
337             elsif ( ref $property_type_inner eq 'TypeInnerProperties_239' ) {
338 0         0 $property_my = $property_type_inner->{children}->[0];
339 0         0 $property_type = $property_type_inner->{children}->[1]->{children}->[0];
340 0         0 $property_TYPED = $property_type_inner->{children}->[2];
341 0         0 $property_arrayref_thinarrow = $property_type_inner->{children}->[4];
342 0         0 $property_arrayref_index_max = $property_type_inner->{children}->[5];
343 0         0 $property_arrayref_rightbracket = $property_type_inner->{children}->[6];
344 0         0 $property_assign = $property_type_inner->{children}->[7];
345 0         0 $property_subexpression_string = $property_type_inner->{children}->[8];
346              
347             $rperl_source_group->{PMC}
348 0         0 .= $property_key . q{ }
349             . $property_fat_arrow . q{ }
350             . $property_my . q{ }
351             . $property_type . q{ }
352             . $property_TYPED
353             . $property_name
354             . $property_arrayref_thinarrow;
355              
356 0         0 $rperl_source_subgroup = $property_arrayref_index_max->ast_to_rperl__generate($modes);
357 0         0 RPerl::Generator::source_group_append( $rperl_source_group, $rperl_source_subgroup );
358              
359 0         0 $rperl_source_group->{PMC} .= $property_arrayref_rightbracket . q{ } . $property_assign . q{ } . $property_subexpression_string;
360             }
361             else {
362 0         0 die RPerl::Parser::rperl_rule__replace( 'ERROR ECOGEASCP00, CODE GENERATOR, ABSTRACT SYNTAX TO C++: Grammar rule '
363             . ( ref $self )
364             . ' found where TypeInnerProperties_238 or TypeInnerProperties_239 expected, dying' )
365             . "\n";
366             }
367              
368             # CREATE SYMBOL TABLE ENTRY
369 4 50       20 if ( exists $modes->{_symbol_table}->{ $modes->{_symbol_table}->{_namespace} }->{_properties}->{$property_key} ) {
370             die 'ERROR ECOGEASRP10, CODE GENERATOR, ABSTRACT SYNTAX TO RPERL: OO property '
371             . $property_key
372             . ' already declared in this scope, namespace '
373             . $modes->{_symbol_table}->{_namespace}
374 0         0 . ', dying' . "\n";
375             }
376              
377             # RPerl::diag( 'in Class::Generator->ast_to_rperl__generate(), property ' . $i . ', have $parent_package_names = ' . "\n" . Dumper($parent_package_names) . "\n" ) if (scalar @{$parent_package_names});
378              
379             # disallow name masking of inherited $properties, causes mismatching behavior in PERLOPS_PERLTYPES vs CPPOPS_CPPTYPES
380 4         9 foreach my $parent_package_name (@{$parent_package_names}) {
  4         13  
381 1 50       7 if ( exists $modes->{_symbol_table}->{ $parent_package_name . q{::} }->{_properties}->{$property_key} ) {
382 0         0 die 'ERROR ECOGEASRP11, CODE GENERATOR, ABSTRACT SYNTAX TO RPERL: OO property '
383             . q{'} . $property_key . q{'}
384             . ' already declared in parent namespace '
385             . q{'} . $parent_package_name . q{::} . q{'}
386             . ', name masking disallowed, dying' . "\n";
387             }
388             }
389              
390 4         22 $modes->{_symbol_table}->{ $modes->{_symbol_table}->{_namespace} }->{_properties}->{$property_key}
391             = { isa => 'RPerl::DataStructure::Hash::Properties', type => $property_type };
392             }
393             }
394 20         112 $rperl_source_group->{PMC} .= "\n" . $properties_right_brace . $properties_semicolon . "\n";
395             }
396             else { # ( ref $properties eq 'Properties_77' ) { ## no critic qw(ProhibitPostfixControls) # SYSTEM SPECIAL 6: PERL CRITIC FILED ISSUE #639, not postfix foreach or if
397             # empty $properties
398 49         293 my string $properties_our_hashref = $properties->{children}->[0];
399 49         166 my string $properties_equal = $properties->{children}->[1];
400 49         154 my string $properties_left_brace = $properties->{children}->[2];
401 49         139 my string $properties_right_brace = $properties->{children}->[3];
402 49         173 my string $properties_semicolon = $properties->{children}->[4];
403             $rperl_source_group->{PMC}
404 49         365 .= $properties_our_hashref . q{ } . $properties_equal . q{ } . $properties_left_brace . $properties_right_brace . $properties_semicolon . "\n";
405             }
406              
407 69 100       350 if ( exists $method_or_subroutine_star->{children}->[0] ) {
408 64 50       386 if ( $modes->{label} eq 'ON' ) {
409 0         0 $rperl_source_group->{PMC} .= "\n" . '# [[[ SUBROUTINES & OO METHODS ]]]' . "\n\n";
410             }
411             }
412 69         195 foreach my object $method_or_subroutine ( ## no critic qw(ProhibitPostfixControls) # SYSTEM SPECIAL 6: PERL CRITIC FILED ISSUE #639, not postfix foreach or if
413 69         284 @{ $method_or_subroutine_star->{children} }
414             )
415             {
416 100         2842 $rperl_source_subgroup = $method_or_subroutine->ast_to_rperl__generate($modes);
417 87         1914 RPerl::Generator::source_group_append( $rperl_source_group, $rperl_source_subgroup );
418             }
419              
420 56 50       256 if ( $modes->{label} eq 'ON' ) {
421 0         0 $rperl_source_group->{PMC} .= "\n" . $retval_literal_number . $retval_semicolon . ' # end of class' . "\n";
422             }
423             else {
424 56         235 $rperl_source_group->{PMC} .= $retval_literal_number . $retval_semicolon . "\n";
425             }
426 56         935 return $rperl_source_group;
427             }
428              
429             sub ast_to_cpp__generate__CPPOPS_PERLTYPES {
430 0     0   0 { my string_hashref::method $RETURN_TYPE };
  0         0  
431 0         0 ( my object $self, my string $package_name_underscores, my string_hashref $modes ) = @ARG;
432 0         0 my string_hashref $cpp_source_group = {
433             CPP => q{// <<< RP::CU::M::C::G __DUMMY_SOURCE_CODE CPPOPS_PERLTYPES >>>} . "\n",
434             H => q{// <<< RP::CU::M::C::G __DUMMY_SOURCE_CODE CPPOPS_PERLTYPES >>>} . "\n",
435             PMC => q{# <<< RP::CU::M::C::G __DUMMY_SOURCE_CODE CPPOPS_PERLTYPES >>>} . "\n"
436             };
437              
438             #...
439 0         0 return $cpp_source_group;
440             }
441              
442             sub ast_to_cpp__generate__CPPOPS_CPPTYPES {
443 23     23   50 { my string_hashref::method $RETURN_TYPE };
  23         44  
444 23         107 ( my object $self, my string $package_name_underscores, my string_hashref $modes ) = @ARG;
445 23         162 my string_hashref $cpp_source_group = { H_INCLUDES => q{}, H => q{}, CPP => q{} };
446              
447             #RPerl::diag( 'in Class::Generator->ast_to_cpp__generate__CPPOPS_CPPTYPES(), received $self = ' . "\n" . RPerl::Parser::rperl_ast__dump($self) . "\n" );
448             #RPerl::diag( 'in Class::Generator->ast_to_cpp__generate__CPPOPS_CPPTYPES(), received $package_name_underscores = ' . $package_name_underscores . "\n");
449             #RPerl::diag( 'in Class::Generator->ast_to_cpp__generate__CPPOPS_CPPTYPES(), received $modes = ' . "\n" . Dumper($modes) . "\n");
450             # RPerl::diag( 'in Class::Generator->ast_to_cpp__generate__CPPOPS_CPPTYPES(), received $modes->{_symbol_table} = ' . "\n" . Dumper($modes->{_symbol_table}) . "\n");
451              
452 23         82 my string $self_class = ref $self;
453              
454             # unwrap Class_72 from Module_25
455 23 50       97 if ( ($self_class) eq 'Module_25' ) {
456 23         81 $self = $self->{children}->[0];
457 23         84 $self_class = ref $self;
458             }
459              
460 23 50       83 if ( ($self_class) ne 'Class_72' ) {
461 0         0 die RPerl::Parser::rperl_rule__replace( 'ERROR ECOGEASCP00, CODE GENERATOR, ABSTRACT SYNTAX TO C++, CPPOPS_CPPTYPES: Grammar rule '
462             . ($self_class)
463             . ' found where Module_25 or Class_72 expected, dying' )
464             . "\n";
465             }
466              
467             # Class: 'use parent qw(' WordScoped ')' ';' Include Critic* Exports? Include* Constant* Properties SubroutineOrMethod* LITERAL_NUMBER ';' ;
468 23         111 my string $parent_name = $self->{children}->[1]->{children}->[0];
469 23         124 my string $use_keyword = $self->{children}->[4]->{children}->[0];
470 23         54 my object $exports_optional = $self->{children}->[6];
471 23         57 my object $include_star = $self->{children}->[7];
472 23         89 my object $constant_star = $self->{children}->[8];
473 23         54 my object $properties = $self->{children}->[9];
474 23         54 my object $method_or_subroutine_star = $self->{children}->[10];
475              
476 23 50       101 if ( $modes->{label} eq 'ON' ) {
477 0         0 $cpp_source_group->{H_INCLUDES} .= '// [[[ INCLUDES & OO INHERITANCE INCLUDES ]]]' . "\n";
478 0         0 $cpp_source_group->{CPP} .= '// [[[ INCLUDES ]]]' . "\n";
479              
480             # DEV NOTE, CORRELATION #rp043: no need to include RPerl.cpp multiple times in one file
481 0 0 0     0 if (not ((exists $modes->{current_package_count}) and (defined $modes->{current_package_count}) and ($modes->{current_package_count} >= 1))) {
      0        
482 0         0 $cpp_source_group->{H_INCLUDES} .= <<EOL;
483             #include <RPerl.cpp> // -> RPerl.h -> (rperltypes_mode.h; rperloperations.h; rperltypes.h; HelperFunctions.cpp)
484             EOL
485             }
486             }
487             else {
488             # DEV NOTE, CORRELATION #rp043: no need to include RPerl.cpp multiple times in one file
489 23 50 33     236 if (not ((exists $modes->{current_package_count}) and (defined $modes->{current_package_count}) and ($modes->{current_package_count} >= 1))) {
      33        
490 23         81 $cpp_source_group->{H_INCLUDES} .= <<EOL;
491             #include <RPerl.cpp>
492             EOL
493             }
494             }
495              
496             # RPerl::diag('in Class::Generator->ast_to_cpp__generate__CPPOPS_CPPTYPES(), have $modes->{_enable_sse} = ' . Dumper($modes->{_enable_sse}) . "\n");
497             # RPerl::diag('in Class::Generator->ast_to_cpp__generate__CPPOPS_CPPTYPES(), have $modes->{_enable_gmp} = ' . Dumper($modes->{_enable_gmp}) . "\n");
498              
499             # NEED FIX WIN32: change hard-coded forward-slash in generated path name below?
500             # NEED FIX: handle absolute vs relative include paths
501 23         89 my string $module_file_name = $package_name_underscores;
502 23         168 $module_file_name =~ s/__/\//gxms;
503 23         68 $module_file_name .= '.pm';
504              
505             # RPerl::diag('in Class::Generator->ast_to_cpp__generate__CPPOPS_CPPTYPES(), have $module_file_name = ' . $module_file_name . "\n");
506              
507 23 50 33     106 if ( ( exists $modes->{_enable_sse} ) and ( defined $modes->{_enable_sse} ) ) {
508 0         0 foreach my string $module_path_name ( keys %{ $modes->{_enable_sse} } ) {
  0         0  
509 0 0 0     0 if ( ( $module_path_name =~ /$module_file_name$/xms ) and ( $modes->{_enable_sse}->{$module_path_name} ) ) {
510 0         0 $cpp_source_group->{H_INCLUDES} .= '#include <rperlsse.h>' . "\n";
511             }
512             }
513             }
514              
515             # RPerl::diag('in Class::Generator->ast_to_cpp__generate__CPPOPS_CPPTYPES(), have $modes->{_enable_gmp} = ' . Dumper($modes->{_enable_gmp}) . "\n");
516 23 50 33     95 if ( ( exists $modes->{_enable_gmp} ) and ( defined $modes->{_enable_gmp} ) ) {
517 0         0 foreach my string $module_path_name ( keys %{ $modes->{_enable_gmp} } ) {
  0         0  
518 0 0 0     0 if ( ( $module_path_name =~ /$module_file_name$/xms ) and ( $modes->{_enable_gmp}->{$module_path_name} ) ) {
519 0         0 $cpp_source_group->{H_INCLUDES} .= '#include <rperlgmp.h>' . "\n";
520             }
521             }
522             }
523              
524             # RPerl::diag('in Class::Generator->ast_to_cpp__generate__CPPOPS_CPPTYPES(), have $modes->{_enable_gsl} = ' . Dumper($modes->{_enable_gsl}) . "\n");
525 23 50 33     86 if ( ( exists $modes->{_enable_gsl} ) and ( defined $modes->{_enable_gsl} ) ) {
526 0         0 foreach my string $module_path_name ( keys %{ $modes->{_enable_gsl} } ) {
  0         0  
527 0 0 0     0 if ( ( $module_path_name =~ /$module_file_name$/xms ) and ( $modes->{_enable_gsl}->{$module_path_name} ) ) {
528 0         0 $cpp_source_group->{H_INCLUDES} .= '#include <rperlgsl.h>' . "\n";
529             }
530             }
531             }
532              
533             # NEED FIX WIN32: change hard-coded forward-slash in generated path name below?
534             # NEED FIX: handle absolute vs relative include paths
535             # RPerl::diag('in Class::Generator->ast_to_cpp__generate__CPPOPS_CPPTYPES(), have $parent_name = ' . $parent_name . "\n");
536 23         79 my string $parent_name_path = $parent_name;
537 23         164 $parent_name_path =~ s/::/\//gxms;
538 23         59 $parent_name_path .= '.cpp';
539 23 50 33     177 if ( $parent_name =~ /^\w+Perl::Config$/ ) { # DEV NOTE, CORRELATION #rp027: MathPerl::Config, PhysicsPerl::Config, etc
    50          
540              
541             # RPerl::diag('in Class::Generator->ast_to_cpp__generate__CPPOPS_CPPTYPES(), skipping system config file $parent_name = ' . $parent_name . "\n");
542             }
543             elsif ( ( ( substr $parent_name_path, 0, 5 ) ne 'RPerl' ) and ( ( substr $parent_name_path, 0, 5 ) ne 'rperl' ) ) {
544             # RPerl::diag('in Class::Generator->ast_to_cpp__generate__CPPOPS_CPPTYPES(), have user-defined module to possibly be #include $parent_name = ' . $parent_name . "\n");
545             # RPerl::diag('in Class::Generator->ast_to_cpp__generate__CPPOPS_CPPTYPES(), have $modes = ' . Dumper($modes) . "\n");
546              
547             # DEV NOTE, CORRELATION #rp042: do not recursively load the same .cpp/.h file from within itself
548             # it is incorrect for a subclass inside a multi-class file to include its parent class' .cpp file name, which is the .cpp version of it's own .h file name
549 0         0 my $parent_name_length = (length $parent_name) + 3;
550 0 0       0 if (($parent_name . '.pm') ne (substr $modes->{_input_file_name_current}, ($parent_name_length * -1), $parent_name_length)) {
551             # non-RPerl user-defined module, wrapped in double-quotes " " to denote user nature
552 0         0 $cpp_source_group->{H_INCLUDES} .= '#include "' . $parent_name_path . '"' . "\n";
553             }
554             }
555             else {
556             # RPerl system module, wrapped in angle-brackets < > to denote system nature
557 23         153 $cpp_source_group->{H_INCLUDES} .= '#include <' . $parent_name_path . '>' . "\n";
558             }
559 23         69 $cpp_source_group->{CPP} .= '#include "__NEED_HEADER_PATH"' . "\n"; # DEV NOTE, CORRELATION #rp033: defer setting header include path until files are saved in Compiler
560              
561 23         44 my string_hashref $cpp_source_subgroup;
562              
563              
564              
565              
566             # START HERE: figure out how to do Exports in C++, convert the Exports code below from RPerl output to C++ output
567             # START HERE: figure out how to do Exports in C++, convert the Exports code below from RPerl output to C++ output
568             # START HERE: figure out how to do Exports in C++, convert the Exports code below from RPerl output to C++ output
569              
570             =DISABLED_NEED_CONVERT_FROM_RPERL_TO_CPP_OUTPUT
571             if ( exists $exports_optional->{children}->[0] ) {
572             # RPerl::diag( 'in Class::Generator->ast_to_cpp__generate__CPPOPS_CPPTYPES(), have YES EXPORTS ' . "\n" );
573             if ( $modes->{label} eq 'ON' ) {
574             $rperl_source_group->{H} .= "\n" . '# [[[ EXPORTS ]]]' . "\n";
575             }
576             my object $exports = $exports_optional->{children}->[0];
577             my string $use_exporter = $exports->{children}->[0];
578             my string $export = $exports->{children}->[1];
579             my string $export_ok = $exports->{children}->[2];
580              
581             $rperl_source_group->{H} .= $use_exporter; # already has a newline
582             if ( exists $export->{children}->[0] ) {
583             $rperl_source_group->{H} .= $export->{children}->[0]->{attr} . $export->{children}->[1]->{attr} . ';' . "\n"; # DEV NOTE: does not capture semicolon in AST for some reason, must hard-code here
584             }
585             if ( exists $export_ok->{children}->[0] ) {
586             $rperl_source_group->{H} .= $export_ok->{children}->[0]->{attr} . $export_ok->{children}->[1]->{attr} . ';' . "\n"; # DEV NOTE: does not capture semicolon in AST for some reason, must hard-code here
587             }
588             # RPerl::diag( 'in Class::Generator->ast_to_cpp__generate__CPPOPS_CPPTYPES(), AFTER EXPORTS, have $rperl_source_group->{H} = ' . "\n" . RPerl::Parser::rperl_ast__dump($rperl_source_group->{H}) . "\n" );
589             }
590             =cut
591              
592              
593              
594              
595 23         46 foreach my object $include ( @{ $include_star->{children} } ) { ## no critic qw(ProhibitPostfixControls) # SYSTEM SPECIAL 6: PERL CRITIC FILED ISSUE #639, not postfix foreach or if
  23         137  
596             # RPerl::diag('in Class::Generator->ast_to_cpp__generate__CPPOPS_CPPTYPES(), have $package_name_underscores = ' . $package_name_underscores . "\n");
597 0         0 $cpp_source_subgroup = $include->ast_to_cpp__generate__CPPOPS_CPPTYPES( $package_name_underscores, $modes );
598 0         0 RPerl::Generator::source_group_append( $cpp_source_group, $cpp_source_subgroup );
599             }
600              
601 23         58 my string $cpp_source_tmp = <<EOL;
602              
603             # ifdef __PERL__TYPES
604              
605             Purposefully_die_from_a_compile-time_error,_due_to____PERL__TYPES_being_defined.__We_need_to_define_only___CPP__TYPES_in_this_file!
606              
607             # elif defined __CPP__TYPES
608              
609             EOL
610              
611 23         89 $cpp_source_group->{H} .= $cpp_source_tmp;
612 23         57 $cpp_source_group->{CPP} .= $cpp_source_tmp;
613              
614 23 50       79 if ( $modes->{label} eq 'ON' ) {
615 0         0 $cpp_source_tmp = ( ( '// [[[<<< BEGIN CPP TYPES >>>]]]' . "\n" ) x 3 ) . "\n";
616 0         0 $cpp_source_group->{H} .= $cpp_source_tmp;
617 0         0 $cpp_source_group->{CPP} .= $cpp_source_tmp;
618             }
619              
620 23 100       82 if ( exists $constant_star->{children}->[0] ) {
621 1 50       8 if ( $modes->{label} eq 'ON' ) {
622 0         0 $cpp_source_group->{H} .= '// [[[ CONSTANTS ]]]' . "\n";
623             }
624 1         3 foreach my object $constant ( @{ $constant_star->{children} } ) { ## no critic qw(ProhibitPostfixControls) # SYSTEM SPECIAL 6: PERL CRITIC FILED ISSUE #639, not postfix foreach or if
  1         3  
625 2         49 $cpp_source_subgroup = $constant->ast_to_cpp__generate__CPPOPS_CPPTYPES( $package_name_underscores, $modes );
626 2         7 $cpp_source_group->{H} .= $cpp_source_subgroup->{H};
627 2         5 $cpp_source_group->{_H_constants_shims}->{$package_name_underscores} .= $cpp_source_subgroup->{_H_constants_shims}->{$package_name_underscores};
628             }
629 1         5 $cpp_source_group->{H} .= "\n";
630             }
631              
632 23 50       82 if ( $modes->{label} eq 'ON' ) {
633 0         0 $cpp_source_group->{H} .= '// [[[ OO INHERITANCE ]]]' . "\n";
634             }
635 23         66 my string $parent_name_underscores = $parent_name;
636 23         124 $parent_name_underscores =~ s/::/__/gxms;
637              
638             # RPerl::diag( 'in Class::Generator->ast_to_cpp__generate__CPPOPS_CPPTYPES(), have $parent_name_underscores = ' . $parent_name_underscores . "\n");
639              
640             # DEV NOTE: avoid namespace clobbering of CPPOPS base class over PERLOPS base class
641 23 100       75 if ( $parent_name_underscores eq 'RPerl__CompileUnit__Module__Class' ) {
642 20         53 $parent_name_underscores .= '__CPP';
643             }
644              
645 23         107 $cpp_source_group->{H} .= 'class ' . $package_name_underscores . ' : public ' . $parent_name_underscores . ' {' . "\n";
646 23         67 $cpp_source_group->{H} .= 'public:' . "\n";
647              
648 23         65 my string_arrayref $properties_accessors_mutators = [];
649 23         66 my string_arrayref $properties_accessors_mutators_shims = [];
650 23         55 my string_arrayref $properties_declarations = [];
651 23         64 my string_arrayref $properties_initializations = [];
652 23         38 my string $property_declaration;
653              
654             # prepare for later use in:
655             # disallow name masking of inherited $properties, AND
656             # generate accessors & mutators for inherited $properties
657 23         57 my string $package_name_colons = $package_name_underscores;
658 23         93 $package_name_colons =~ s/__/::/gxms;
659 23         214 my $parent_package_names = RPerl::CompileUnit::Module::Class::parent_and_grandparent_package_names($package_name_colons);
660             # RPerl::diag( 'in Class::Generator->ast_to_cpp__generate__CPPOPS_CPPTYPES(), have $parent_package_names = ' . Dumper($parent_package_names) . "\n" );
661              
662             # non-empty $properties
663             # Properties -> 'our hashref $properties' OP19_VARIABLE_ASSIGN LBRACE HashEntryProperties STAR-27 '}' ';'
664             # HashEntryProperties -> WORD OP20_HASH_FATARROW TypeInnerProperties
665 23 100       141 if ( ref $properties eq 'Properties_76' ) { ## no critic qw(ProhibitPostfixControls) # SYSTEM SPECIAL 6: PERL CRITIC FILED ISSUE #639, not postfix foreach or if
666 4         20 $modes->{_inside_class_properties} = 1;
667 4         21 $property_declaration = q{};
668 4         28 my object $property_0 = $properties->{children}->[3];
669 4         9 my object $properties_1_to_n = $properties->{children}->[4];
670              
671 4         29 my string $property_key = $property_0->{children}->[0]->{children}->[0];
672 4         31 $property_key =~ s/^(\w+)\s*$/$1/gxms; # strip trailing whitespace, caused by grammar matching operator names with trailing spaces
673 4 50       24 if ( $property_key !~ /^[a-z]/ ) {
674 0         0 die 'ERROR ECOGEASCP24, CODE GENERATOR, ABSTRACT SYNTAX TO C++: invalid OO properties name (hash key) ' . q{'}
675             . $property_key . q{'}
676             . ' does not start with a lowercase letter a-z, dying' . "\n";
677             }
678 4         15 my object $property_type_inner = $property_0->{children}->[2];
679 4         8 my string $property_type = undef;
680 4         8 my object $property_subexpression = undef;
681 4         6 my object $property_arrayref_index_max = undef;
682 4         20 my string $property_name = $property_type_inner->{children}->[3]->{children}->[0];
683 4         23 $property_name =~ s/^(\w+)\s*$/$1/gxms; # strip trailing whitespace, caused by grammar matching operator names with trailing spaces
684              
685             # DEV NOTE: we can do error checking once here instead of twice for TypeInnerProperties_238 & TypeInnerProperties_239 below
686             # because they both have OpStringOrWord as sub-element 3, grabbed as $property_name above
687 4 50       16 if ( $property_name ne $property_key ) {
688             # DEV NOTE, CORRELATION #rp030: matches numbering of ECOGEPPRP20 in RPerl/CompileUnit/Module/Class.pm
689 0         0 die 'ERROR ECOGEASCP21, CODE GENERATOR, ABSTRACT SYNTAX TO C++: redundant name mismatch, inner type name ' . q{'}
690             . $property_name . q{'}
691             . ' does not equal OO properties key ' . q{'}
692             . $property_key . q{'}
693             . ', dying' . "\n";
694             }
695 4 50 33     80 if ((exists $perlapinames_generated::FUNCTIONS_DOCUMENTED->{$property_name}) or
      33        
      33        
696             (exists $perlapinames_generated::FUNCTIONS_UNDOCUMENTED->{$property_name}) or
697             (exists $perlapinames_generated::VARIABLES_DOCUMENTED->{$property_name}) or
698             (exists $perlapinames_generated::VARIABLES_UNDOCUMENTED->{$property_name})) {
699 0         0 die 'ERROR ECOGEASCP41, CODE GENERATOR, ABSTRACT SYNTAX TO C++: Perl API name conflict, OO property name ' . q{'}
700             . $property_name . q{'}
701             . ' is the same as a protected function or variable name in the Perl API, please choose a different name, dying' . "\n";
702             }
703              
704             # TypeInnerProperties -> MY Type '$TYPED_' WORD OP19_VARIABLE_ASSIGN SubExpression
705 4 50       19 if ( ref $property_type_inner eq 'TypeInnerProperties_238' ) {
    0          
706 4         15 $property_type = $property_type_inner->{children}->[1]->{children}->[0];
707 4         12 $property_subexpression = $property_type_inner->{children}->[5];
708             }
709              
710             # TypeInnerProperties -> MY Type '$TYPED_' WORD OP02_ARRAY_THINARROW SubExpression ']' OP19_VARIABLE_ASSIGN 'undef'
711             elsif ( ref $property_type_inner eq 'TypeInnerProperties_239' ) {
712 0         0 $property_type = $property_type_inner->{children}->[1]->{children}->[0];
713 0         0 $property_arrayref_index_max = $property_type_inner->{children}->[5];
714             }
715             else {
716 0         0 die RPerl::Parser::rperl_rule__replace( 'ERROR ECOGEASCP00, CODE GENERATOR, ABSTRACT SYNTAX TO C++: Grammar rule '
717             . ( ref $self )
718             . ' found where TypeInnerProperties_238 or TypeInnerProperties_239 expected, dying' )
719             . "\n";
720             }
721              
722             # RPerl::diag( 'in Class::Generator->ast_to_cpp__generate__CPPOPS_CPPTYPES(), property 0, have $property_key = ' . "\n" . RPerl::Parser::rperl_ast__dump($property_key) . "\n" );
723             # RPerl::diag( 'in Class::Generator->ast_to_cpp__generate__CPPOPS_CPPTYPES(), property 0, have $property_type_inner = ' . "\n" . RPerl::Parser::rperl_ast__dump($property_type_inner) . "\n" );
724             # RPerl::diag( 'in Class::Generator->ast_to_cpp__generate__CPPOPS_CPPTYPES(), property 0, have $property_subexpression = ' . "\n" . RPerl::Parser::rperl_ast__dump($property_subexpression) . "\n" );
725             # RPerl::diag( 'in Class::Generator->ast_to_cpp__generate__CPPOPS_CPPTYPES(), property 0, have $property_type = ' . "\n" . RPerl::Parser::rperl_ast__dump($property_type) . "\n" );
726             # RPerl::diag( 'in Class::Generator->ast_to_cpp__generate__CPPOPS_CPPTYPES(), property 0, have $property_arrayref_index_max = ' . "\n" . RPerl::Parser::rperl_ast__dump($property_arrayref_index_max) . "\n" );
727              
728             # CREATE SYMBOL TABLE ENTRY
729 4 50       29 if ( exists $modes->{_symbol_table}->{ $modes->{_symbol_table}->{_namespace} }->{_properties}->{$property_key} ) {
730             die 'ERROR ECOGEASCP10, CODE GENERATOR, ABSTRACT SYNTAX TO C++: OO property '
731             . q{'} . $property_key . q{'}
732             . ' already declared in this scope, namespace '
733 0         0 . q{'} . $modes->{_symbol_table}->{_namespace} . q{'}
734             . ', dying' . "\n";
735             }
736              
737             # RPerl::diag( 'in Class::Generator->ast_to_cpp__generate__CPPOPS_CPPTYPES(), property 0, have $parent_package_names = ' . "\n" . Dumper($parent_package_names) . "\n" ) if (scalar @{$parent_package_names});
738              
739             # disallow name masking of inherited $properties, causes mismatching behavior in PERLOPS_PERLTYPES vs CPPOPS_CPPTYPES
740 4         10 foreach my $parent_package_name (@{$parent_package_names}) {
  4         20  
741 3 100       27 if ( exists $modes->{_symbol_table}->{ $parent_package_name . q{::} }->{_properties}->{$property_key} ) {
742 1         31 die 'ERROR ECOGEASCP11, CODE GENERATOR, ABSTRACT SYNTAX TO C++: OO property '
743             . q{'} . $property_key . q{'}
744             . ' already declared in parent namespace '
745             . q{'} . $parent_package_name . q{::} . q{'}
746             . ', name masking disallowed, dying' . "\n";
747             }
748             }
749              
750 3         19 $modes->{_symbol_table}->{ $modes->{_symbol_table}->{_namespace} }->{_properties}->{$property_key}
751             = { isa => 'RPerl::DataStructure::Hash::Properties', type => $property_type };
752              
753 3         81 $property_type = RPerl::Generator::type_convert_perl_to_cpp( $property_type, 1 ); # $pointerify_classes = 1
754 3         14 $modes->{_symbol_table}->{ $modes->{_symbol_table}->{_namespace} }->{_properties}->{$property_key}->{type_cpp} = $property_type; # add converted C++ type to symtab entry
755              
756 3 50       11 if ( defined $property_arrayref_index_max ) {
757 0         0 my string $property_arrayref_index_max_address = "$property_arrayref_index_max";
758 0         0 $property_arrayref_index_max = RPerl::Generator::arrayref_convert_index_max_to_size($property_arrayref_index_max);
759 0         0 $cpp_source_subgroup = $property_arrayref_index_max->ast_to_cpp__generate__CPPOPS_CPPTYPES($modes);
760 0 0       0 if ( $property_arrayref_index_max_address eq "$property_arrayref_index_max" ) { # not compensated automatically, must compensate manually
761 0         0 $cpp_source_subgroup->{CPP} = q{(} . $cpp_source_subgroup->{CPP} . q{) + 1};
762             }
763 0         0 push @{$properties_initializations}, ( q{ } . 'this->' . $property_key . '.resize(' . $cpp_source_subgroup->{CPP} . ');' );
  0         0  
764             }
765              
766 3         15 $property_declaration = q{ } . $property_type . q{ } . $property_key;
767              
768             # SubExpression_150 ISA RPerl::Operation::Expression::SubExpression::Literal::Undefined,
769             # don't perform any C++ initialization for properties initialized to 'undef' in Perl
770 3 50 33     23 if ( ( defined $property_subexpression ) and ( ( ref $property_subexpression ) ne 'SubExpression_150' ) ) {
771 3         78 $cpp_source_subgroup = $property_subexpression->ast_to_cpp__generate__CPPOPS_CPPTYPES($modes);
772 3         15 $property_declaration .= ' = ' . $cpp_source_subgroup->{CPP};
773             }
774              
775 3         7 $property_declaration .= ';';
776 3         6 push @{$properties_declarations}, $property_declaration;
  3         10  
777              
778 3         68 $cpp_source_subgroup = ast_to_cpp__generate_accessors_mutators__CPPOPS_CPPTYPES( $property_key, $modes->{_symbol_table}->{_namespace}, $modes );
779 3 50       13 if ( $cpp_source_subgroup->{H} ne q{} ) {
780 3         11 push @{$properties_accessors_mutators}, $cpp_source_subgroup->{H};
  3         10  
781             }
782 3 0 33     16 if ((exists $cpp_source_subgroup->{PMC}) and (defined $cpp_source_subgroup->{PMC}) and ($cpp_source_subgroup->{PMC} ne q{})) {
      33        
783 0         0 push @{$properties_accessors_mutators_shims}, $cpp_source_subgroup->{PMC};
  0         0  
784             }
785              
786 3         6 my integer $i = 0;
787 3         6 foreach my object $property ( @{ $properties_1_to_n->{children} } ) {
  3         13  
788 6 100       18 if ( ( ref $property ) eq 'TERMINAL' ) { # skip comma between properties
789 3         6 next;
790             }
791 3         5 $i++;
792              
793 3         5 $property_subexpression = undef;
794 3         4 $property_arrayref_index_max = undef;
795              
796 3         11 $property_key = $property->{children}->[0]->{children}->[0];
797 3         16 $property_key =~ s/^(\w+)\s*$/$1/gxms; # strip trailing whitespace, caused by grammar matching operator names with trailing spaces
798 3 50       9 if ( $property_key !~ /^[a-z]/ ) {
799 0         0 die 'ERROR ECOGEASCP24, CODE GENERATOR, ABSTRACT SYNTAX TO C++: invalid OO properties name (hash key) ' . q{'}
800             . $property_key . q{'}
801             . ' does not start with a lowercase letter a-z, dying' . "\n";
802             }
803 3         6 $property_type_inner = $property->{children}->[2];
804 3         12 $property_name = $property_type_inner->{children}->[3]->{children}->[0];
805 3         11 $property_name =~ s/^(\w+)\s*$/$1/gxms; # strip trailing whitespace, caused by grammar matching operator names with trailing spaces
806              
807             # DEV NOTE: we can do error checking once here instead of twice for TypeInnerProperties_238 & TypeInnerProperties_239 below
808             # because they both have OpStringOrWord as sub-element 3, grabbed as $property_name above
809 3 50       9 if ( $property_name ne $property_key ) {
810             # DEV NOTE, CORRELATION #rp030: matches numbering of ECOGEPPRP20 in RPerl/CompileUnit/Module/Class.pm
811 0         0 die 'ERROR ECOGEASCP21, CODE GENERATOR, ABSTRACT SYNTAX TO C++: redundant name mismatch, inner type name ' . q{'}
812             . $property_name . q{'}
813             . ' does not equal OO properties key ' . q{'}
814             . $property_key . q{'}
815             . ', dying' . "\n";
816             }
817 3 50 33     34 if ((exists $perlapinames_generated::FUNCTIONS_DOCUMENTED->{$property_name}) or
      33        
      33        
818             (exists $perlapinames_generated::FUNCTIONS_UNDOCUMENTED->{$property_name}) or
819             (exists $perlapinames_generated::VARIABLES_DOCUMENTED->{$property_name}) or
820             (exists $perlapinames_generated::VARIABLES_UNDOCUMENTED->{$property_name})) {
821 0         0 die 'ERROR ECOGEASCP41, CODE GENERATOR, ABSTRACT SYNTAX TO C++: Perl API name conflict, OO property name ' . q{'}
822             . $property_name . q{'}
823             . ' is the same as a protected function or variable name in the Perl API, please choose a different name, dying' . "\n";
824             }
825              
826             # TypeInnerProperties -> MY Type '$TYPED_' WORD OP19_VARIABLE_ASSIGN SubExpression
827 3 50       10 if ( ref $property_type_inner eq 'TypeInnerProperties_238' ) {
    0          
828 3         10 $property_type = $property_type_inner->{children}->[1]->{children}->[0];
829 3         7 $property_subexpression = $property_type_inner->{children}->[5];
830             }
831              
832             # TypeInnerProperties -> MY Type '$TYPED_' WORD OP02_ARRAY_THINARROW SubExpression ']' OP19_VARIABLE_ASSIGN 'undef'
833             elsif ( ref $property_type_inner eq 'TypeInnerProperties_239' ) {
834 0         0 $property_type = $property_type_inner->{children}->[1]->{children}->[0];
835 0         0 $property_arrayref_index_max = $property_type_inner->{children}->[5];
836             }
837             else {
838 0         0 die RPerl::Parser::rperl_rule__replace( 'ERROR ECOGEASCP00, CODE GENERATOR, ABSTRACT SYNTAX TO C++: Grammar rule '
839             . ( ref $self )
840             . ' found where TypeInnerProperties_238 or TypeInnerProperties_239 expected, dying' )
841             . "\n";
842             }
843              
844             # RPerl::diag( 'in Class::Generator->ast_to_cpp__generate__CPPOPS_CPPTYPES(), property ' . $i . ', have $property_key = ' . "\n" . RPerl::Parser::rperl_ast__dump($property_key) . "\n" );
845             # RPerl::diag( 'in Class::Generator->ast_to_cpp__generate__CPPOPS_CPPTYPES(), property ' . $i . ', have $property_type_inner = ' . "\n" . RPerl::Parser::rperl_ast__dump($property_type_inner) . "\n" );
846             # RPerl::diag( 'in Class::Generator->ast_to_cpp__generate__CPPOPS_CPPTYPES(), property ' . $i . ', have $property_subexpression = ' . "\n" . RPerl::Parser::rperl_ast__dump($property_subexpression) . "\n" );
847             # RPerl::diag( 'in Class::Generator->ast_to_cpp__generate__CPPOPS_CPPTYPES(), property ' . $i . ', have $property_type = ' . "\n" . RPerl::Parser::rperl_ast__dump($property_type) . "\n" );
848             # RPerl::diag( 'in Class::Generator->ast_to_cpp__generate__CPPOPS_CPPTYPES(), property ' . $i . ', have $property_arrayref_index_max = ' . "\n" . RPerl::Parser::rperl_ast__dump($property_arrayref_index_max) . "\n" );
849              
850             # CREATE SYMBOL TABLE ENTRY
851 3 50       11 if ( exists $modes->{_symbol_table}->{ $modes->{_symbol_table}->{_namespace} }->{_properties}->{$property_key} ) {
852             die 'ERROR ECOGEASCP10, CODE GENERATOR, ABSTRACT SYNTAX TO C++: OO property '
853             . $property_key
854             . ' already declared in this scope, namespace '
855             . $modes->{_symbol_table}->{_namespace}
856 0         0 . ', dying' . "\n";
857             }
858              
859             # RPerl::diag( 'in Class::Generator->ast_to_cpp__generate__CPPOPS_CPPTYPES(), property ' . $i . ', have $parent_package_names = ' . "\n" . Dumper($parent_package_names) . "\n" ) if (scalar @{$parent_package_names});
860            
861             # disallow name masking of inherited $properties, causes mismatching behavior in PERLOPS_PERLTYPES vs CPPOPS_CPPTYPES
862 3         8 foreach my $parent_package_name (@{$parent_package_names}) {
  3         6  
863 0 0       0 if ( exists $modes->{_symbol_table}->{ $parent_package_name . q{::} }->{_properties}->{$property_key} ) {
864 0         0 die 'ERROR ECOGEASCP11, CODE GENERATOR, ABSTRACT SYNTAX TO C++: OO property '
865             . q{'} . $property_key . q{'}
866             . ' already declared in parent namespace '
867             . q{'} . $parent_package_name . q{::} . q{'}
868             . ', name masking disallowed, dying' . "\n";
869             }
870             }
871              
872 3         13 $modes->{_symbol_table}->{ $modes->{_symbol_table}->{_namespace} }->{_properties}->{$property_key}
873             = { isa => 'RPerl::DataStructure::Hash::Properties', type => $property_type };
874              
875 3         64 $property_type = RPerl::Generator::type_convert_perl_to_cpp( $property_type, 1 ); # $pointerify_classes = 1
876 3         9 $modes->{_symbol_table}->{ $modes->{_symbol_table}->{_namespace} }->{_properties}->{$property_key}->{type_cpp} = $property_type; # add converted C++ type to symtab entry
877              
878 3 50       9 if ( defined $property_arrayref_index_max ) {
879 0         0 my string $property_arrayref_index_max_address = "$property_arrayref_index_max";
880 0         0 $property_arrayref_index_max = RPerl::Generator::arrayref_convert_index_max_to_size($property_arrayref_index_max);
881 0         0 $cpp_source_subgroup = $property_arrayref_index_max->ast_to_cpp__generate__CPPOPS_CPPTYPES($modes);
882 0 0       0 if ( $property_arrayref_index_max_address eq "$property_arrayref_index_max" ) { # not compensated automatically, must compensate manually
883 0         0 $cpp_source_subgroup->{CPP} = q{(} . $cpp_source_subgroup->{CPP} . q{) + 1};
884             }
885 0         0 push @{$properties_initializations}, ( q{ } . 'this->' . $property_key . '.resize(' . $cpp_source_subgroup->{CPP} . ');' );
  0         0  
886             }
887              
888 3         9 $property_declaration = q{ } . $property_type . q{ } . $property_key;
889              
890             # SubExpression_150 ISA RPerl::Operation::Expression::SubExpression::Literal::Undefined,
891             # don't perform any C++ initialization for properties initialized to 'undef' in Perl
892 3 50 33     19 if ( ( defined $property_subexpression ) and ( ( ref $property_subexpression ) ne 'SubExpression_150' ) ) {
893 3         67 $cpp_source_subgroup = $property_subexpression->ast_to_cpp__generate__CPPOPS_CPPTYPES($modes);
894 3         10 $property_declaration .= ' = ' . $cpp_source_subgroup->{CPP};
895             }
896              
897 3         6 $property_declaration .= ';';
898 3         6 push @{$properties_declarations}, $property_declaration;
  3         6  
899              
900 3         61 $cpp_source_subgroup = ast_to_cpp__generate_accessors_mutators__CPPOPS_CPPTYPES( $property_key, $modes->{_symbol_table}->{_namespace}, $modes );
901 3 50       12 if ( $cpp_source_subgroup->{H} ne q{} ) {
902 3         6 push @{$properties_accessors_mutators}, $cpp_source_subgroup->{H};
  3         10  
903             }
904 3 0 33     13 if ((exists $cpp_source_subgroup->{PMC}) and (defined $cpp_source_subgroup->{PMC}) and ($cpp_source_subgroup->{PMC} ne q{})) {
      33        
905 0         0 push @{$properties_accessors_mutators_shims}, $cpp_source_subgroup->{PMC};
  0         0  
906             }
907             }
908 3         10 delete $modes->{_inside_class_properties};
909             }
910              
911             # generate accessors & mutators for inherited $properties
912 22         48 foreach my $parent_package_name (@{$parent_package_names}) {
  22         105  
913             # RPerl::diag( 'in Class::Generator->ast_to_cpp__generate__CPPOPS_CPPTYPES(), have $parent_package_name = ' . $parent_package_name . "\n" );
914             # RPerl::diag( 'in Class::Generator->ast_to_cpp__generate__CPPOPS_CPPTYPES(), have $modes->{_symbol_table}->{ $parent_package_name . q{::} } = ' . Dumper($modes->{_symbol_table}->{ $parent_package_name . q{::} }) . "\n" );
915 2         17 foreach my $parent_property_key (keys %{ $modes->{_symbol_table}->{ $parent_package_name . q{::} }->{_properties} }) {
  2         17  
916 0 0       0 if (not exists $modes->{_symbol_table}->{ $package_name_colons . q{::} }->{_properties}->{$parent_property_key}) {
917 0         0 $cpp_source_subgroup = ast_to_cpp__generate_accessors_mutators__CPPOPS_CPPTYPES( $parent_property_key, $parent_package_name . q{::}, $modes );
918 0 0       0 if ( $cpp_source_subgroup->{H} ne q{} ) {
919 0         0 push @{$properties_accessors_mutators}, $cpp_source_subgroup->{H};
  0         0  
920             }
921 0 0 0     0 if ((exists $cpp_source_subgroup->{PMC}) and (defined $cpp_source_subgroup->{PMC}) and ($cpp_source_subgroup->{PMC} ne q{})) {
      0        
922 0         0 push @{$properties_accessors_mutators_shims}, $cpp_source_subgroup->{PMC};
  0         0  
923             }
924             }
925             }
926             }
927              
928 22 100       117 if ( exists $properties_declarations->[0] ) {
929 3 50       18 if ( $modes->{label} eq 'ON' ) {
930 0         0 $cpp_source_group->{H} .= ' // [[[ OO PROPERTIES ]]]' . "\n";
931             }
932 3         9 $cpp_source_group->{H} .= ( join "\n", @{$properties_declarations} ) . "\n\n";
  3         17  
933             }
934              
935 22 50       110 if ( $modes->{label} eq 'ON' ) {
936 0         0 $cpp_source_group->{H} .= ' // [[[ OO METHODS ]]]' . "\n\n";
937             }
938              
939 22 100       99 if ( exists $properties_accessors_mutators->[0] ) {
940 3 50       11 if ( $modes->{label} eq 'ON' ) {
941 0         0 $cpp_source_group->{H} .= ' // <<< OO PROPERTIES, ACCESSORS & MUTATORS >>>' . "\n";
942             }
943 3         10 $cpp_source_group->{H} .= ( join "\n", @{$properties_accessors_mutators} ) . "\n\n";
  3         16  
944             }
945              
946 22 50       86 if ( exists $properties_accessors_mutators_shims->[0] ) {
947 0 0 0     0 if ( ( not exists $cpp_source_group->{_PMC_accessors_mutators_shims} ) or ( not defined $cpp_source_group->{_PMC_accessors_mutators_shims} ) ) {
    0 0        
948 0         0 $cpp_source_group->{_PMC_accessors_mutators_shims} = {};
949             }
950             elsif (( not exists $cpp_source_group->{_PMC_accessors_mutators_shims}->{$package_name_underscores} )
951             or ( not defined $cpp_source_group->{_PMC_accessors_mutators_shims}->{$package_name_underscores} ) )
952             {
953 0         0 $cpp_source_group->{_PMC_accessors_mutators_shims}->{$package_name_underscores} = q{};
954             }
955 0         0 $cpp_source_group->{_PMC_accessors_mutators_shims}->{$package_name_underscores} .= ( join "\n", @{$properties_accessors_mutators_shims} ) . "\n";
  0         0  
956             }
957              
958 22 50       88 if ( $modes->{label} eq 'ON' ) {
959 0         0 $cpp_source_group->{H} .= ' // <<< CONSTRUCTOR & DESTRUCTOR >>>' . "\n";
960             }
961 22 50       69 if ( exists $properties_initializations->[0] ) { # initialize properties in constructor
962 0         0 $cpp_source_group->{H} .= q{ } . $package_name_underscores . '() {' . "\n" . ( join "\n", @{$properties_initializations} ) . "\n" . '}' . "\n"; # CONSTRUCTOR
  0         0  
963             }
964             else { # empty constructor
965 22         90 $cpp_source_group->{H} .= q{ } . $package_name_underscores . '() {}' . "\n"; # CONSTRUCTOR
966             }
967 22         90 $cpp_source_group->{H} .= q{ } . '~' . $package_name_underscores . '() {}' . "\n\n"; # DESTRUCTOR
968              
969 22 50       83 if ( $modes->{label} eq 'ON' ) {
970 0         0 $cpp_source_group->{H} .= ' // <<< CLASS NAME REPORTER >>>' . "\n";
971             }
972 22         65 my string $package_name_scoped = $package_name_underscores;
973 22         125 $package_name_scoped =~ s/__/::/gxms;
974 22         88 $cpp_source_group->{H} .= ' virtual string myclassname() { return (const string) "' . $package_name_scoped . '"; }' . "\n"; # CLASS NAME REPORTER
975              
976             # RPerl::diag('in Class::Generator->ast_to_cpp__generate__CPPOPS_CPPTYPES(), have $cpp_source_group->{_H_constants_shims}->{$package_name_underscores} = ' . Dumper($cpp_source_group->{_H_constants_shims}->{$package_name_underscores}) . "\n");
977 22 50 66     104 if ( ( exists $cpp_source_group->{_H_constants_shims} )
      66        
      33        
978             and ( defined $cpp_source_group->{_H_constants_shims} )
979             and ( exists $cpp_source_group->{_H_constants_shims}->{$package_name_underscores} )
980             and ( defined $cpp_source_group->{_H_constants_shims}->{$package_name_underscores} ) )
981             {
982 1         3 $cpp_source_group->{H} .= "\n";
983 1 50       4 if ( $modes->{label} eq 'ON' ) { $cpp_source_group->{H} .= ' // <<< CONSTANTS, SHIMS >>>' . "\n"; }
  0         0  
984 1         5 $cpp_source_group->{H} .= $cpp_source_group->{_H_constants_shims}->{$package_name_underscores};
985             }
986              
987 22         69 my string_arrayref $method_declarations = [];
988 22         49 my string_arrayref $method_definitions = [];
989 22         67 my string_arrayref $subroutine_declarations = [];
990 22         55 my string_arrayref $subroutine_definitions = [];
991 22         40 my string_arrayref $PMC_subroutines_shims = [];
992 22         53 my string_arrayref $CPP_subroutines_shims = [];
993              
994 22         53 foreach my object $method_or_subroutine ( ## no critic qw(ProhibitPostfixControls) # SYSTEM SPECIAL 6: PERL CRITIC FILED ISSUE #639, not postfix foreach or if
995 22         91 @{ $method_or_subroutine_star->{children} }
996             )
997             {
998 37 100       165 if ( ( ref $method_or_subroutine ) eq 'SubroutineOrMethod_88' ) { # METHOD
    50          
999 29         950 $cpp_source_subgroup = $method_or_subroutine->ast_to_cpp__generate_declaration__CPPOPS_CPPTYPES($modes);
1000 29         56 push @{$method_declarations}, $cpp_source_subgroup->{H};
  29         116  
1001 29         809 $cpp_source_subgroup = $method_or_subroutine->ast_to_cpp__generate__CPPOPS_CPPTYPES( $package_name_underscores, $modes );
1002 29         74 push @{$method_definitions}, $cpp_source_subgroup->{CPP};
  29         91  
1003 29 50 33     129 if ( ( exists $cpp_source_subgroup->{H_INCLUDES} ) and ( defined $cpp_source_subgroup->{H_INCLUDES} ) ) {
1004 0         0 $cpp_source_group->{H_INCLUDES} .= $cpp_source_subgroup->{H_INCLUDES};
1005             }
1006             }
1007             elsif ( ( ref $method_or_subroutine ) eq 'SubroutineOrMethod_87' ) { # SUBROUTINE
1008 8         214 $cpp_source_subgroup = $method_or_subroutine->ast_to_cpp__generate_declaration__CPPOPS_CPPTYPES($modes);
1009 8         15 push @{$subroutine_declarations}, $cpp_source_subgroup->{H};
  8         23  
1010 8         175 $cpp_source_subgroup = $method_or_subroutine->ast_to_cpp__generate__CPPOPS_CPPTYPES($modes);
1011 8         19 push @{$subroutine_definitions}, $cpp_source_subgroup->{CPP};
  8         30  
1012 8         200 $cpp_source_subgroup = $method_or_subroutine->ast_to_cpp__generate_shims__CPPOPS_CPPTYPES($modes);
1013 8 50 33     45 if ((exists $cpp_source_subgroup->{PMC}) and (defined $cpp_source_subgroup->{PMC})) {
1014 8         17 push @{$PMC_subroutines_shims}, $cpp_source_subgroup->{PMC};
  8         18  
1015             }
1016 8         20 push @{$CPP_subroutines_shims}, $cpp_source_subgroup->{CPP};
  8         14  
1017 8 50 33     32 if ( ( exists $cpp_source_subgroup->{H_INCLUDES} ) and ( defined $cpp_source_subgroup->{H_INCLUDES} ) ) {
1018 0         0 $cpp_source_group->{H_INCLUDES} .= $cpp_source_subgroup->{H_INCLUDES};
1019             }
1020             }
1021             else {
1022 0         0 die RPerl::Parser::rperl_rule__replace( 'ERROR ECOGEASCP00, CODE GENERATOR, ABSTRACT SYNTAX TO C++, CPPOPS_CPPTYPES: Grammar rule '
1023             . ( ref $method_or_subroutine )
1024             . ' found where SubroutineOrMethod_88 or SubroutineOrMethod_87 expected, dying' )
1025             . "\n";
1026             }
1027             }
1028              
1029 22 50       83 if ( exists $method_declarations->[0] ) {
1030 22 50       95 if ( $modes->{label} eq 'ON' ) {
1031 0         0 $cpp_source_group->{H} .= "\n" . ' // <<< USER-DEFINED METHODS >>>' . "\n";
1032             }
1033 22         62 $cpp_source_group->{H} .= ( join "\n", @{$method_declarations} ) . "\n";
  22         179  
1034             }
1035              
1036 22 50 33     112 if ( ( exists $method_definitions->[0] ) or ( exists $subroutine_definitions->[0] ) ) {
1037 22 50       101 if ( $modes->{label} eq 'ON' ) {
1038 0         0 $cpp_source_group->{CPP} .= '// [[[ SUBROUTINES & OO METHODS ]]]' . "\n\n";
1039             }
1040 22         57 $cpp_source_group->{CPP} .= ( join "\n\n", @{$method_definitions} );
  22         118  
1041 22 50       99 if ( exists $method_definitions->[0] ) { $cpp_source_group->{CPP} .= "\n\n"; }
  22         63  
1042 22         55 $cpp_source_group->{CPP} .= ( join "\n\n", @{$subroutine_definitions} );
  22         102  
1043 22 100       68 if ( exists $subroutine_definitions->[0] ) { $cpp_source_group->{CPP} .= "\n\n"; }
  3         9  
1044 22 100       70 if ( exists $PMC_subroutines_shims->[0] ) {
1045 3 50 33     21 if ( ( not exists $cpp_source_group->{_PMC_subroutines_shims} ) or ( not defined $cpp_source_group->{_PMC_subroutines_shims} ) ) {
    0 0        
1046 3         16 $cpp_source_group->{_PMC_subroutines_shims} = {};
1047             }
1048             elsif (( not exists $cpp_source_group->{_PMC_subroutines_shims}->{$package_name_underscores} )
1049             or ( not defined $cpp_source_group->{_PMC_subroutines_shims}->{$package_name_underscores} ) )
1050             {
1051 0         0 $cpp_source_group->{_PMC_subroutines_shims}->{$package_name_underscores} = q{};
1052             }
1053 3         12 $cpp_source_group->{_PMC_subroutines_shims}->{$package_name_underscores} .= ( join "\n", @{$PMC_subroutines_shims} ) . "\n";
  3         17  
1054             }
1055             }
1056              
1057 22         71 $cpp_source_group->{H} .= '}; // end of class' . "\n\n";
1058              
1059 22 50       95 if ( $modes->{label} eq 'ON' ) {
1060 0         0 $cpp_source_group->{H} .= '// [[[ OO SUBCLASSES ]]]' . "\n";
1061             }
1062 22         98 $cpp_source_group->{H} .= '#define ' . $package_name_underscores . '_rawptr ' . $package_name_underscores . '*' . "\n";
1063 22         90 $cpp_source_group->{H} .= 'typedef std::unique_ptr<' . $package_name_underscores . '> ' . $package_name_underscores . '_ptr;' . "\n";
1064 22         77 $cpp_source_group->{H} .= 'typedef std::vector<' . $package_name_underscores . '_ptr> ' . $package_name_underscores . '_arrayref;' . "\n";
1065 22         106 $cpp_source_group->{H} .= 'typedef std::unordered_map<string, ' . $package_name_underscores . '_ptr> ' . $package_name_underscores . '_hashref;' . "\n";
1066             $cpp_source_group->{H}
1067 22         86 .= 'typedef std::unordered_map<string, ' . $package_name_underscores . '_ptr>::iterator ' . $package_name_underscores . '_hashref_iterator;' . "\n\n";
1068              
1069 22 100       68 if ( exists $subroutine_declarations->[0] ) {
1070 3 50       9 if ( $modes->{label} eq 'ON' ) {
1071 0         0 $cpp_source_group->{H} .= '// [[[ SUBROUTINES ]]]' . "\n";
1072             }
1073 3         9 $cpp_source_group->{H} .= ( join "\n", @{$subroutine_declarations} ) . "\n\n";
  3         14  
1074 3 50       10 if ( $modes->{label} eq 'ON' ) {
1075 0         0 $cpp_source_group->{H} .= '// <<< SHIM MACROS >>>' . "\n";
1076             }
1077 3         6 $cpp_source_group->{H} .= ( join "\n", @{$CPP_subroutines_shims} ) . "\n\n";
  3         12  
1078             }
1079              
1080 22 50       73 if ( $modes->{label} eq 'ON' ) {
1081 0         0 $cpp_source_group->{H} .= '// <<< OPERATIONS & DATA TYPES REPORTER >>>' . "\n";
1082             }
1083 22         82 $cpp_source_group->{H} .= 'integer ' . $package_name_underscores . '__MODE_ID() { return 2; } // CPPOPS_CPPTYPES is 2' . "\n\n";
1084              
1085 22 50       67 if ( $modes->{label} eq 'ON' ) {
1086 0         0 $cpp_source_tmp = ( ( '// [[[<<< END CPP TYPES >>>]]]' . "\n" ) x 3 ) . "\n";
1087 0         0 $cpp_source_group->{H} .= $cpp_source_tmp;
1088 0         0 $cpp_source_group->{CPP} .= $cpp_source_tmp;
1089             }
1090              
1091 22         63 $cpp_source_tmp = <<EOL;
1092             # else
1093              
1094             Purposefully_die_from_a_compile-time_error,_due_to_neither___PERL__TYPES_nor___CPP__TYPES_being_defined.__We_need_to_define_only___CPP__TYPES_in_this_file!
1095              
1096             # endif
1097              
1098             EOL
1099              
1100 22         96 $cpp_source_group->{H} .= $cpp_source_tmp;
1101 22         58 $cpp_source_group->{CPP} .= $cpp_source_tmp;
1102              
1103             # deferred, prepend possibly-updated H_INCLUDES to H, discarding duplicates
1104 22         64 my string $H_INCLUDES_UNIQUE = '';
1105 22         131 foreach my string $H_INCLUDE ( split /\n/, $cpp_source_group->{H_INCLUDES} ) {
1106 44 50       809 if ( $H_INCLUDES_UNIQUE !~ /$H_INCLUDE/ ) {
1107 44         157 $H_INCLUDES_UNIQUE .= $H_INCLUDE . "\n";
1108             }
1109             }
1110 22         116 $cpp_source_group->{H} = $H_INCLUDES_UNIQUE . $cpp_source_group->{H};
1111 22         63 delete $cpp_source_group->{H_INCLUDES};
1112              
1113             # RPerl::diag( "\n" . 'in Class::Generator::ast_to_cpp__generate__CPPOPS_CPPTYPES(), returning $cpp_source_group = ' . "\n" . Dumper($cpp_source_group) . "\n" );
1114              
1115 22         468 return $cpp_source_group;
1116             }
1117              
1118             # generate accessors/mutators
1119             sub ast_to_cpp__generate_accessors_mutators__CPPOPS_CPPTYPES {
1120 6     6   10 { my string_hashref $RETURN_TYPE };
  6         15  
1121 6         15 ( my string $property_key, my string $namespace_from, my string_hashref $modes ) = @ARG;
1122 6         19 my string_hashref $cpp_source_group = { H => q{} };
1123              
1124             # RPerl::diag( "\n" . 'in Class::Generator::ast_to_cpp__generate_accessors_mutators__CPPOPS_CPPTYPES(), received $modes = ' . "\n" . Dumper($modes) . "\n" );
1125              
1126             # grab RPerl-style type out of symtab, instead of accepting-as-arg now-C++-style type from $property_type in caller
1127             # my string $property_type = $modes->{_symbol_table}->{ $modes->{_symbol_table}->{_namespace} }->{_properties}->{$property_key}->{type};
1128 6         23 my string $property_type = $modes->{_symbol_table}->{ $namespace_from }->{_properties}->{$property_key}->{type};
1129 6         11 my boolean $is_direct = 0;
1130 6         8 my $property_element_or_value_type;
1131              
1132             # array element accessors/mutators
1133 6 100       29 if ( $property_type =~ /_arrayref$/ ) {
    100          
1134 1         4 $property_element_or_value_type = substr $property_type, 0, ( ( length $property_type ) - 9 ); # strip trailing '_arrayref'
1135 1 50       5 if ( exists $rperlnamespaces_generated::RPERL->{ $property_element_or_value_type . '::' } ) {
1136              
1137             # arrayref of RPerl data types
1138 1 50 33     9 if ( ( $property_element_or_value_type eq 'object' ) or ( $property_element_or_value_type eq 'hashref' ) ) {
    50          
1139              
1140             # arrayref of objects or hashrefs (same as Perl object which is a blessed hashref), set address, return void
1141 0         0 $is_direct = 0;
1142             }
1143             elsif ( $property_element_or_value_type eq 'arrayref' ) {
1144              
1145             # arrayref of arrayrefs, set address, return void
1146 0         0 $is_direct = 0;
1147             }
1148             else {
1149             # arrayref of scalars, return value
1150 1         3 $is_direct = 1;
1151             }
1152             }
1153             else {
1154             # arrayref of user-defined data types (objects), set address, return void
1155 0         0 $is_direct = 0;
1156             }
1157             }
1158              
1159             # hash value accessors/mutators
1160             elsif ( $property_type =~ /_hashref$/ ) {
1161 1         4 $property_element_or_value_type = substr $property_type, 0, ( ( length $property_type ) - 8 ); # strip trailing '_hashref'
1162 1 50       8 if ( exists $rperlnamespaces_generated::RPERL->{ $property_element_or_value_type . '::' } ) {
1163              
1164             # hashref of RPerl data types
1165 1 50 33     12 if ( ( $property_element_or_value_type eq 'object' ) or ( $property_element_or_value_type eq 'hashref' ) ) {
    50          
1166              
1167             # hashref of objects or hashrefs (same as Perl object which is a blessed hashref), set address, return void
1168 0         0 $is_direct = 0;
1169             }
1170             elsif ( $property_element_or_value_type eq 'arrayref' ) {
1171              
1172             # hashref of arrayrefs, set address, return void
1173 0         0 $is_direct = 0;
1174             }
1175             else {
1176             # hashref of scalars, return value
1177 1         4 $is_direct = 1;
1178             }
1179             }
1180             else {
1181             # hashref of user-defined data types (objects), set address, return void
1182 0         0 $is_direct = 0;
1183             }
1184             }
1185              
1186             # scalar accessors/mutators, return value
1187             else {
1188 4         10 $is_direct = 1;
1189             }
1190              
1191 6 50       15 if ($is_direct) {
1192 6         25 $cpp_source_group->{H} = $property_type . ' get_' . $property_key . '() { return this->' . $property_key . '; }' . "\n";
1193             $cpp_source_group->{H}
1194 6         28 .= 'void set_' . $property_key . '(' . $property_type . q{ } . $property_key . '_new) { this->' . $property_key . ' = ' . $property_key . '_new; }';
1195             }
1196             else {
1197             # HARD-CODED EXAMPLE:
1198             #integer get_bodies_size() { return this->bodies.size(); } // call from Perl or C++
1199             #string_arrayref get_bodies_keys() { string_arrayref keys; keys.reserve(this->keys.size()); for(auto hash_entry : this->bodies) { keys.push_back(hash_entry.first); } } // call from Perl or C++
1200             #PhysicsPerl__Astro__Body_ptr& get_bodies_element(integer i) { return this->bodies[i]; } // call from C++
1201             #void get_bodies_element_indirect(integer i, PhysicsPerl__Astro__Body_rawptr bodies_element_rawptr) { *bodies_element_rawptr = *(this->bodies[i].get_raw()); } // call from Perl shim
1202             #void set_bodies_element(integer i, PhysicsPerl__Astro__Body_ptr& bodies_element_ptr) { *(this->bodies[i].get_raw()) = *(bodies_element_ptr.get_raw()); } // call from C++
1203             #void set_bodies_element(integer i, PhysicsPerl__Astro__Body_rawptr bodies_element_rawptr) { *(this->bodies[i].get_raw()) = *bodies_element_rawptr; } // call from Perl
1204             #sub get_bodies_element {
1205             # ( my PhysicsPerl::Astro::System $self, my integer $i ) = @ARG;
1206             # my PhysicsPerl::Astro::Body $bodies_element = PhysicsPerl::Astro::Body->new();
1207             # $self->get_bodies_element_indirect($i, $bodies_element);
1208             # return $bodies_element;
1209             #}
1210              
1211 0         0 my string $property_element_or_value_type_cpp_nopointerify = RPerl::Generator::type_convert_perl_to_cpp( $property_element_or_value_type, 0 ); # $pointerify_classes = 0
1212              
1213             # C++ code
1214 0 0       0 if ( $property_type =~ /_arrayref$/ ) {
    0          
1215 0         0 $cpp_source_group->{H} = 'integer get_' . $property_key . '_size() { return this->' . $property_key . '.size(); } // call from Perl or C++' . "\n";
1216             }
1217             elsif ( $property_type =~ /_hashref$/ ) {
1218             $cpp_source_group->{H}
1219 0         0 = 'string_arrayref get_'
1220             . $property_key
1221             . '_keys() { string_arrayref keys; keys.reserve(this->'
1222             . $property_key
1223             . '.size()); for(auto hash_entry : this->'
1224             . $property_key
1225             . ') { keys.push_back(hash_entry.first); } } // call from Perl or C++' . "\n";
1226             }
1227             $cpp_source_group->{H}
1228 0         0 .= $property_element_or_value_type_cpp_nopointerify
1229             . '_ptr& get_'
1230             . $property_key
1231             . '_element(integer i) { return this->'
1232             . $property_key
1233             . '[i]; } // call from C++' . "\n";
1234             $cpp_source_group->{H}
1235 0         0 .= 'void get_'
1236             . $property_key
1237             . '_element_indirect(integer i, '
1238             . $property_element_or_value_type_cpp_nopointerify
1239             . '_rawptr '
1240             . $property_key
1241             . '_element_rawptr) { *'
1242             . $property_key
1243             . '_element_rawptr = *(this->'
1244             . $property_key
1245             . '[i].get_raw()); } // call from Perl shim' . "\n";
1246             $cpp_source_group->{H}
1247 0         0 .= 'void set_'
1248             . $property_key
1249             . '_element(integer i, '
1250             . $property_element_or_value_type_cpp_nopointerify
1251             . '_ptr& '
1252             . $property_key
1253             . '_element_ptr) { *(this->'
1254             . $property_key
1255             . '[i].get_raw()) = *('
1256             . $property_key
1257             . '_element_ptr.get_raw()); } // call from C++' . "\n";
1258             $cpp_source_group->{H}
1259 0         0 .= 'void set_'
1260             . $property_key
1261             . '_element(integer i, '
1262             . $property_element_or_value_type_cpp_nopointerify
1263             . '_rawptr '
1264             . $property_key
1265             . '_element_rawptr) { *(this->'
1266             . $property_key
1267             . '[i].get_raw()) = *'
1268             . $property_key
1269             . '_element_rawptr; } // call from Perl';
1270              
1271             # RPerl::diag( "\n" . 'in Class::Generator::ast_to_cpp__generate_accessors_mutators__CPPOPS_CPPTYPES(), have $modes->{subcompile} = ' . "\n" . $modes->{subcompile} . "\n" );
1272              
1273             # DEV NOTE: only generate PMC output file in dynamic (default) subcompile mode
1274 0 0       0 if ($modes->{subcompile} eq 'DYNAMIC') {
1275             # RPerl::diag( 'in Class::Generator::ast_to_cpp__generate_accessors_mutators__CPPOPS_CPPTYPES(), YES PMC SHIMS' . "\n" );
1276             # Perl shim code
1277             # DEV NOTE: must create return variable object in Perl so it will be memory-managed by Perl,
1278             # and not wrongly destructed or double-destructed by Perl garbage collector and/or C++ memory.h,
1279             # even though Perl object contents will be replaced by C++ memory address, TRICKY!
1280             # HARD-CODED EXAMPLE:
1281             # undef &PhysicsPerl::Astro::System::get_bodies_element;
1282             # *PhysicsPerl::Astro::System::get_bodies_element = sub { ... };
1283              
1284             # $cpp_source_group->{PMC} = 'sub get_' . $property_key . '_element {' . "\n"; # DEV NOTE: use alternate syntax to avoid "subroutine redefined" errors
1285 0         0 $cpp_source_group->{PMC} = 'undef &' . $modes->{_symbol_table}->{_namespace} . 'get_' . $property_key . '_element;' . "\n";
1286 0         0 $cpp_source_group->{PMC} .= '*' . $modes->{_symbol_table}->{_namespace} . 'get_' . $property_key . '_element = sub {' . "\n";
1287             $cpp_source_group->{PMC}
1288             .= '( my '
1289 0         0 . ( substr $modes->{_symbol_table}->{_namespace}, 0, ( ( length $modes->{_symbol_table}->{_namespace} ) - 2 ) )
1290             . ' $self, my integer $i ) = @ARG;' . "\n";
1291             $cpp_source_group->{PMC}
1292 0         0 .= 'my ' . $property_element_or_value_type . ' $' . $property_key . '_element = ' . $property_element_or_value_type . '->new();' . "\n";
1293 0         0 $cpp_source_group->{PMC} .= '$self->get_' . $property_key . '_element_indirect($i, $' . $property_key . '_element);' . "\n";
1294 0         0 $cpp_source_group->{PMC} .= 'return $' . $property_key . '_element;' . "\n";
1295             # $cpp_source_group->{PMC} .= '}'; # DEV NOTE: use alternate syntax to avoid "subroutine redefined" errors
1296 0         0 $cpp_source_group->{PMC} .= '};';
1297             }
1298             # else { RPerl::diag( 'in Class::Generator::ast_to_cpp__generate_accessors_mutators__CPPOPS_CPPTYPES(), NO PMC SHIMS' . "\n" ); }
1299              
1300             # RPerl::diag( 'in Class::Generator::ast_to_cpp__generate_accessors_mutators__CPPOPS_CPPTYPES(), have $cpp_source_group->{H} = ' . "\n" . $cpp_source_group->{H} . "\n" );
1301             }
1302 6         16 return $cpp_source_group;
1303             }
1304              
1305             1; # end of class
1306