line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# [[[ HEADER ]]] |
2
|
|
|
|
|
|
|
package RPerl::CompileUnit::Module::Class; |
3
|
7
|
|
|
7
|
|
133
|
use strict; |
|
7
|
|
|
|
|
20
|
|
|
7
|
|
|
|
|
181
|
|
4
|
7
|
|
|
7
|
|
33
|
use warnings; |
|
7
|
|
|
|
|
13
|
|
|
7
|
|
|
|
|
146
|
|
5
|
7
|
|
|
7
|
|
2329
|
use RPerl::Config; # get @ARG, Dumper, Carp, English without 'use RPerl;' |
|
7
|
|
|
|
|
27
|
|
|
7
|
|
|
|
|
1516
|
|
6
|
|
|
|
|
|
|
our $VERSION = 0.044_000; |
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
# [[[ OO INHERITANCE ]]] |
9
|
|
|
|
|
|
|
# BASE CLASS HAS NO INHERITANCE |
10
|
|
|
|
|
|
|
# "The Buck Stops Here" |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
# [[[ CRITICS ]]] |
13
|
|
|
|
|
|
|
## no critic qw(ProhibitStringyEval) # SYSTEM DEFAULT 1: allow eval() |
14
|
|
|
|
|
|
|
## no critic qw(ProhibitAutoloading RequireArgUnpacking) # SYSTEM SPECIAL 2: allow Autoload & read-only @ARG |
15
|
|
|
|
|
|
|
## no critic qw(ProhibitExcessComplexity) # SYSTEM SPECIAL 5: allow complex code inside subroutines, must be after line 1 |
16
|
|
|
|
|
|
|
## no critic qw(ProhibitDeepNests) # SYSTEM SPECIAL 7: allow deeply-nested code |
17
|
|
|
|
|
|
|
## no critic qw(ProhibitNoStrict) # SYSTEM SPECIAL 8: allow no strict |
18
|
|
|
|
|
|
|
## no critic qw(RequireBriefOpen) # SYSTEM SPECIAL 10: allow complex processing with open filehandle |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
# [[[ INCLUDES ]]] |
21
|
7
|
|
|
7
|
|
63
|
use File::Basename; |
|
7
|
|
|
|
|
16
|
|
|
7
|
|
|
|
|
594
|
|
22
|
7
|
|
|
7
|
|
47
|
use File::Spec; # for splitpath() to test if @INC file entries are absolute or relative |
|
7
|
|
|
|
|
14
|
|
|
7
|
|
|
|
|
197
|
|
23
|
7
|
|
|
7
|
|
41
|
use Scalar::Util 'reftype'; # to test for HASH ref when given initialization values for new() method |
|
7
|
|
|
|
|
14
|
|
|
7
|
|
|
|
|
604
|
|
24
|
7
|
|
|
7
|
|
3430
|
use rperltypes; # required for all automatically-generated type-checking subroutine calls |
|
7
|
|
|
|
|
27
|
|
|
7
|
|
|
|
|
48
|
|
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
# [[[ OO PROPERTIES ]]] |
27
|
|
|
|
|
|
|
# BASE CLASS HAS NO PROPERTIES |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
# [[[ SUBROUTINES & OO METHODS ]]] |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
# RPerl object constructor, SHORT FORM |
32
|
|
|
|
|
|
|
sub new { |
33
|
7
|
|
|
7
|
|
90
|
no strict; |
|
7
|
|
|
|
|
29
|
|
|
7
|
|
|
|
|
2273
|
|
34
|
607
|
50
|
|
607
|
0
|
4103
|
if ( not defined ${ $_[0] . '::properties' } ) { |
|
607
|
|
|
|
|
4255
|
|
35
|
0
|
|
|
|
|
0
|
croak 'ERROR ECOOOCO00, SOURCE CODE, OO OBJECT CONSTRUCTOR: Undefined hashref $properties for class ' . $_[0] . ', croaking' . "\n"; |
36
|
|
|
|
|
|
|
} |
37
|
|
|
|
|
|
|
# return bless { %{ ${ $_[0] . '::properties' } } }, $_[0]; # DOES NOT INHERIT PROPERTIES FROM PARENT CLASSES |
38
|
|
|
|
|
|
|
# return bless { %{ ${ $_[0] . '::properties' } }, %{ properties_inherited($_[0]) } }, $_[0]; # WHAT DOES THIS DO??? |
39
|
|
|
|
|
|
|
# return bless { %{ properties_inherited($_[0]) } }, $_[0]; # WORKS PROPERLY, BUT DOES NOT INITIALIZE PROPERTIES |
40
|
607
|
|
|
|
|
1154
|
return bless { %{ properties_inherited_initialized($_[0], $_[1]) } }, $_[0]; |
|
607
|
|
|
|
|
3362
|
|
41
|
|
|
|
|
|
|
} |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
# allow properties to be initialized by passing them as hashref arg to new() method |
45
|
|
|
|
|
|
|
sub properties_inherited_initialized { |
46
|
|
|
|
|
|
|
# print {*STDERR} 'in Class::properties_inherited_initialized(), top of subroutine, received $ARG[0] = ', $ARG[0], "\n"; |
47
|
|
|
|
|
|
|
# print {*STDERR} 'in Class::properties_inherited_initialized(), top of subroutine, received $ARG[1] = ', $ARG[1], "\n"; |
48
|
|
|
|
|
|
|
|
49
|
607
|
|
|
607
|
0
|
2537
|
my $properties_inherited = properties_inherited($_[0]); |
50
|
|
|
|
|
|
|
|
51
|
607
|
50
|
|
|
|
2446
|
if (defined $_[1]) { |
52
|
0
|
0
|
0
|
|
|
0
|
if ((not defined reftype($_[1])) or (reftype($_[1]) ne 'HASH')) { |
53
|
0
|
|
|
|
|
0
|
croak 'ERROR ECOOOCO01, SOURCE CODE, OO OBJECT CONSTRUCTOR: Initialization values for new() method must be key-value pairs inside a hash reference, croaking'; |
54
|
|
|
|
|
|
|
} |
55
|
0
|
|
|
|
|
0
|
foreach my $property_name (sort keys %{$_[1]}) { |
|
0
|
|
|
|
|
0
|
|
56
|
0
|
0
|
|
|
|
0
|
if (not exists $properties_inherited->{$property_name}) { |
57
|
0
|
|
|
|
|
0
|
croak 'ERROR ECOOOCO02, SOURCE CODE, OO OBJECT CONSTRUCTOR: Attempted initialization of invalid property ' . q{'} . $property_name . q{'} . ', croaking'; |
58
|
|
|
|
|
|
|
} |
59
|
0
|
|
|
|
|
0
|
$properties_inherited->{$property_name} = $_[1]->{$property_name}; |
60
|
|
|
|
|
|
|
} |
61
|
|
|
|
|
|
|
} |
62
|
|
|
|
|
|
|
|
63
|
607
|
|
|
|
|
3945
|
return $properties_inherited; |
64
|
|
|
|
|
|
|
} |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
# inherit properties from parent and grandparnt classes |
68
|
|
|
|
|
|
|
sub properties_inherited { |
69
|
|
|
|
|
|
|
# print {*STDERR} 'in Class::properties_inherited(), top of subroutine, received $ARG[0] = ', $ARG[0], "\n"; |
70
|
7
|
|
|
7
|
|
53
|
no strict; |
|
7
|
|
|
|
|
27
|
|
|
7
|
|
|
|
|
1220
|
|
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
# always keep self class' $properties |
73
|
3622
|
|
|
3622
|
0
|
4888
|
my $properties = { %{ ${ $ARG[0] . '::properties' } } }; |
|
3622
|
|
|
|
|
4435
|
|
|
3622
|
|
|
|
|
18253
|
|
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
# inherit parent & (great*)grandparent class' $properties |
76
|
3622
|
|
|
|
|
5622
|
foreach my $parent_package_name (@{ $ARG[0] . '::ISA' }) { |
|
3622
|
|
|
|
|
13413
|
|
77
|
|
|
|
|
|
|
# print {*STDERR} 'in Class::properties_inherited(), top of foreach() loop, have $parent_package_name = ', $parent_package_name, "\n"; |
78
|
|
|
|
|
|
|
# RPerl base class & Eyapp classes have no $properties, skip |
79
|
3622
|
100
|
66
|
|
|
11477
|
if (($parent_package_name eq 'RPerl::CompileUnit::Module::Class') or |
80
|
|
|
|
|
|
|
($parent_package_name eq 'Parse::Eyapp::Node')) { |
81
|
607
|
|
|
|
|
1540
|
next; |
82
|
|
|
|
|
|
|
} |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
# recurse to get inherited $properties |
85
|
3015
|
|
|
|
|
6219
|
my $parent_and_grandparent_properties = properties_inherited($parent_package_name); |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
# self class' $properties override inherited $properties, same as C++ |
88
|
3015
|
|
|
|
|
3775
|
foreach my $parent_property_key (keys %{ $parent_and_grandparent_properties }) { |
|
3015
|
|
|
|
|
6913
|
|
89
|
7236
|
50
|
|
|
|
11623
|
if (not exists $properties->{$parent_property_key}) { |
90
|
7236
|
|
|
|
|
12186
|
$properties->{$parent_property_key} = $parent_and_grandparent_properties->{$parent_property_key}; |
91
|
|
|
|
|
|
|
} |
92
|
|
|
|
|
|
|
} |
93
|
|
|
|
|
|
|
} |
94
|
3622
|
|
|
|
|
5766
|
return $properties; |
95
|
|
|
|
|
|
|
} |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
sub parent_and_grandparent_package_names { |
99
|
|
|
|
|
|
|
# print {*STDERR} 'in Class::parent_and_grandparent_package_names(), top of subroutine, received $ARG[0] = ', $ARG[0], "\n"; |
100
|
7
|
|
|
7
|
|
53
|
no strict; |
|
7
|
|
|
|
|
16
|
|
|
7
|
|
|
|
|
2011
|
|
101
|
|
|
|
|
|
|
|
102
|
129
|
|
|
129
|
0
|
775
|
RPerl::eval_use($ARG[0]); |
103
|
|
|
|
|
|
|
|
104
|
129
|
|
|
|
|
532
|
my $arg0_isa_string = $ARG[0] . '::ISA'; |
105
|
|
|
|
|
|
|
# print {*STDERR} 'in Class::parent_and_grandparent_package_names(), have $arg0_isa_string = ', $arg0_isa_string, "\n"; |
106
|
|
|
|
|
|
|
|
107
|
129
|
|
|
|
|
238
|
my @arg0_isa = @{$arg0_isa_string}; |
|
129
|
|
|
|
|
877
|
|
108
|
|
|
|
|
|
|
# print {*STDERR} 'in Class::parent_and_grandparent_package_names(), have @arg0_isa = ', Dumper(\@arg0_isa), "\n"; |
109
|
|
|
|
|
|
|
|
110
|
129
|
|
|
|
|
325
|
my $package_names = []; |
111
|
|
|
|
|
|
|
|
112
|
129
|
|
|
|
|
235
|
foreach my $parent_package_name (@{ $ARG[0] . '::ISA' }) { |
|
129
|
|
|
|
|
618
|
|
113
|
|
|
|
|
|
|
# print {*STDERR} 'in Class::parent_and_grandparent_package_names(), top of foreach() loop, have $parent_package_name = ', $parent_package_name, "\n"; |
114
|
|
|
|
|
|
|
# RPerl base class & Eyapp classes have no $properties, skip |
115
|
129
|
100
|
66
|
|
|
655
|
if (($parent_package_name eq 'RPerl::CompileUnit::Module::Class') or |
116
|
|
|
|
|
|
|
($parent_package_name eq 'Parse::Eyapp::Node')) { |
117
|
98
|
|
|
|
|
252
|
next; |
118
|
|
|
|
|
|
|
} |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
# get parent's package name |
121
|
31
|
|
|
|
|
92
|
push @{$package_names}, $parent_package_name; |
|
31
|
|
|
|
|
143
|
|
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
# recurse to get (great*)grandparents' package names |
124
|
31
|
|
|
|
|
209
|
my $grandparent_package_names = parent_and_grandparent_package_names($parent_package_name); |
125
|
31
|
|
|
|
|
79
|
$package_names = [@{$package_names}, @{$grandparent_package_names}]; |
|
31
|
|
|
|
|
71
|
|
|
31
|
|
|
|
|
122
|
|
126
|
|
|
|
|
|
|
# print {*STDERR} 'in Class::parent_and_grandparent_package_names(), inside foreach() loop, have $grandparent_package_names = ', Dumper($grandparent_package_names), "\n"; |
127
|
|
|
|
|
|
|
} |
128
|
|
|
|
|
|
|
# print {*STDERR} 'in Class::parent_and_grandparent_package_names(), bottom of subroutine, returning $package_names = ', Dumper($package_names), "\n"; |
129
|
129
|
|
|
|
|
460
|
return $package_names; |
130
|
|
|
|
|
|
|
} |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
# RPerl object destructor |
134
|
|
|
|
|
|
|
# NEED ADDRESS: do we ever need to actually deconstruct anything to free resources? |
135
|
|
|
|
0
|
|
|
sub DESTROY { } |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
# [[[ SUBROUTINES ]]] |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
# suppress deprecated feature warning |
141
|
|
|
|
|
|
|
local $SIG{__WARN__} = sub { |
142
|
|
|
|
|
|
|
return if $_[0] =~ /^Use of inherited AUTOLOAD for non-method /xms; |
143
|
|
|
|
|
|
|
carp @ARG; |
144
|
|
|
|
|
|
|
}; |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
|
147
|
0
|
|
|
|
|
0
|
BEGIN { |
148
|
|
|
|
|
|
|
#RPerl::diag('in Class.pm BEGIN block, about to use data types...' . "\n"); |
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
# DEV NOTE, CORRELATION #rp012: type system includes, hard-copies in rperltypes.pm & rperltypesconv.pm & Class.pm |
151
|
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
# [[[ DATA TYPES ]]] |
153
|
7
|
|
|
7
|
|
55
|
use RPerl::DataType::Void; |
|
7
|
|
|
|
|
17
|
|
|
7
|
|
|
|
|
305
|
|
154
|
7
|
|
|
7
|
|
42
|
use RPerl::DataType::Boolean; |
|
7
|
|
|
|
|
18
|
|
|
7
|
|
|
|
|
41
|
|
155
|
7
|
|
|
7
|
|
51
|
use RPerl::DataType::UnsignedInteger; |
|
7
|
|
|
|
|
23
|
|
|
7
|
|
|
|
|
37
|
|
156
|
7
|
|
|
7
|
|
51
|
use RPerl::DataType::Integer; |
|
7
|
|
|
|
|
15
|
|
|
7
|
|
|
|
|
27
|
|
157
|
7
|
|
|
7
|
|
49
|
use RPerl::DataType::Number; |
|
7
|
|
|
|
|
28
|
|
|
7
|
|
|
|
|
32
|
|
158
|
7
|
|
|
7
|
|
49
|
use RPerl::DataType::Character; |
|
7
|
|
|
|
|
15
|
|
|
7
|
|
|
|
|
30
|
|
159
|
7
|
|
|
7
|
|
52
|
use RPerl::DataType::String; |
|
7
|
|
|
|
|
17
|
|
|
7
|
|
|
|
|
29
|
|
160
|
7
|
|
|
7
|
|
45
|
use RPerl::DataType::Scalar; |
|
7
|
|
|
|
|
20
|
|
|
7
|
|
|
|
|
270
|
|
161
|
7
|
|
|
7
|
|
38
|
use RPerl::DataType::Unknown; |
|
7
|
|
|
|
|
14
|
|
|
7
|
|
|
|
|
187
|
|
162
|
7
|
|
|
7
|
|
42
|
use RPerl::DataType::FileHandle; |
|
7
|
|
|
|
|
17
|
|
|
7
|
|
|
|
|
239
|
|
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
#RPerl::diag('in Class.pm BEGIN block, about to use data structures...' . "\n"); |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
# [[[ DATA STRUCTURES ]]] |
167
|
7
|
|
|
7
|
|
36
|
use RPerl::DataStructure::Array; |
|
7
|
|
|
|
|
15
|
|
|
7
|
|
|
|
|
26
|
|
168
|
7
|
|
|
7
|
|
80
|
use RPerl::DataStructure::Array::SubTypes; |
|
7
|
|
|
|
|
16
|
|
|
7
|
|
|
|
|
65
|
|
169
|
7
|
|
|
7
|
|
52
|
use RPerl::DataStructure::Array::Reference; |
|
7
|
|
|
|
|
19
|
|
|
7
|
|
|
|
|
315
|
|
170
|
7
|
|
|
7
|
|
36
|
use RPerl::DataStructure::Hash; |
|
7
|
|
|
|
|
20
|
|
|
7
|
|
|
|
|
33
|
|
171
|
7
|
|
|
7
|
|
56
|
use RPerl::DataStructure::Hash::SubTypes; |
|
7
|
|
|
|
|
20
|
|
|
7
|
|
|
|
|
54
|
|
172
|
7
|
|
|
7
|
|
50
|
use RPerl::DataStructure::Hash::Reference; |
|
7
|
|
|
0
|
|
17
|
|
|
7
|
|
|
|
|
19341
|
|
173
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
#RPerl::diag('in Class.pm BEGIN block, done' . "\n"); |
175
|
|
|
|
|
|
|
} |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
# after compiling but before runtime: create symtab entries for all RPerl functions/methods, and accessors/mutators for all RPerl class properties |
179
|
|
|
|
|
|
|
INIT { |
180
|
7
|
|
|
7
|
|
46
|
create_symtab_entries_and_accessors_mutators(\%INC); |
181
|
|
|
|
|
|
|
}; |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
sub create_symtab_entries_and_accessors_mutators { |
185
|
132
|
|
|
132
|
0
|
548
|
(my $INC_ref) = @ARG; |
186
|
|
|
|
|
|
|
# $RPerl::DEBUG = 1; |
187
|
|
|
|
|
|
|
# $RPerl::VERBOSE = 1; |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
# add calling .pl driver to INC for subroutine activation; |
190
|
|
|
|
|
|
|
# DEV NOTE: should be safe to use basename() here instead of fileparse(), because $PROGRAM_NAME should never end in a directory |
191
|
132
|
|
|
|
|
7568
|
$INC{ basename($PROGRAM_NAME) } = $PROGRAM_NAME; |
192
|
|
|
|
|
|
|
|
193
|
|
|
|
|
|
|
# RPerl::diag('in Class.pm INIT block, have $INC_ref =' . "\n" . Dumper($INC_ref) . "\n"); |
194
|
|
|
|
|
|
|
# RPerl::diag('in Class.pm INIT block, have $rperlnamespaces_generated::CORE =' . "\n" . Dumper($rperlnamespaces_generated::CORE) . "\n"); |
195
|
|
|
|
|
|
|
|
196
|
132
|
|
|
|
|
2989
|
my $module_filename_long; # string |
197
|
|
|
|
|
|
|
my $use_rperl; # boolean |
198
|
132
|
|
|
|
|
0
|
my $inside_package; # boolean |
199
|
132
|
|
|
|
|
0
|
my $package_name; # string |
200
|
132
|
|
|
|
|
0
|
my $package_name_underscores; # string |
201
|
132
|
|
|
|
|
0
|
my $namespace_root; # string |
202
|
132
|
|
|
|
|
0
|
my $object_properties; # hashref |
203
|
132
|
|
|
|
|
0
|
my $object_properties_string; # string |
204
|
132
|
|
|
|
|
0
|
my $object_properties_types; # hashref |
205
|
132
|
|
|
|
|
0
|
my $inside_object_properties; # boolean |
206
|
132
|
|
|
|
|
0
|
my $subroutine_type; # string |
207
|
132
|
|
|
|
|
0
|
my $subroutine_name; # string |
208
|
132
|
|
|
|
|
0
|
my $CHECK; # string |
209
|
132
|
|
|
|
|
0
|
my $inside_subroutine; # boolean |
210
|
132
|
|
|
|
|
0
|
my $inside_subroutine_header; # boolean |
211
|
132
|
|
|
|
|
0
|
my $inside_subroutine_arguments; # boolean |
212
|
132
|
|
|
|
|
0
|
my $subroutine_arguments_line; # string |
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
# RPerl::diag(q{in Class.pm INIT block, have $PROGRAM_NAME = '} . $PROGRAM_NAME . "'\n"); |
215
|
|
|
|
|
|
|
|
216
|
132
|
|
|
|
|
382
|
foreach my $module_filename_short ( sort keys %{$INC_ref} ) { |
|
132
|
|
|
|
|
4652
|
|
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
# RPerl::diag("in Class.pm INIT block, have \$module_filename_short = '$module_filename_short'\n"); |
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
# skip special entry created by Filter::Util::Call |
221
|
3118
|
50
|
|
|
|
6207
|
if ( $module_filename_short eq '-e' ) { |
222
|
0
|
|
|
|
|
0
|
next; |
223
|
|
|
|
|
|
|
} |
224
|
|
|
|
|
|
|
|
225
|
3118
|
|
|
|
|
8643
|
$module_filename_long = $INC{$module_filename_short}; |
226
|
|
|
|
|
|
|
# RPerl::diag( 'in Class.pm INIT block, have $module_filename_long = ' . $module_filename_long . "\n" ); |
227
|
|
|
|
|
|
|
|
228
|
|
|
|
|
|
|
# determine if both short & long module filenames are absolute; |
229
|
|
|
|
|
|
|
# file names w/out any volume or directories are not absolute, allows 'use Foo;' where "Foo.pm" exists in current directory w/out any volume or directory |
230
|
3118
|
|
|
|
|
4108
|
my $module_is_absolute = 0; |
231
|
3118
|
50
|
|
|
|
5298
|
if (defined $module_filename_long) { |
232
|
3118
|
|
|
|
|
26595
|
(my $module_volume, my $module_directories, my $module_file) = File::Spec->splitpath( $module_filename_long ); |
233
|
|
|
|
|
|
|
# RPerl::diag( 'in Class.pm INIT block, have $module_volume = ' . q{'} . $module_volume . q{'} . "\n" ); |
234
|
|
|
|
|
|
|
# RPerl::diag( 'in Class.pm INIT block, have $module_directories = ' . q{'} . $module_directories . q{'} . "\n" ); |
235
|
|
|
|
|
|
|
# RPerl::diag( 'in Class.pm INIT block, have $module_file = ' . q{'} . $module_file . q{'} . "\n" ); |
236
|
|
|
|
|
|
|
# if (($module_volume ne q{}) or ($module_directories ne q{})) { # DEV NOTE: this isn't right, if the volume is empty then it can't be absolute regardless of directories |
237
|
3118
|
50
|
|
|
|
8055
|
if ($module_volume ne q{}) { |
238
|
0
|
0
|
|
|
|
0
|
if ( $module_filename_long eq $module_filename_short ) { |
239
|
|
|
|
|
|
|
# absolute module names include volume, and must match both short & long filenames |
240
|
0
|
|
|
|
|
0
|
$module_is_absolute = 1; |
241
|
|
|
|
|
|
|
} |
242
|
|
|
|
|
|
|
} |
243
|
|
|
|
|
|
|
} |
244
|
|
|
|
|
|
|
|
245
|
|
|
|
|
|
|
# RPerl::diag( 'in Class.pm INIT block, have $module_is_absolute = ' . $module_is_absolute . "\n" ); |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
# skip absolute file names (such as Komodo's perl5db.pl) which came from a runtime `require $scalar` or `require 'foo.pm'`, |
248
|
|
|
|
|
|
|
# because we can not determine the correct package from the absolute path name, and we don't know how to figure out which part was in @INC from the absolute path; |
249
|
3118
|
50
|
33
|
|
|
9423
|
if ((not defined $module_filename_long) or $module_is_absolute) { |
250
|
|
|
|
|
|
|
# RPerl::diag( 'in Class.pm INIT block, skipping due to undefined or absolute module filename' . "\n" ); |
251
|
0
|
|
|
|
|
0
|
next; |
252
|
|
|
|
|
|
|
} |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
# skip already-compiled files with PMC counterparts |
255
|
3118
|
50
|
|
|
|
27376
|
if (-e ($module_filename_long . 'c')) { |
256
|
|
|
|
|
|
|
# RPerl::diag( 'in Class.pm INIT block, skipping due to already-compiled PMC file' . "\n" ); |
257
|
0
|
|
|
|
|
0
|
next; |
258
|
|
|
|
|
|
|
} |
259
|
|
|
|
|
|
|
|
260
|
3118
|
|
|
|
|
4702
|
$use_rperl = 0; |
261
|
3118
|
|
|
|
|
3862
|
$inside_package = 0; |
262
|
3118
|
|
|
|
|
4116
|
$package_name = q{}; |
263
|
3118
|
|
|
|
|
4358
|
$CHECK = $RPerl::CHECK; # reset data type checking to RPerl default for every file |
264
|
3118
|
|
|
|
|
4039
|
$object_properties_string = q{}; |
265
|
3118
|
|
|
|
|
5765
|
$object_properties_types = {}; |
266
|
3118
|
|
|
|
|
4198
|
$inside_object_properties = 0; |
267
|
3118
|
|
|
|
|
3929
|
$inside_subroutine = 0; |
268
|
3118
|
|
|
|
|
3659
|
$inside_subroutine_header = 0; |
269
|
3118
|
|
|
|
|
3646
|
$inside_subroutine_arguments = 0; |
270
|
3118
|
|
|
|
|
3780
|
$subroutine_arguments_line = q{}; |
271
|
|
|
|
|
|
|
|
272
|
3118
|
|
|
|
|
7262
|
$namespace_root = RPerl::filename_short_to_namespace_root_guess($module_filename_short); |
273
|
|
|
|
|
|
|
|
274
|
|
|
|
|
|
|
# RPerl::diag(q{in Class.pm INIT block, have $namespace_root = '} . $namespace_root . "'\n"); |
275
|
|
|
|
|
|
|
|
276
|
|
|
|
|
|
|
# DEV NOTE: avoid error... |
277
|
|
|
|
|
|
|
# Name "rperlnamespaces_generated::RPERL_DEPS" used only once: possible typo |
278
|
3118
|
|
|
|
|
4582
|
my $tmp = $rperlnamespaces_generated::CORE; |
279
|
3118
|
|
|
|
|
4136
|
$tmp = $rperlnamespaces_generated::RPERL_DEPS; |
280
|
|
|
|
|
|
|
|
281
|
3118
|
100
|
100
|
|
|
13876
|
if ( ( not exists $rperlnamespaces_generated::CORE->{$namespace_root} ) and |
|
|
|
100
|
|
|
|
|
282
|
|
|
|
|
|
|
( not exists $rperlnamespaces_generated::RPERL_DEPS->{$namespace_root} ) and |
283
|
|
|
|
|
|
|
( not exists $rperlnamespaces_generated::RPERL_FILES->{$module_filename_short}) ) |
284
|
|
|
|
|
|
|
{ |
285
|
|
|
|
|
|
|
# RPerl::diag( 'in Class.pm INIT block, not skipping due to CORE & RPERL_DEPS namespaces, $module_filename_long = ' . $module_filename_long . "\n" ); |
286
|
|
|
|
|
|
|
|
287
|
711
|
50
|
|
|
|
23463
|
open my $MODULE_FILE, '<', $module_filename_long or croak $OS_ERROR; |
288
|
|
|
|
|
|
|
MODULE_FILE_LINE_LOOP: |
289
|
711
|
|
|
|
|
9473
|
while ( my $module_file_line = <$MODULE_FILE> ) { |
290
|
127833
|
|
|
|
|
155617
|
MODULE_FILE_LINE_LOOP_INNER: |
291
|
|
|
|
|
|
|
chomp $module_file_line; |
292
|
|
|
|
|
|
|
|
293
|
|
|
|
|
|
|
# RPerl::diag('in Class.pm INIT block, have $module_file_line =' . "\n" . $module_file_line . "\n"); |
294
|
|
|
|
|
|
|
|
295
|
|
|
|
|
|
|
# set data type checking mode |
296
|
127833
|
100
|
|
|
|
192531
|
if ( $module_file_line =~ /^\s*\#\s*\<\<\<\s*TYPE_CHECKING\s*\:\s*(\w+)\s*\>\>\>/xms ) { |
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
# RPerl::diag( "in Class.pm INIT block, have \$module_filename_long = '$module_filename_long'\n" ); |
299
|
3
|
50
|
|
|
|
14
|
if ($inside_subroutine) { |
300
|
|
|
|
|
|
|
|
301
|
|
|
|
|
|
|
# RPerl::diag( 'in Class.pm INIT block, found <<< TYPE_CHECKING: ' . $1 . ' >>> while inside subroutine ' . $subroutine_name . '(), aborting RPerl activation of entire file' . "\n" ); |
302
|
0
|
|
|
|
|
0
|
last; |
303
|
|
|
|
|
|
|
} |
304
|
|
|
|
|
|
|
else { |
305
|
|
|
|
|
|
|
# RPerl::diag( 'in Class.pm INIT block, found <<< TYPE_CHECKING: ' . $1 . " >>>\n" ); |
306
|
3
|
|
|
|
|
7
|
$CHECK = $1; |
307
|
|
|
|
|
|
|
} |
308
|
|
|
|
|
|
|
} |
309
|
|
|
|
|
|
|
|
310
|
|
|
|
|
|
|
# skip single-line comments |
311
|
127833
|
100
|
|
|
|
233186
|
next if ( $module_file_line =~ /^\s*\#/xms ); |
312
|
|
|
|
|
|
|
|
313
|
|
|
|
|
|
|
# skip multi-line POD comments |
314
|
110595
|
100
|
|
|
|
162802
|
if ( $module_file_line =~ /^\=(\w+)/xms ) { |
315
|
|
|
|
|
|
|
|
316
|
|
|
|
|
|
|
# RPerl::diag("in Class.pm INIT block, skipping multi-line POD comment, have \$1 = '$1'\n"); |
317
|
78
|
|
|
|
|
273
|
$module_file_line = <$MODULE_FILE>; |
318
|
78
|
50
|
|
|
|
198
|
if ( not defined $module_file_line ) { |
319
|
0
|
|
|
|
|
0
|
croak "End of file '$module_filename_long' reached without finding '=cut' end of multi-line POD comment '=$1', croaking"; |
320
|
|
|
|
|
|
|
} |
321
|
78
|
|
|
|
|
193
|
while ( $module_file_line !~ /^\=cut/xms ) { |
322
|
16290
|
50
|
|
|
|
22026
|
if ( not defined $module_file_line ) { |
323
|
0
|
|
|
|
|
0
|
croak "End of file '$module_filename_long' reached without finding '=cut' end of multi-line POD comment '=$1', croaking"; |
324
|
|
|
|
|
|
|
} |
325
|
16290
|
|
|
|
|
26543
|
$module_file_line = <$MODULE_FILE>; |
326
|
|
|
|
|
|
|
} |
327
|
78
|
|
|
|
|
248
|
next; |
328
|
|
|
|
|
|
|
} |
329
|
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
# skip multi-line heredocs |
331
|
110517
|
100
|
66
|
|
|
361640
|
if ( ( $module_file_line =~ /\=\s*\<\<\s*(\w+)\s*\;\s*$/xms ) |
|
|
|
100
|
|
|
|
|
332
|
|
|
|
|
|
|
or ( $module_file_line =~ /\=\s*\<\<\s*\'(\w+)\'\s*\;\s*$/xms ) |
333
|
|
|
|
|
|
|
or ( $module_file_line =~ /\=\s*\<\<\s*\"(\w+)\"\s*\;\s*$/xms ) ) |
334
|
|
|
|
|
|
|
{ |
335
|
|
|
|
|
|
|
# RPerl::diag("in Class.pm INIT block, skipping multi-line heredoc, have \$1 = '$1'\n"); |
336
|
24
|
|
|
|
|
101
|
$module_file_line = <$MODULE_FILE>; |
337
|
24
|
50
|
|
|
|
79
|
if ( not defined $module_file_line ) { |
338
|
0
|
|
|
|
|
0
|
croak "End of file '$module_filename_long' reached without finding '$1' end of multi-line heredoc string, croaking"; |
339
|
|
|
|
|
|
|
} |
340
|
24
|
|
|
|
|
323
|
while ( $module_file_line !~ /^$1/xms ) { |
341
|
96
|
|
|
|
|
176
|
$module_file_line = <$MODULE_FILE>; |
342
|
96
|
50
|
|
|
|
350
|
if ( not defined $module_file_line ) { |
343
|
0
|
|
|
|
|
0
|
croak "End of file '$module_filename_long' reached without finding '$1' end of multi-line heredoc string, croaking"; |
344
|
|
|
|
|
|
|
} |
345
|
|
|
|
|
|
|
} |
346
|
24
|
|
|
|
|
84
|
next; |
347
|
|
|
|
|
|
|
} |
348
|
|
|
|
|
|
|
|
349
|
|
|
|
|
|
|
# skip __DATA__ footer |
350
|
110493
|
50
|
|
|
|
164562
|
if ( $module_file_line eq '__DATA__' ) { |
351
|
|
|
|
|
|
|
# if ($inside_subroutine) { RPerl::diag( 'in Class.pm INIT block, skipping __DATA__ footer while inside subroutine ' . $subroutine_name . '(), aborting RPerl activation of entire file' . "\n" ); } |
352
|
|
|
|
|
|
|
# else { RPerl::diag('in Class.pm INIT block, skipping __DATA__ footer' . "\n"); } |
353
|
0
|
|
|
|
|
0
|
last; |
354
|
|
|
|
|
|
|
} |
355
|
|
|
|
|
|
|
|
356
|
|
|
|
|
|
|
# skip __END__ footer |
357
|
110493
|
100
|
|
|
|
151464
|
if ( $module_file_line eq '__END__' ) { |
358
|
|
|
|
|
|
|
# if ($inside_subroutine) { RPerl::diag( 'in Class.pm INIT block, skipping __END__ footer while inside subroutine ' . $subroutine_name . '(), aborting RPerl activation of entire file' . "\n" ); } |
359
|
|
|
|
|
|
|
# else { RPerl::diag('in Class.pm INIT block, skipping __END__ footer' . "\n"); } |
360
|
21
|
|
|
|
|
57
|
last; |
361
|
|
|
|
|
|
|
} |
362
|
|
|
|
|
|
|
|
363
|
|
|
|
|
|
|
# if ($module_file_line =~ m/sub\s*/xms) { |
364
|
|
|
|
|
|
|
# RPerl::diag("in Class.pm INIT block, have \$module_file_line =\n$module_file_line\n"); |
365
|
|
|
|
|
|
|
# } |
366
|
|
|
|
|
|
|
|
367
|
|
|
|
|
|
|
# create ops/types reporting subroutine & accessor/mutator object methods for each RPerl package |
368
|
|
|
|
|
|
|
|
369
|
|
|
|
|
|
|
# user-style RPerl header, anything that starts with 'use RPerl;' |
370
|
110472
|
100
|
|
|
|
170612
|
if ( $module_file_line =~ /^\s*(use\s+RPerl\s*;)/xms ) { |
371
|
|
|
|
|
|
|
# RPerl::diag(q{in Class.pm INIT block, found '} . $1 . q{' in $module_filename_short = } . $module_filename_short . "\n"); |
372
|
53
|
|
|
|
|
131
|
$use_rperl = 1; |
373
|
53
|
|
|
|
|
155
|
next; |
374
|
|
|
|
|
|
|
} |
375
|
|
|
|
|
|
|
|
376
|
|
|
|
|
|
|
# package declaration |
377
|
110419
|
100
|
|
|
|
167839
|
if ( $module_file_line =~ /^\s*package\s+/xms ) { |
378
|
|
|
|
|
|
|
|
379
|
|
|
|
|
|
|
# object properties, save types from just-finished package |
380
|
1643
|
100
|
|
|
|
3186
|
if ($inside_package) { |
381
|
939
|
|
|
|
|
1850
|
$object_properties_types = save_object_properties_types( $package_name, $object_properties_string, $object_properties_types ); |
382
|
939
|
|
|
|
|
1456
|
$object_properties_string = q{}; |
383
|
|
|
|
|
|
|
} |
384
|
1643
|
|
|
|
|
2249
|
$inside_package = 1; |
385
|
|
|
|
|
|
|
|
386
|
|
|
|
|
|
|
# one-line package declaration, indexed by PAUSE unless listed in no_index in Makefile.PL |
387
|
1643
|
100
|
|
|
|
7445
|
if ( $module_file_line =~ /^\s*package\s+(\w+(::\w+)*)\;.*$/xms ) { |
|
|
50
|
|
|
|
|
|
388
|
856
|
|
|
|
|
2298
|
$package_name = $1; |
389
|
|
|
|
|
|
|
# RPerl::diag( 'in Class.pm INIT block, one-line package declaration, have $package name = ' . $package_name . "\n" ); |
390
|
|
|
|
|
|
|
} |
391
|
|
|
|
|
|
|
|
392
|
|
|
|
|
|
|
# two-line package declaration, not indexed by PAUSE |
393
|
|
|
|
|
|
|
elsif ( $module_file_line =~ /^\s*package\s*\#\s*hide.*$/xms ) { # EX. package # hide from PAUSE indexing |
394
|
787
|
|
|
|
|
2432
|
$module_file_line = <$MODULE_FILE>; |
395
|
787
|
|
|
|
|
1157
|
chomp $module_file_line; |
396
|
787
|
50
|
|
|
|
2723
|
if ( $module_file_line =~ /^\s*(\w+(::\w+)*)\;.*$/xms ) { |
397
|
787
|
|
|
|
|
1734
|
$package_name = $1; |
398
|
|
|
|
|
|
|
# RPerl::diag( 'in Class.pm INIT block, two-line package declaration, have $package name = ' . $package_name . "\n" ); |
399
|
|
|
|
|
|
|
} |
400
|
|
|
|
|
|
|
else { |
401
|
0
|
|
|
|
|
0
|
croak q{Improperly formed two-line package declaration found in file '} |
402
|
|
|
|
|
|
|
. $module_filename_long |
403
|
|
|
|
|
|
|
. q{' near '} |
404
|
|
|
|
|
|
|
. $module_file_line |
405
|
|
|
|
|
|
|
. q{', croaking}; |
406
|
|
|
|
|
|
|
} |
407
|
|
|
|
|
|
|
} |
408
|
|
|
|
|
|
|
else { |
409
|
0
|
|
|
|
|
0
|
croak q{Improperly formed package declaration found in file '} |
410
|
|
|
|
|
|
|
. $module_filename_long |
411
|
|
|
|
|
|
|
. q{' near '} |
412
|
|
|
|
|
|
|
. $module_file_line |
413
|
|
|
|
|
|
|
. q{', croaking}; |
414
|
|
|
|
|
|
|
} |
415
|
|
|
|
|
|
|
|
416
|
1643
|
50
|
|
|
|
3140
|
if ($inside_subroutine) { |
417
|
|
|
|
|
|
|
# RPerl::diag( 'in Class.pm INIT block, have $package name = ' . $package_name . 'while inside subroutine ' . $subroutine_name . '(), aborting RPerl activation of entire file' . "\n" ); |
418
|
0
|
|
|
|
|
0
|
last; |
419
|
|
|
|
|
|
|
} |
420
|
|
|
|
|
|
|
# else { RPerl::diag( 'in Class.pm INIT block, have $package name = ' . $package_name . "\n" ); } |
421
|
|
|
|
|
|
|
|
422
|
|
|
|
|
|
|
# system-style RPerl header, 'use strict; use warnings; use RPerl::AfterSubclass;' on 3 lines |
423
|
|
|
|
|
|
|
# don't check for $VERSION due to numerous un-versioned subtypes |
424
|
1643
|
100
|
|
|
|
2927
|
if ( not $use_rperl ) { |
425
|
652
|
|
|
|
|
1269
|
foreach my $rperl_header_line ( 'use strict;', 'use warnings;', 'use RPerl::AfterSubclass;' ) { |
426
|
1883
|
|
|
|
|
6698
|
$module_file_line = <$MODULE_FILE>; |
427
|
1883
|
|
|
|
|
2569
|
chomp $module_file_line; |
428
|
1883
|
100
|
|
|
|
20003
|
if ( $module_file_line !~ /\Q$rperl_header_line/xms ) { |
429
|
|
|
|
|
|
|
|
430
|
|
|
|
|
|
|
# RPerl::diag(q{in Class.pm INIT block, failed to find RPerl header line '} . $rperl_header_line . q{' for $module_filename_short = } . $module_filename_short . ', aborting RPerl activation of entire file' . "\n"); |
431
|
38
|
|
|
|
|
174
|
next MODULE_FILE_LINE_LOOP; |
432
|
|
|
|
|
|
|
} |
433
|
|
|
|
|
|
|
} |
434
|
|
|
|
|
|
|
|
435
|
|
|
|
|
|
|
# RPerl::diag('in Class.pm INIT block, found RPerl header in $module_filename_short = ' . $module_filename_short . "\n"); |
436
|
614
|
|
|
|
|
1075
|
$use_rperl = 1; |
437
|
|
|
|
|
|
|
} |
438
|
|
|
|
|
|
|
|
439
|
|
|
|
|
|
|
# RPerl::diag(q{in Class.pm INIT block, have $use_rperl, enabling package in $module_filename_short = } . $module_filename_short . "\n"); |
440
|
|
|
|
|
|
|
|
441
|
|
|
|
|
|
|
# ops/types reporting subroutine |
442
|
|
|
|
|
|
|
# DEV NOTE, CORRELATION #rp018: RPerl::DataStructure::Array & Hash can not 'use RPerl;' so they are skipped in the header-checking loop above, their *__MODE_ID() subroutines are not created below |
443
|
1605
|
|
|
|
|
2558
|
$package_name_underscores = $package_name; |
444
|
1605
|
|
|
|
|
4740
|
$package_name_underscores =~ s/::/__/g; |
445
|
1605
|
100
|
|
|
|
81668
|
if ( not eval( 'defined &main::' . $package_name_underscores . '__MODE_ID' ) ) { |
446
|
1161
|
50
|
|
0
|
|
60761
|
eval( '*main::' . $package_name_underscores . '__MODE_ID = sub { return 0; };' ) # PERLOPS_PERLTYPES is 0 |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
447
|
|
|
|
|
|
|
|
448
|
|
|
|
|
|
|
# eval( 'sub main::' . $package_name_underscores . '__MODE_ID { return 0; }' ) # equivalent to previous line |
449
|
|
|
|
|
|
|
or croak($EVAL_ERROR); |
450
|
1161
|
50
|
|
|
|
3515
|
if ($EVAL_ERROR) { croak($EVAL_ERROR); } |
|
0
|
|
|
|
|
0
|
|
451
|
|
|
|
|
|
|
} |
452
|
|
|
|
|
|
|
|
453
|
1605
|
|
|
|
|
7747
|
next; |
454
|
|
|
|
|
|
|
} |
455
|
|
|
|
|
|
|
|
456
|
|
|
|
|
|
|
# object properties, remember types for deferred accessor/mutator generation below |
457
|
108776
|
100
|
|
|
|
158111
|
if ( $module_file_line =~ /^\s*our\s+hashref\s+\$properties/xms ) { |
458
|
|
|
|
|
|
|
|
459
|
|
|
|
|
|
|
# hard-coded example |
460
|
|
|
|
|
|
|
#our hashref $properties = { foo => my Foo::Bar_arrayref $TYPED_foo = undef, quux => my integer_hashref $TYPED_quux = {a => 12, b => 21} }; |
461
|
523
|
|
|
|
|
871
|
$inside_object_properties = 1; |
462
|
523
|
|
|
|
|
787
|
chomp $module_file_line; # strip trailing newline |
463
|
523
|
|
|
|
|
1169
|
$object_properties_string .= $module_file_line; |
464
|
523
|
|
|
|
|
1293
|
next; |
465
|
|
|
|
|
|
|
} |
466
|
|
|
|
|
|
|
|
467
|
|
|
|
|
|
|
# create symbol table entries for methods and plain-old non-method subroutines |
468
|
|
|
|
|
|
|
# DEPRECATED, CORRELATION #rp120: old subroutine header |
469
|
|
|
|
|
|
|
# if ( $module_file_line =~ /^\s*our\s+([\w:]+)\s+\$(\w+)\s+\=\s+sub\s+\{/xms ) { |
470
|
|
|
|
|
|
|
# if ( $module_file_line =~ /^\s*sub\s+(\w+)\s*\{[\s\n\r]*\{\s*my\s+([\w:]+)\s+\$RETURN_TYPE\s*\};/xms ) { # can't match multi-line content against single-line input |
471
|
|
|
|
|
|
|
|
472
|
|
|
|
|
|
|
# first half of subroutine header (name) |
473
|
|
|
|
|
|
|
# if ( $module_file_line =~ /^\s*sub\s+(\w+)\s*\{/xms ) { |
474
|
108253
|
100
|
|
|
|
163808
|
if ( $module_file_line =~ /^\s*sub\s+(\w+)\s*\{\s*(.*)$/xms ) { |
475
|
|
|
|
|
|
|
# RPerl::diag(q{in Class.pm INIT block, found first half of subroutine header for } . $1 . q{() in $module_filename_short = } . $module_filename_short . "\n"); |
476
|
2310
|
100
|
|
|
|
4467
|
if ($inside_subroutine_header) { |
477
|
|
|
|
|
|
|
# RPerl::diag(q{in Class.pm INIT block, found first half of subroutine header for } . $1 . q{() when already marked as $inside_subroutine_header for } . $subroutine_name . q{(), skipping activation of non-RPerl subroutine } . $subroutine_name . q{() in $module_filename_short = } . $module_filename_short . "\n"); |
478
|
53
|
|
|
|
|
81
|
$inside_subroutine_header = 0; |
479
|
|
|
|
|
|
|
} |
480
|
|
|
|
|
|
|
else { |
481
|
2257
|
|
|
|
|
3193
|
$inside_subroutine_header = 1; |
482
|
|
|
|
|
|
|
} |
483
|
2310
|
|
|
|
|
2968
|
$inside_object_properties = 0; |
484
|
2310
|
|
|
|
|
2843
|
$inside_subroutine = 0; |
485
|
2310
|
100
|
|
|
|
4410
|
if ( not $use_rperl ) { |
486
|
|
|
|
|
|
|
# RPerl::diag(q{in Class.pm INIT block, do NOT have $use_rperl, skipping subroutine } . $1 . q{() in $module_filename_short = } . $module_filename_short . "\n"); |
487
|
123
|
|
|
|
|
184
|
$subroutine_name = q{}; |
488
|
123
|
|
|
|
|
329
|
next; |
489
|
|
|
|
|
|
|
} |
490
|
|
|
|
|
|
|
# else { RPerl::diag(q{in Class.pm INIT block, have $use_rperl, looking for second half of header for subroutine } . $1 . q{() in $module_filename_short = } . $module_filename_short . "\n"); } |
491
|
|
|
|
|
|
|
|
492
|
|
|
|
|
|
|
# NEED ANSWER: should this be a croak() or die() statement instead of just an abort? |
493
|
2187
|
50
|
|
|
|
3720
|
if ($inside_subroutine_arguments) { |
494
|
0
|
|
|
|
|
0
|
RPerl::warning( q{WARNING WCOPR00, PRE-PROCESSOR: Found header for subroutine $subroutine_name = } . $1 . '() while we should still be inside arguments of subroutine ' . $subroutine_name . '(), aborting RPerl activation of entire file' . "\n" ); |
495
|
0
|
|
|
|
|
0
|
$subroutine_name = q{}; |
496
|
0
|
|
|
|
|
0
|
last; # last line of file |
497
|
|
|
|
|
|
|
} |
498
|
|
|
|
|
|
|
|
499
|
|
|
|
|
|
|
# DEV NOTE, CORRELATION #rp053: even with the upgrade to normal Perl subroutine headers, we must still activate subroutines w/out args or when type-checking is explicitly disabled with CHECK OFF, in order for RPerl::Exporter to work properly, presumably because Exporter.pm runs before Class.pm and thus we can not test for the existence of __CHECKED_*() subroutines in RPerl::Exporter::import() |
500
|
|
|
|
|
|
|
# activate previous subroutine, no arguments |
501
|
2187
|
50
|
|
|
|
3693
|
if ($inside_subroutine) { |
502
|
|
|
|
|
|
|
# RPerl::diag( q{in Class.pm INIT block, have $inside_subroutine = } . $inside_subroutine . q{, about to call activate_subroutine_args_checking() while inside subroutine } . $subroutine_name . '(), no arguments assumed' . "\n" ); |
503
|
0
|
|
|
|
|
0
|
activate_subroutine_args_checking( $package_name, $subroutine_name, $subroutine_type, q{}, $module_filename_long ); |
504
|
|
|
|
|
|
|
} |
505
|
|
|
|
|
|
|
|
506
|
2187
|
|
|
|
|
4856
|
$subroutine_name = $1; |
507
|
|
|
|
|
|
|
|
508
|
|
|
|
|
|
|
# enable single-line subroutine headers, continue parsing same input line if it contains more data |
509
|
2187
|
100
|
|
|
|
4542
|
if ($2 ne q{}) { |
510
|
31
|
|
|
|
|
75
|
$module_file_line = $2; |
511
|
31
|
|
|
|
|
282
|
goto MODULE_FILE_LINE_LOOP_INNER; |
512
|
|
|
|
|
|
|
} |
513
|
|
|
|
|
|
|
|
514
|
2156
|
|
|
|
|
5416
|
next; |
515
|
|
|
|
|
|
|
} |
516
|
|
|
|
|
|
|
|
517
|
|
|
|
|
|
|
# second half of subroutine header (return type), TYPO WARNING |
518
|
105943
|
50
|
|
|
|
151078
|
if ( $module_file_line =~ /^\s*\{\s*my\s+([\w:]+)\s+\$RETURN_VALUE\s*\}\s*;/xms ) { |
519
|
0
|
|
|
|
|
0
|
RPerl::warning(q{WARNING WCOPR01, PRE-PROCESSOR: Likely typo of '$RETURN_VALUE' instead of '$RETURN_TYPE' in subroutine } . $subroutine_name . q{() in $module_filename_short = } . $module_filename_short . "\n"); |
520
|
|
|
|
|
|
|
} |
521
|
|
|
|
|
|
|
# second half of subroutine header (return type) |
522
|
|
|
|
|
|
|
# if ( $module_file_line =~ /^\s*\{\s*my\s+([\w:]+)\s+\$RETURN_TYPE\s*\}\s*;/xms ) { |
523
|
105943
|
100
|
|
|
|
156851
|
if ( $module_file_line =~ /^\s*\{\s*my\s+([\w:]+)\s+\$RETURN_TYPE\s*\}\s*;\s*(.*)/xms ) { |
524
|
|
|
|
|
|
|
# RPerl::diag(q{in Class.pm INIT block, found second half of subroutine header for } . $subroutine_name . q{() in $module_filename_short = } . $module_filename_short . "\n"); |
525
|
2187
|
100
|
|
|
|
3939
|
if ($inside_subroutine_header) { |
526
|
2173
|
|
|
|
|
2869
|
$inside_subroutine_header = 0; |
527
|
|
|
|
|
|
|
} |
528
|
|
|
|
|
|
|
else { |
529
|
|
|
|
|
|
|
# RPerl::diag(q{in Class.pm INIT block, found second half of subroutine header with $RETURN_TYPE } . $1 . q{ when not already marked as $inside_subroutine_header for } . $subroutine_name . q{(), skipping activation of unknown subroutine in $module_filename_short = } . $module_filename_short . "\n"); |
530
|
14
|
|
|
|
|
45
|
next; |
531
|
|
|
|
|
|
|
} |
532
|
2173
|
|
|
|
|
3981
|
$subroutine_type = $1; |
533
|
|
|
|
|
|
|
|
534
|
|
|
|
|
|
|
# RPerl::diag( q{in Class.pm INIT block, have $subroutine_type = } . $subroutine_type . q{, and $subroutine_name = } . $subroutine_name . "()\n" ); |
535
|
|
|
|
|
|
|
# RPerl::diag( q{in Class.pm INIT block, have $CHECK = '} . $CHECK . "'\n" ); |
536
|
|
|
|
|
|
|
|
537
|
|
|
|
|
|
|
# DEV NOTE, CORRELATION #rp053: even with the upgrade to normal Perl subroutine headers, we must still activate subroutines w/out args or when type-checking is explicitly disabled with CHECK OFF, in order for RPerl::Exporter to work properly, presumably because Exporter.pm runs before Class.pm and thus we can not test for the existence of __CHECKED_*() subroutines in RPerl::Exporter::import() |
538
|
2173
|
50
|
0
|
|
|
3965
|
if ( $CHECK eq 'OFF' ) { |
|
|
0
|
|
|
|
|
|
539
|
|
|
|
|
|
|
# RPerl::diag( q{in Class.pm INIT block, CHECK IS OFF, about to call activate_subroutine_args_checking()...} . "\n" ); |
540
|
2173
|
|
|
|
|
4952
|
activate_subroutine_args_checking( $package_name, $subroutine_name, $subroutine_type, q{}, $module_filename_long ); |
541
|
|
|
|
|
|
|
} |
542
|
|
|
|
|
|
|
elsif ( ( $CHECK ne 'ON' ) and ( $CHECK ne 'TRACE' ) ) { |
543
|
0
|
|
|
|
|
0
|
croak( 'Received invalid value ' |
544
|
|
|
|
|
|
|
. $CHECK |
545
|
|
|
|
|
|
|
. ' for RPerl preprocessor directive CHECK to control data type checking, valid values are OFF, ON, and TRACE, croaking' ); |
546
|
|
|
|
|
|
|
} |
547
|
|
|
|
|
|
|
else { |
548
|
0
|
|
|
|
|
0
|
$inside_subroutine = 1; |
549
|
|
|
|
|
|
|
} |
550
|
|
|
|
|
|
|
|
551
|
|
|
|
|
|
|
# enable single-line subroutine headers, continue parsing same input line if it contains more data |
552
|
2173
|
100
|
|
|
|
5996
|
if ($2 ne q{}) { |
553
|
17
|
|
|
|
|
45
|
$module_file_line = $2; |
554
|
17
|
|
|
|
|
135
|
goto MODULE_FILE_LINE_LOOP_INNER; |
555
|
|
|
|
|
|
|
} |
556
|
|
|
|
|
|
|
|
557
|
2156
|
|
|
|
|
9371
|
next; |
558
|
|
|
|
|
|
|
} |
559
|
|
|
|
|
|
|
|
560
|
|
|
|
|
|
|
# skip class properties AKA package variables |
561
|
103756
|
100
|
|
|
|
158682
|
if ( $module_file_line =~ /^\s*our\s+[\w:]+\s+\$\w+\s+\=/xms ) { |
562
|
30
|
|
|
|
|
67
|
$inside_object_properties = 0; |
563
|
|
|
|
|
|
|
} |
564
|
|
|
|
|
|
|
|
565
|
|
|
|
|
|
|
# skip non-RPerl-enabled subroutine/method, using normal Perl 'sub foo {}' syntax instead of RPerl syntax |
566
|
|
|
|
|
|
|
# DEPRECATED, CORRELATION #rp120: old subroutine header |
567
|
|
|
|
|
|
|
# if ( $module_file_line =~ /^\s*sub\s+[\w:]+\s+\{/xms ) { |
568
|
|
|
|
|
|
|
# $inside_object_properties = 0; |
569
|
|
|
|
|
|
|
# } |
570
|
|
|
|
|
|
|
|
571
|
|
|
|
|
|
|
# skip end-of-module line |
572
|
103756
|
100
|
|
|
|
150377
|
if ( $module_file_line =~ /^\s*1\;\s+\#\ end\ of/xms ) { |
573
|
660
|
|
|
|
|
1025
|
$inside_object_properties = 0; |
574
|
|
|
|
|
|
|
} |
575
|
|
|
|
|
|
|
|
576
|
|
|
|
|
|
|
# object properties, continue to aggregate types |
577
|
103756
|
100
|
|
|
|
146477
|
if ($inside_object_properties) { |
578
|
1067
|
|
|
|
|
1362
|
chomp $module_file_line; # strip trailing newline |
579
|
1067
|
|
|
|
|
1396
|
$object_properties_string .= $module_file_line; |
580
|
1067
|
|
|
|
|
2106
|
next; |
581
|
|
|
|
|
|
|
} |
582
|
|
|
|
|
|
|
|
583
|
|
|
|
|
|
|
# subroutine/method, process arguments and activate type checking |
584
|
102689
|
50
|
|
|
|
227693
|
if ($inside_subroutine) { |
585
|
0
|
0
|
|
|
|
0
|
if ( not $use_rperl ) { |
586
|
|
|
|
|
|
|
# RPerl::diag(q{in Class.pm INIT block, do NOT have $use_rperl, skipping inside subroutine in $module_filename_short = } . $module_filename_short . "\n"); |
587
|
0
|
|
|
|
|
0
|
next; |
588
|
|
|
|
|
|
|
} |
589
|
|
|
|
|
|
|
# else { RPerl::diag(q{in Class.pm INIT block, have $use_rperl, enabling inside subroutine in $module_filename_short = } . $module_filename_short . "\n"); } |
590
|
|
|
|
|
|
|
|
591
|
|
|
|
|
|
|
# RPerl::diag( q{in Class.pm INIT block, have $inside_subroutine = 1} . "\n" ); |
592
|
|
|
|
|
|
|
# RPerl::diag("in Class.pm INIT block, have \$module_file_line =\n$module_file_line\n"); |
593
|
0
|
0
|
|
|
|
0
|
if ( $module_file_line =~ /^\s*\(\s*my/xms ) { |
594
|
0
|
|
|
|
|
0
|
$inside_subroutine_arguments = 1; |
595
|
|
|
|
|
|
|
} |
596
|
|
|
|
|
|
|
|
597
|
|
|
|
|
|
|
# RPerl::diag( q{in Class.pm INIT block, have $inside_subroutine_arguments = }, $inside_subroutine_arguments, "\n" ); |
598
|
0
|
0
|
|
|
|
0
|
if ($inside_subroutine_arguments) { |
599
|
0
|
|
|
|
|
0
|
$subroutine_arguments_line .= $module_file_line; |
600
|
0
|
0
|
|
|
|
0
|
if ( $subroutine_arguments_line =~ /\@ARG\;/xms ) { # @ARG; found |
601
|
0
|
0
|
|
|
|
0
|
if ( not( $subroutine_arguments_line =~ /\@ARG\;$/xms ) ) { # @ARG; found not at end-of-line |
602
|
|
|
|
|
|
|
# RPerl::diag( q{in Class.pm INIT block, found @ARG; NOT at end-of-line while inside subroutine } . $subroutine_name . '(), have $subroutine_arguments_line = ' . "\n" . $subroutine_arguments_line . "\n\n" . 'aborting RPerl activation of entire file' . "\n" ); |
603
|
0
|
|
|
|
|
0
|
last; |
604
|
|
|
|
|
|
|
} |
605
|
|
|
|
|
|
|
|
606
|
|
|
|
|
|
|
# RPerl::diag( q{in Class.pm INIT block, found @ARG; at end-of-line while inside subroutine } . $subroutine_name . '(), have $subroutine_arguments_line = ' . "\n" . $subroutine_arguments_line . "\n" ); |
607
|
|
|
|
|
|
|
|
608
|
0
|
|
|
|
|
0
|
my $subroutine_arguments = []; # string_arrayref_arrayref |
609
|
|
|
|
|
|
|
|
610
|
|
|
|
|
|
|
# loop once per subroutine argument |
611
|
0
|
|
|
|
|
0
|
while ( $subroutine_arguments_line =~ m/my\s+(\w+)\s+\$(\w+)/g ) { |
612
|
0
|
|
|
|
|
0
|
push @{$subroutine_arguments}, [ $1, $2 ]; |
|
0
|
|
|
|
|
0
|
|
613
|
|
|
|
|
|
|
# RPerl::diag( q{in Class.pm INIT block, have subroutine argument type = } . $1 . q{ and subroutine argument name = } . $2 . "\n" ); |
614
|
|
|
|
|
|
|
} |
615
|
|
|
|
|
|
|
|
616
|
|
|
|
|
|
|
# RPerl::diag( q{in Class.pm INIT block, have $subroutine_arguments = } . "\n" . Dumper($subroutine_arguments) . "\n" ); |
617
|
|
|
|
|
|
|
|
618
|
0
|
|
|
|
|
0
|
my $subroutine_arguments_check_code = "\n"; # string |
619
|
|
|
|
|
|
|
|
620
|
0
|
0
|
|
|
|
0
|
if ( $CHECK eq 'ON' ) { |
|
|
0
|
|
|
|
|
|
621
|
|
|
|
|
|
|
# RPerl::diag( 'in Class.pm INIT block, CHECK IS ON' . "\n" ); |
622
|
0
|
|
|
|
|
0
|
my $i = 0; # integer |
623
|
0
|
|
|
|
|
0
|
foreach my $subroutine_argument ( @{$subroutine_arguments} ) { |
|
0
|
|
|
|
|
0
|
|
624
|
|
|
|
|
|
|
# $subroutine_arguments_check_code .= q{ } . $subroutine_argument->[0] . '_CHECK( $_[' . $i . '] );' . "\n"; # DOES NOT WORK, fails to find RPerl::Exporter::integer_CHECKTRACE() etc. |
625
|
|
|
|
|
|
|
# $subroutine_arguments_check_code .= q{ ::} . $subroutine_argument->[0] . '_CHECK( $_[' . $i . '] );' . "\n"; # DOES NOT WORK, we no longer export all the type-checking subroutines to the main '::' namespace |
626
|
0
|
|
|
|
|
0
|
$subroutine_arguments_check_code .= q{ rperltypes::} . $subroutine_argument->[0] . '_CHECK( $_[' . $i . '] );' . "\n"; # does work, hard-code all automatically-generated type-checking code to 'rperltypes::' namespace |
627
|
0
|
|
|
|
|
0
|
$i++; |
628
|
|
|
|
|
|
|
} |
629
|
|
|
|
|
|
|
|
630
|
|
|
|
|
|
|
# RPerl::diag( 'in Class.pm INIT block, CHECK IS ON, about to call activate_subroutine_args_checking()...' . "\n" ); |
631
|
0
|
|
|
|
|
0
|
activate_subroutine_args_checking( $package_name, $subroutine_name, $subroutine_type, $subroutine_arguments_check_code, $module_filename_long ); |
632
|
0
|
|
|
|
|
0
|
$inside_subroutine = 0; |
633
|
0
|
|
|
|
|
0
|
$subroutine_arguments_line = q{}; |
634
|
|
|
|
|
|
|
} |
635
|
|
|
|
|
|
|
elsif ( $CHECK eq 'TRACE' ) { |
636
|
|
|
|
|
|
|
# RPerl::diag( 'in Class.pm INIT block, CHECK IS TRACE' . "\n" ); |
637
|
0
|
|
|
|
|
0
|
my $i = 0; # integer |
638
|
0
|
|
|
|
|
0
|
foreach my $subroutine_argument ( @{$subroutine_arguments} ) { |
|
0
|
|
|
|
|
0
|
|
639
|
|
|
|
|
|
|
# $subroutine_arguments_check_code .= q{ } . $subroutine_argument->[0] . '_CHECKTRACE( $_[' . $i . q{], '$} . $subroutine_argument->[1] . q{', '} . $subroutine_name . q{()' );} . "\n"; # DOES NOT WORK |
640
|
|
|
|
|
|
|
# $subroutine_arguments_check_code .= q{ ::} . $subroutine_argument->[0] . '_CHECKTRACE( $_[' . $i . q{], '$} . $subroutine_argument->[1] . q{', '} . $subroutine_name . q{()' );} . "\n"; # DOES NOT WORK |
641
|
0
|
|
|
|
|
0
|
$subroutine_arguments_check_code .= q{ rperltypes::} . $subroutine_argument->[0] . '_CHECKTRACE( $_[' . $i . q{], '$} . $subroutine_argument->[1] . q{', '} . $subroutine_name . q{()' );} . "\n"; |
642
|
0
|
|
|
|
|
0
|
$i++; |
643
|
|
|
|
|
|
|
} |
644
|
|
|
|
|
|
|
# RPerl::diag( 'in Class.pm INIT block, CHECK IS TRACE, about to call activate_subroutine_args_checking()...' . "\n" ); |
645
|
0
|
|
|
|
|
0
|
activate_subroutine_args_checking( $package_name, $subroutine_name, $subroutine_type, $subroutine_arguments_check_code, $module_filename_long ); |
646
|
0
|
|
|
|
|
0
|
$inside_subroutine = 0; |
647
|
0
|
|
|
|
|
0
|
$subroutine_arguments_line = q{}; |
648
|
|
|
|
|
|
|
} |
649
|
|
|
|
|
|
|
else { |
650
|
0
|
|
|
|
|
0
|
croak( 'Received invalid value ' |
651
|
|
|
|
|
|
|
. $CHECK |
652
|
|
|
|
|
|
|
. ' for RPerl preprocessor directive CHECK to control data type checking, valid values are OFF, ON, and TRACE, croaking' |
653
|
|
|
|
|
|
|
); |
654
|
|
|
|
|
|
|
} |
655
|
0
|
|
|
|
|
0
|
$inside_subroutine_arguments = 0; |
656
|
|
|
|
|
|
|
# RPerl::diag( 'in Class.pm INIT block, have $subroutine_arguments_check_code =' . "\n" . $subroutine_arguments_check_code . "\n" ); |
657
|
|
|
|
|
|
|
} |
658
|
|
|
|
|
|
|
|
659
|
0
|
|
|
|
|
0
|
next; # next file line |
660
|
|
|
|
|
|
|
} |
661
|
|
|
|
|
|
|
} |
662
|
|
|
|
|
|
|
} |
663
|
|
|
|
|
|
|
|
664
|
711
|
50
|
|
|
|
5600
|
close $MODULE_FILE or croak $OS_ERROR; |
665
|
|
|
|
|
|
|
|
666
|
|
|
|
|
|
|
# activate final subroutine in file, no arguments |
667
|
711
|
50
|
|
|
|
1615
|
if ($inside_subroutine) { |
668
|
0
|
0
|
|
|
|
0
|
if ($inside_subroutine_arguments) { |
669
|
0
|
|
|
|
|
0
|
croak('Did not find @ARG to end subroutine arguments before end of file, croaking'); |
670
|
|
|
|
|
|
|
} |
671
|
|
|
|
|
|
|
|
672
|
|
|
|
|
|
|
# DEV NOTE, CORRELATION #rp053: even with the upgrade to normal Perl subroutine headers, we must still activate subroutines w/out args or when type-checking is explicitly disabled with CHECK OFF, in order for RPerl::Exporter to work properly, presumably because Exporter.pm runs before Class.pm and thus we can not test for the existence of __CHECKED_*() subroutines in RPerl::Exporter::import() |
673
|
|
|
|
|
|
|
# RPerl::diag( 'in Class.pm INIT block, activating final subroutine in file, no subroutine arguments found' . "\n" ); |
674
|
0
|
|
|
|
|
0
|
activate_subroutine_args_checking( $package_name, $subroutine_name, $subroutine_type, q{}, $module_filename_long ); |
675
|
0
|
|
|
|
|
0
|
$inside_subroutine = 0; |
676
|
|
|
|
|
|
|
} |
677
|
|
|
|
|
|
|
|
678
|
|
|
|
|
|
|
# object properties, save final package's types |
679
|
711
|
|
|
|
|
1965
|
$object_properties_types = save_object_properties_types( $package_name, $object_properties_string, $object_properties_types ); |
680
|
|
|
|
|
|
|
|
681
|
|
|
|
|
|
|
# RPerl::diag( 'in Class.pm INIT block, have $object_properties_types = ' . "\n" . Dumper($object_properties_types) . "\n" ) if ( keys %{$object_properties_types} ); |
682
|
|
|
|
|
|
|
|
683
|
|
|
|
|
|
|
# accessor/mutator object methods, deferred creation for all packages found in this file |
684
|
711
|
|
|
|
|
1334
|
foreach $package_name ( sort keys %{$object_properties_types} ) { |
|
711
|
|
|
|
|
5461
|
|
685
|
|
|
|
|
|
|
# RPerl::diag("in Class.pm INIT block, about to create accessors/mutators, have \$package_name = '$package_name'\n"); |
686
|
32
|
|
|
|
|
1418
|
$object_properties = eval "\$$package_name\:\:properties"; |
687
|
|
|
|
|
|
|
|
688
|
32
|
|
|
|
|
106
|
foreach my $property_name ( sort keys %{$object_properties} ) { |
|
32
|
|
|
|
|
161
|
|
689
|
|
|
|
|
|
|
|
690
|
|
|
|
|
|
|
# RPerl::diag("in Class.pm INIT block, about to create accessors/mutators, have \$property_name = '$property_name'\n"); |
691
|
|
|
|
|
|
|
# DEV NOTE, CORRELATION #rp003: avoid re-defining class accessor/mutator methods; so far only triggered by RPerl::CodeBlock::Subroutine |
692
|
|
|
|
|
|
|
# because it has a special BEGIN{} block with multiple package names including it's own package name |
693
|
|
|
|
|
|
|
|
694
|
48
|
|
|
|
|
133
|
my $property_type = $object_properties_types->{$package_name}->{$property_name}; |
695
|
48
|
|
|
|
|
85
|
my $eval_string; |
696
|
48
|
|
|
|
|
86
|
my $return_whole = 0; |
697
|
|
|
|
|
|
|
|
698
|
|
|
|
|
|
|
# RPerl::diag("in Class.pm INIT block, about to create accessors/mutators, have \$property_type = '$property_type'\n"); |
699
|
|
|
|
|
|
|
|
700
|
|
|
|
|
|
|
# array element accessor/mutator |
701
|
48
|
100
|
66
|
|
|
805
|
if ( ( $property_type =~ /_arrayref$/ ) |
|
|
100
|
66
|
|
|
|
|
702
|
|
|
|
|
|
|
and ( not eval( 'defined &' . $package_name . '::get_' . $property_name . '_element' ) ) ) |
703
|
|
|
|
|
|
|
{ |
704
|
|
|
|
|
|
|
# RPerl::diag('in Class.pm INIT block, about to create accessors/mutators, have arrayref type' . "\n"); |
705
|
|
|
|
|
|
|
# hard-coded examples |
706
|
|
|
|
|
|
|
# sub get_foo_size { { my integer::method $RETURN_TYPE }; ( my Foo::Bar $self ) = @ARG; return (scalar @{$self->{foo}}); } |
707
|
|
|
|
|
|
|
# sub get_foo_element { { my Foo::Quux::method $RETURN_TYPE }; ( my Foo::Bar $self, my integer $i ) = @ARG; return $self->{foo}->[$i]; } |
708
|
|
|
|
|
|
|
# sub set_foo_element { { my void::method $RETURN_TYPE }; ( my Foo::Bar $self, my integer $i, my Foo::Quux $foo_element ) = @ARG; $self->{foo}->[$i] = $foo_element; } |
709
|
6
|
|
|
|
|
27
|
my $property_element_type = substr $property_type, 0, ( ( length $property_type ) - 9 ); # strip trailing '_arrayref' |
710
|
6
|
50
|
|
|
|
36
|
if ( exists $rperlnamespaces_generated::RPERL->{ $property_element_type . '::' } ) { |
711
|
|
|
|
|
|
|
# RPerl::diag('in Class.pm INIT block, about to create accessors/mutators, have RPerl arrayref type, setting $return_whole flag' . "\n"); |
712
|
6
|
|
|
|
|
13
|
$return_whole = 1; |
713
|
|
|
|
|
|
|
} |
714
|
|
|
|
|
|
|
else { |
715
|
0
|
|
|
|
|
0
|
$eval_string |
716
|
|
|
|
|
|
|
= 'sub' |
717
|
|
|
|
|
|
|
. $package_name |
718
|
|
|
|
|
|
|
. '::get_' |
719
|
|
|
|
|
|
|
. $property_name . '_size' |
720
|
|
|
|
|
|
|
. '} = sub { ( my ' |
721
|
|
|
|
|
|
|
. $package_name |
722
|
|
|
|
|
|
|
. ' $self ) = @ARG; return (scalar @{$self->{' |
723
|
|
|
|
|
|
|
. $property_name |
724
|
|
|
|
|
|
|
. '}}); };'; |
725
|
0
|
|
|
|
|
0
|
$eval_string |
726
|
|
|
|
|
|
|
.= '*{' |
727
|
|
|
|
|
|
|
. $package_name |
728
|
|
|
|
|
|
|
. '::get_' |
729
|
|
|
|
|
|
|
. $property_name |
730
|
|
|
|
|
|
|
. '_element' |
731
|
|
|
|
|
|
|
. '} = sub { ( my ' |
732
|
|
|
|
|
|
|
. $package_name |
733
|
|
|
|
|
|
|
. ' $self, my integer $i ) = @ARG; return $self->{' |
734
|
|
|
|
|
|
|
. $property_name |
735
|
|
|
|
|
|
|
. '}->[$i]; };'; |
736
|
0
|
|
|
|
|
0
|
$eval_string |
737
|
|
|
|
|
|
|
.= '*{' |
738
|
|
|
|
|
|
|
. $package_name |
739
|
|
|
|
|
|
|
. '::set_' |
740
|
|
|
|
|
|
|
. $property_name |
741
|
|
|
|
|
|
|
. '_element' |
742
|
|
|
|
|
|
|
. '} = sub { ( my ' |
743
|
|
|
|
|
|
|
. $package_name |
744
|
|
|
|
|
|
|
. ' $self, my integer $i, my ' |
745
|
|
|
|
|
|
|
. $property_element_type . ' $' |
746
|
|
|
|
|
|
|
. $property_name |
747
|
|
|
|
|
|
|
. '_element ) = @ARG; $self->{' |
748
|
|
|
|
|
|
|
. $property_name |
749
|
|
|
|
|
|
|
. '}->[$i] = $' |
750
|
|
|
|
|
|
|
. $property_name |
751
|
|
|
|
|
|
|
. '_element; };'; |
752
|
|
|
|
|
|
|
|
753
|
|
|
|
|
|
|
# RPerl::diag( 'in Class::INIT() block, have user-defined object array element accessor $eval_string = ' . "\n" . $eval_string . "\n" ); |
754
|
0
|
0
|
|
|
|
0
|
eval($eval_string) or croak($EVAL_ERROR); |
755
|
0
|
0
|
|
|
|
0
|
if ($EVAL_ERROR) { croak($EVAL_ERROR); } |
|
0
|
|
|
|
|
0
|
|
756
|
|
|
|
|
|
|
} |
757
|
|
|
|
|
|
|
} |
758
|
|
|
|
|
|
|
|
759
|
|
|
|
|
|
|
# hash value accessor/mutator |
760
|
|
|
|
|
|
|
elsif ( ( $property_type =~ /_hashref$/ ) |
761
|
|
|
|
|
|
|
and ( not eval( 'defined &' . $package_name . '::get_' . $property_name . '_element' ) ) ) |
762
|
|
|
|
|
|
|
{ |
763
|
|
|
|
|
|
|
# hard-coded example |
764
|
|
|
|
|
|
|
# sub get_foo_keys { { my string_arrayref::method $RETURN_TYPE }; ( my Foo::Bar $self ) = @ARG; return [sort keys %{$self->{foo}}]; } |
765
|
|
|
|
|
|
|
# sub get_foo_element { { my Foo::Quux::method $RETURN_TYPE }; ( my Foo::Bar $self, my integer $i ) = @ARG; return $self->{foo}->{$i}; } |
766
|
|
|
|
|
|
|
# sub set_foo_element { { my void::method $RETURN_TYPE }; ( my Foo::Bar $self, my integer $i, my Foo::Quux $foo_element ) = @ARG; $self->{foo}->{$i} = $foo_element; } |
767
|
6
|
|
|
|
|
27
|
my $property_value_type = substr $property_type, 0, ( ( length $property_type ) - 8 ); # strip trailing '_hashref' |
768
|
6
|
50
|
|
|
|
38
|
if ( exists $rperlnamespaces_generated::RPERL->{ $property_value_type . '::' } ) { |
769
|
6
|
|
|
|
|
15
|
$return_whole = 1; |
770
|
|
|
|
|
|
|
} |
771
|
|
|
|
|
|
|
else { |
772
|
0
|
|
|
|
|
0
|
$eval_string |
773
|
|
|
|
|
|
|
= '*{' |
774
|
|
|
|
|
|
|
. $package_name |
775
|
|
|
|
|
|
|
. '::get_' |
776
|
|
|
|
|
|
|
. $property_name . '_keys' |
777
|
|
|
|
|
|
|
. '} = sub { ( my ' |
778
|
|
|
|
|
|
|
. $package_name |
779
|
|
|
|
|
|
|
. ' $self ) = @ARG; return [sort keys %{$self->{' |
780
|
|
|
|
|
|
|
. $property_name |
781
|
|
|
|
|
|
|
. '}}]; };'; |
782
|
0
|
|
|
|
|
0
|
$eval_string |
783
|
|
|
|
|
|
|
.= '*{' |
784
|
|
|
|
|
|
|
. $package_name |
785
|
|
|
|
|
|
|
. '::get_' |
786
|
|
|
|
|
|
|
. $property_name |
787
|
|
|
|
|
|
|
. '_element' |
788
|
|
|
|
|
|
|
. '} = sub { ( my ' |
789
|
|
|
|
|
|
|
. $package_name |
790
|
|
|
|
|
|
|
. ' $self, my integer $i ) = @ARG; return $self->{' |
791
|
|
|
|
|
|
|
. $property_name |
792
|
|
|
|
|
|
|
. '}->{$i}; };'; |
793
|
0
|
|
|
|
|
0
|
$eval_string |
794
|
|
|
|
|
|
|
.= '*{' |
795
|
|
|
|
|
|
|
. $package_name |
796
|
|
|
|
|
|
|
. '::set_' |
797
|
|
|
|
|
|
|
. $property_name |
798
|
|
|
|
|
|
|
. '_element' |
799
|
|
|
|
|
|
|
. '} = sub { ( my ' |
800
|
|
|
|
|
|
|
. $package_name |
801
|
|
|
|
|
|
|
. ' $self, my integer $i, my ' |
802
|
|
|
|
|
|
|
. $property_value_type . ' $' |
803
|
|
|
|
|
|
|
. $property_name |
804
|
|
|
|
|
|
|
. '_element ) = @ARG; $self->{' |
805
|
|
|
|
|
|
|
. $property_name |
806
|
|
|
|
|
|
|
. '}->{$i} = $' |
807
|
|
|
|
|
|
|
. $property_name |
808
|
|
|
|
|
|
|
. '_element; };'; |
809
|
|
|
|
|
|
|
|
810
|
|
|
|
|
|
|
# RPerl::diag( 'in Class::INIT() block, have user-defined object hash value accessor $eval_string = ' . "\n" . $eval_string . "\n" ); |
811
|
0
|
0
|
|
|
|
0
|
eval($eval_string) or croak($EVAL_ERROR); |
812
|
0
|
0
|
|
|
|
0
|
if ($EVAL_ERROR) { croak($EVAL_ERROR); } |
|
0
|
|
|
|
|
0
|
|
813
|
|
|
|
|
|
|
} |
814
|
|
|
|
|
|
|
} |
815
|
|
|
|
|
|
|
|
816
|
|
|
|
|
|
|
# scalar accessor/mutator |
817
|
|
|
|
|
|
|
else { |
818
|
36
|
|
|
|
|
102
|
$return_whole = 1; |
819
|
|
|
|
|
|
|
} |
820
|
|
|
|
|
|
|
|
821
|
|
|
|
|
|
|
# return whole values for scalars, scalar arrayrefs, and scalar hashrefs |
822
|
48
|
50
|
|
|
|
159
|
if ($return_whole) { |
823
|
48
|
50
|
|
|
|
2088
|
if ( not eval( 'defined &' . $package_name . '::get_' . $property_name ) ) { |
824
|
48
|
|
|
|
|
191
|
$eval_string = '*{' . $package_name . '::get_' . $property_name . '} = sub { return $_[0]->{' . $property_name . '}; };'; |
825
|
|
|
|
|
|
|
# RPerl::diag( 'in Class::INIT() block, have $return_whole accessor $eval_string = ' . "\n" . $eval_string . "\n" ); |
826
|
48
|
50
|
|
0
|
|
3116
|
eval($eval_string) or croak($EVAL_ERROR); |
|
1
|
|
|
|
|
12
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
827
|
48
|
50
|
|
|
|
355
|
if ($EVAL_ERROR) { croak($EVAL_ERROR); } |
|
0
|
|
|
|
|
0
|
|
828
|
|
|
|
|
|
|
} |
829
|
|
|
|
|
|
|
|
830
|
48
|
50
|
|
|
|
2214
|
if ( not eval( 'defined &' . $package_name . '::set_' . $property_name ) ) { |
831
|
48
|
|
|
|
|
227
|
$eval_string |
832
|
|
|
|
|
|
|
= '*{' |
833
|
|
|
|
|
|
|
. $package_name |
834
|
|
|
|
|
|
|
. '::set_' |
835
|
|
|
|
|
|
|
. $property_name |
836
|
|
|
|
|
|
|
. '} = sub { $_[0]->{' |
837
|
|
|
|
|
|
|
. $property_name |
838
|
|
|
|
|
|
|
. '} = $_[1]; return $_[0]->{' |
839
|
|
|
|
|
|
|
. $property_name . '}; };'; |
840
|
|
|
|
|
|
|
# RPerl::diag( 'in Class::INIT() block, have $return_whole mutator $eval_string = ' . "\n" . $eval_string . "\n" ); |
841
|
48
|
50
|
|
0
|
|
3390
|
eval($eval_string) or croak($EVAL_ERROR); |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
32
|
|
|
|
|
127
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
308
|
|
|
|
|
1786
|
|
|
21
|
|
|
|
|
108
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
2
|
|
|
|
|
11
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
187
|
|
|
|
|
784
|
|
842
|
48
|
50
|
|
|
|
817
|
if ($EVAL_ERROR) { croak($EVAL_ERROR); } |
|
0
|
|
|
|
|
0
|
|
843
|
|
|
|
|
|
|
} |
844
|
|
|
|
|
|
|
} |
845
|
|
|
|
|
|
|
} |
846
|
|
|
|
|
|
|
} |
847
|
|
|
|
|
|
|
} |
848
|
|
|
|
|
|
|
# else { RPerl::diag('in Class.pm INIT block, found existing $rperlnamespaces_generated::CORE->{' . $namespace_root . '}, aborting RPerl activation of entire file' . "\n"); } |
849
|
|
|
|
|
|
|
} |
850
|
|
|
|
|
|
|
} |
851
|
|
|
|
|
|
|
|
852
|
|
|
|
|
|
|
|
853
|
|
|
|
|
|
|
# fake getting and setting values of *_raw subclass of user-defined type (AKA class), |
854
|
|
|
|
|
|
|
# achieved by treating normal Perl object reference (C++ std::unique_ptr<Foo> AKA Foo_ptr) as Perl object raw reference (C++ Foo* AKA Foo_rawptr) |
855
|
|
|
|
|
|
|
sub get_raw { |
856
|
0
|
|
|
0
|
0
|
0
|
( my $self ) = @ARG; |
857
|
0
|
|
|
|
|
0
|
return $self; |
858
|
|
|
|
|
|
|
} |
859
|
|
|
|
|
|
|
|
860
|
|
|
|
|
|
|
|
861
|
|
|
|
|
|
|
sub set_raw { |
862
|
0
|
|
|
0
|
0
|
0
|
( my $self, my $self_new ) = @ARG; |
863
|
0
|
|
|
|
|
0
|
%{$self} = %{$self_new}; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
864
|
|
|
|
|
|
|
} |
865
|
|
|
|
|
|
|
|
866
|
|
|
|
|
|
|
|
867
|
|
|
|
|
|
|
sub save_object_properties_types { |
868
|
1650
|
|
|
1650
|
0
|
4286
|
( my $package_name, my $object_properties_string, my $object_properties_types ) = @ARG; |
869
|
1650
|
100
|
|
|
|
5173
|
if ( $object_properties_string eq q{} ) { |
|
|
100
|
|
|
|
|
|
870
|
|
|
|
|
|
|
|
871
|
|
|
|
|
|
|
# RPerl::diag( 'in Class::save_object_properties_types(), have NO PROPERTIES $object_properties_string ' . "\n" ); |
872
|
|
|
|
|
|
|
} |
873
|
|
|
|
|
|
|
elsif ( $object_properties_string =~ /^\s*our\s+hashref\s+\$properties\s*=\s*\{\s*\}\;/xms ) { |
874
|
|
|
|
|
|
|
|
875
|
|
|
|
|
|
|
# RPerl::diag( 'in Class::save_object_properties_types(), have EMPTY PROPERTIES $object_properties_string = ' . "\n" . $object_properties_string . "\n" ); |
876
|
|
|
|
|
|
|
} |
877
|
|
|
|
|
|
|
else { |
878
|
35
|
|
|
|
|
89
|
my $object_property_key = undef; |
879
|
35
|
|
|
|
|
65
|
my $object_property_type = undef; |
880
|
35
|
|
|
|
|
79
|
my $object_property_inner_type_name = undef; |
881
|
|
|
|
|
|
|
|
882
|
35
|
|
|
|
|
251
|
$object_properties_string =~ s/^\s*our\s+hashref\s+\$properties\s*=\s*\{(.*)\}\;\s*$/$1/xms; # strip everything but hash entries |
883
|
|
|
|
|
|
|
|
884
|
|
|
|
|
|
|
# RPerl::diag( 'in Class::save_object_properties_types(), have NON-EMPTY PROPERTIES $object_properties_string = ' . "\n" . $object_properties_string . "\n\n" ); |
885
|
|
|
|
|
|
|
|
886
|
35
|
100
|
|
|
|
258
|
if ( $object_properties_string =~ /(\w+)\s*\=\>\s*my\s+([\w:]+)\s+\$TYPED_(\w+)/gxms ) { |
887
|
32
|
|
|
|
|
117
|
$object_property_key = $1; |
888
|
32
|
|
|
|
|
71
|
$object_property_type = $2; |
889
|
32
|
|
|
|
|
104
|
$object_property_inner_type_name = $3; |
890
|
|
|
|
|
|
|
} |
891
|
|
|
|
|
|
|
|
892
|
|
|
|
|
|
|
# RPerl::diag( 'in Class::save_object_properties_types(), before while() loop, have $object_property_key = ' . $object_property_key . "\n" ); |
893
|
|
|
|
|
|
|
# RPerl::diag( 'in Class::save_object_properties_types(), before while() loop, have $object_property_type = ' . $object_property_type . "\n" ); |
894
|
|
|
|
|
|
|
# RPerl::diag( 'in Class::save_object_properties_types(), before while() loop, have $object_property_inner_type_name = ' . $object_property_inner_type_name . "\n" ); |
895
|
|
|
|
|
|
|
|
896
|
35
|
|
66
|
|
|
298
|
while ( ( defined $object_property_key ) and ( defined $object_property_type ) and ( defined $object_property_inner_type_name ) ) { |
|
|
|
66
|
|
|
|
|
897
|
48
|
50
|
|
|
|
147
|
if ( $object_property_key ne $object_property_inner_type_name ) { |
898
|
|
|
|
|
|
|
# DEV NOTE, CORRELATION #rp030: matches numbering of ECOGEASCP20 in RPerl/CompileUnit/Module/Class/Generator.pm |
899
|
0
|
|
|
|
|
0
|
die 'ERROR ECOGEPPRP20, CODE GENERATOR, PURE PERL TO RPERL: redundant name mismatch, inner type name ' . q{'} |
900
|
|
|
|
|
|
|
. $object_property_inner_type_name . q{'} |
901
|
|
|
|
|
|
|
. ' does not equal OO properties key ' . q{'} |
902
|
|
|
|
|
|
|
. $object_property_key . q{'} |
903
|
|
|
|
|
|
|
. ', dying' . "\n"; |
904
|
|
|
|
|
|
|
} |
905
|
48
|
|
|
|
|
155
|
$object_properties_types->{$package_name}->{$object_property_key} = $object_property_type; |
906
|
|
|
|
|
|
|
|
907
|
48
|
100
|
|
|
|
204
|
if ( $object_properties_string =~ /(\w+)\s*\=\>\s*my\s+([\w:]+)\s+\$TYPED_(\w+)/gxms ) { |
908
|
16
|
|
|
|
|
37
|
$object_property_key = $1; |
909
|
16
|
|
|
|
|
31
|
$object_property_type = $2; |
910
|
16
|
|
|
|
|
59
|
$object_property_inner_type_name = $3; |
911
|
|
|
|
|
|
|
} |
912
|
|
|
|
|
|
|
else { |
913
|
32
|
|
|
|
|
67
|
$object_property_key = undef; |
914
|
32
|
|
|
|
|
69
|
$object_property_type = undef; |
915
|
32
|
|
|
|
|
94
|
$object_property_inner_type_name = undef; |
916
|
|
|
|
|
|
|
} |
917
|
|
|
|
|
|
|
|
918
|
|
|
|
|
|
|
# RPerl::diag( 'in Class::save_object_properties_types(), bottom of while() loop, have $object_property_key = ' . $object_property_key . "\n" ); |
919
|
|
|
|
|
|
|
# RPerl::diag( 'in Class::save_object_properties_types(), bottom of while() loop, have $object_property_type = ' . $object_property_type . "\n" ); |
920
|
|
|
|
|
|
|
# RPerl::diag( 'in Class::save_object_properties_types(), bottom of while() loop, have $object_property_inner_type_name = ' . $object_property_inner_type_name . "\n" ); |
921
|
|
|
|
|
|
|
} |
922
|
|
|
|
|
|
|
} |
923
|
1650
|
|
|
|
|
3128
|
return $object_properties_types; |
924
|
|
|
|
|
|
|
} |
925
|
|
|
|
|
|
|
|
926
|
|
|
|
|
|
|
|
927
|
|
|
|
|
|
|
# create Perl symbol table entries for RPerl subroutines and methods |
928
|
|
|
|
|
|
|
sub activate_subroutine_args_checking { |
929
|
2173
|
|
|
2173
|
0
|
6004
|
( my $package_name, my $subroutine_name, my $subroutine_type, my $subroutine_arguments_check_code, my $module_filename_long ) = @ARG; |
930
|
|
|
|
|
|
|
|
931
|
|
|
|
|
|
|
# RPerl::diag('in Class::activate_subroutine_args_checking(), received $package_name = ' . $package_name . "\n"); |
932
|
|
|
|
|
|
|
# RPerl::diag('in Class::activate_subroutine_args_checking(), received $subroutine_name = ' . $subroutine_name . "\n"); |
933
|
|
|
|
|
|
|
# RPerl::diag('in Class::activate_subroutine_args_checking(), received $subroutine_type = ' . $subroutine_type . "\n"); |
934
|
|
|
|
|
|
|
# RPerl::diag('in Class::activate_subroutine_args_checking(), received $subroutine_arguments_check_code = ' . $subroutine_arguments_check_code . "\n"); |
935
|
|
|
|
|
|
|
# RPerl::diag('in Class::activate_subroutine_args_checking(), received $module_filename_long = ' . $module_filename_long . "\n"); |
936
|
|
|
|
|
|
|
|
937
|
|
|
|
|
|
|
=DISABLED_NEED_FIX_DOUBLE_CHECKING |
938
|
|
|
|
|
|
|
|
939
|
|
|
|
|
|
|
if ((exists &{$package_name . '::__UNCHECKED_' . $subroutine_name}) or |
940
|
|
|
|
|
|
|
(exists &{$package_name . '::__CHECKED_' . $subroutine_name}) or |
941
|
|
|
|
|
|
|
(exists &{$package_name . '::__CHECK_CODE_' . $subroutine_name})) { |
942
|
|
|
|
|
|
|
RPerl::diag('in Class::activate_subroutine_args_checking(), SKIPPING already-activated subroutine ' . $package_name . '::' . $subroutine_name . "\n"); |
943
|
|
|
|
|
|
|
return; |
944
|
|
|
|
|
|
|
} |
945
|
|
|
|
|
|
|
else { RPerl::diag('in Class::activate_subroutine_args_checking(), NOT SKIPPING not-activated subroutine ' . $package_name . '::' . $subroutine_name . "\n"); } |
946
|
|
|
|
|
|
|
|
947
|
|
|
|
|
|
|
=cut |
948
|
|
|
|
|
|
|
|
949
|
2173
|
|
|
|
|
2921
|
my $package_name_tmp; # string |
950
|
2173
|
|
|
|
|
3023
|
my $subroutine_definition_code = q{}; # string |
951
|
2173
|
|
|
|
|
2867
|
my $subroutine_definition_diag_code = q{}; # string |
952
|
2173
|
|
|
|
|
2921
|
my $check_code_subroutine_name = q{}; # string |
953
|
|
|
|
|
|
|
|
954
|
2173
|
100
|
|
|
|
5525
|
if ( $subroutine_type =~ /\::method$/xms ) { |
955
|
|
|
|
|
|
|
# RPerl::diag("in Class::activate_subroutine_args_checking(), $subroutine_name is a method\n"); |
956
|
1349
|
50
|
|
|
|
2895
|
if ( $package_name eq q{} ) { |
957
|
0
|
|
|
|
|
0
|
croak( 'ERROR ECOPR01, PRE-PROCESSOR: Received no package name for method ', $subroutine_name, ' in file ' . $module_filename_long . ' ... croaking' ); |
958
|
|
|
|
|
|
|
} |
959
|
|
|
|
|
|
|
} |
960
|
|
|
|
|
|
|
else { |
961
|
|
|
|
|
|
|
# RPerl::diag("in Class::activate_subroutine_args_checking(), $subroutine_name is not a method\n"); |
962
|
|
|
|
|
|
|
# non-method subroutines which are not inside any package are actually in the 'main' package namespace |
963
|
824
|
50
|
|
|
|
1599
|
if ( $package_name eq q{} ) { $package_name = 'main'; } |
|
0
|
|
|
|
|
0
|
|
964
|
|
|
|
|
|
|
} |
965
|
|
|
|
|
|
|
|
966
|
|
|
|
|
|
|
# $subroutine_definition_diag_code = "\n " . q{RPerl::diag("IN POST-INIT, direct call MODE } . $package_name . '::' . $subroutine_name . q{\n"); }; |
967
|
|
|
|
|
|
|
|
968
|
|
|
|
|
|
|
=DEPRECATED |
969
|
|
|
|
|
|
|
# set symbol table entry for subroutine to new anonymous subroutine containing dereferenced call to real anonymous subroutine, old header style |
970
|
|
|
|
|
|
|
$subroutine_definition_code |
971
|
|
|
|
|
|
|
= '*{' |
972
|
|
|
|
|
|
|
. $package_name . '::' |
973
|
|
|
|
|
|
|
. $subroutine_name |
974
|
|
|
|
|
|
|
. '} = sub { ' |
975
|
|
|
|
|
|
|
. $subroutine_definition_diag_code |
976
|
|
|
|
|
|
|
. $subroutine_arguments_check_code |
977
|
|
|
|
|
|
|
. 'return &${' |
978
|
|
|
|
|
|
|
. $package_name . '::' |
979
|
|
|
|
|
|
|
. $subroutine_name |
980
|
|
|
|
|
|
|
. '(@ARG); };'; |
981
|
|
|
|
|
|
|
=cut |
982
|
|
|
|
|
|
|
|
983
|
|
|
|
|
|
|
# re-define subroutine call to include type checking code; new header style |
984
|
|
|
|
|
|
|
do |
985
|
2173
|
|
|
|
|
2659
|
{ |
986
|
7
|
|
|
7
|
|
70
|
no strict; |
|
7
|
|
|
|
|
18
|
|
|
7
|
|
|
|
|
1638
|
|
987
|
|
|
|
|
|
|
# create unchecked symbol table entry for original subroutine |
988
|
2173
|
|
|
|
|
2501
|
*{ $package_name . '::__UNCHECKED_' . $subroutine_name } = \&{ $package_name . '::' . $subroutine_name }; # short form, symbol table direct, not strict |
|
2173
|
|
|
|
|
15770
|
|
|
2173
|
|
|
|
|
11176
|
|
989
|
|
|
|
|
|
|
|
990
|
|
|
|
|
|
|
# delete original symtab entry, |
991
|
2173
|
|
|
|
|
3796
|
undef *{ $package_name . '::' . $subroutine_name }; |
|
2173
|
|
|
|
|
8007
|
|
992
|
|
|
|
|
|
|
|
993
|
|
|
|
|
|
|
# re-create new symtab entry pointing to checking code plus unchecked symtab entry |
994
|
2173
|
|
50
|
|
|
9589
|
$subroutine_definition_code .= |
995
|
|
|
|
|
|
|
'*' . $package_name . '::' . $subroutine_name . ' = sub { ' . |
996
|
|
|
|
|
|
|
$subroutine_definition_diag_code . |
997
|
|
|
|
|
|
|
($subroutine_arguments_check_code or "\n") . |
998
|
|
|
|
|
|
|
' return ' . $package_name . '::__UNCHECKED_' . $subroutine_name . '(@ARG);' . "\n" . '};'; |
999
|
|
|
|
|
|
|
|
1000
|
|
|
|
|
|
|
# create new checked symtab entries, for use by Exporter |
1001
|
2173
|
|
|
|
|
4070
|
$check_code_subroutine_name = $package_name . '::__CHECK_CODE_' . $subroutine_name; |
1002
|
2173
|
|
|
|
|
4809
|
$subroutine_definition_code .= "\n" . '*' . $package_name . '::__CHECKED_' . $subroutine_name . ' = \&' . $package_name . '::' . $subroutine_name . "\n" . ';'; |
1003
|
|
|
|
|
|
|
# ${ $check_code_subroutine_name } = $subroutine_arguments_check_code; # DOES NOT WORK |
1004
|
|
|
|
|
|
|
# $subroutine_definition_code .= "\n" . ' $' . $check_code_subroutine_name . q{ =<<'EOF';} . "\n" . $subroutine_arguments_check_code . "\n" . 'EOF' . "\n"; # DOES NOT WORK |
1005
|
|
|
|
|
|
|
# RPerl::diag('in Class::activate_subroutine_args_checking(), have $' . $check_code_subroutine_name . ' = ' . "\n" . '[BEGIN_CHECK_CODE]' . "\n" . ${ $check_code_subroutine_name } . "\n" . ' [END_CHECK_CODE]' . "\n"); |
1006
|
|
|
|
|
|
|
|
1007
|
2173
|
|
|
|
|
5082
|
$subroutine_definition_code .= "\n" . '*' . $check_code_subroutine_name . ' = sub {' . "\n" . ' my $retval ' . q{ =<<'EOF';} . "\n" . $subroutine_arguments_check_code . "\n" . 'EOF' . "\n" . '};' . "\n"; |
1008
|
|
|
|
|
|
|
}; |
1009
|
|
|
|
|
|
|
|
1010
|
|
|
|
|
|
|
# if ($subroutine_arguments_check_code ne q{}) { |
1011
|
|
|
|
|
|
|
# RPerl::diag('in Class::activate_subroutine_args_checking(), have method $subroutine_definition_code =' . "\n" . $subroutine_definition_code . "\n"); |
1012
|
|
|
|
|
|
|
# } |
1013
|
|
|
|
|
|
|
|
1014
|
|
|
|
|
|
|
# eval($subroutine_definition_code) or (croak 'ERROR ECOPR02, PRE-PROCESSOR: Failed to enable type checking for subroutine ' . $package_name . '::' . $subroutine_name . '(),' . "\n" . $EVAL_ERROR . "\n" . 'croaking'); # TRIGGERS FALSE ALARMS ON OUTPUT FROM RPerl::diag() |
1015
|
2173
|
50
|
|
0
|
|
214007
|
eval($subroutine_definition_code) or (RPerl::diag('ERROR ECOPR02, PRE-PROCESSOR: Possible failure to enable type checking for subroutine ' . $package_name . '::' . $subroutine_name . '(),' . "\n" . $EVAL_ERROR . "\n" . 'not croaking')); |
|
0
|
|
|
|
|
0
|
|
|
726
|
|
|
|
|
7793
|
|
|
1
|
|
|
|
|
4
|
|
|
0
|
|
|
|
|
0
|
|
|
1
|
|
|
|
|
46
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
302
|
|
|
|
|
133380
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
9
|
|
|
|
|
483
|
|
|
0
|
|
|
|
|
0
|
|
|
3
|
|
|
|
|
10
|
|
|
2
|
|
|
|
|
6
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
1
|
|
|
|
|
11
|
|
|
0
|
|
|
|
|
0
|
|
|
98
|
|
|
|
|
687
|
|
|
0
|
|
|
|
|
0
|
|
|
5
|
|
|
|
|
180
|
|
|
0
|
|
|
|
|
0
|
|
|
1518
|
|
|
|
|
9378
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
13
|
|
|
|
|
101
|
|
|
74
|
|
|
|
|
472
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
1
|
|
|
|
|
12
|
|
|
1578
|
|
|
|
|
1352427
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
37
|
|
|
|
|
376
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
54
|
|
|
|
|
438
|
|
|
20
|
|
|
|
|
58
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
11
|
|
|
|
|
92
|
|
|
19
|
|
|
|
|
57
|
|
|
1330
|
|
|
|
|
48948
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
6152
|
|
|
|
|
140623
|
|
|
0
|
|
|
|
|
0
|
|
|
39
|
|
|
|
|
171
|
|
|
2
|
|
|
|
|
13
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
3
|
|
|
|
|
36
|
|
|
27
|
|
|
|
|
213
|
|
|
5
|
|
|
|
|
30
|
|
|
0
|
|
|
|
|
0
|
|
|
1418
|
|
|
|
|
6038
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
10
|
|
|
|
|
410
|
|
|
23
|
|
|
|
|
204
|
|
|
676
|
|
|
|
|
22111
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
44
|
|
|
|
|
312
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
638
|
|
|
|
|
183172
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
52
|
|
|
|
|
180
|
|
|
87
|
|
|
|
|
702
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
10
|
|
|
|
|
398
|
|
|
726
|
|
|
|
|
5554
|
|
|
180
|
|
|
|
|
785
|
|
|
5
|
|
|
|
|
193
|
|
|
0
|
|
|
|
|
0
|
|
|
2
|
|
|
|
|
28
|
|
|
2122
|
|
|
|
|
9344
|
|
|
0
|
|
|
|
|
0
|
|
|
64
|
|
|
|
|
345
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
5
|
|
|
|
|
182
|
|
|
1
|
|
|
|
|
5
|
|
|
1
|
|
|
|
|
17
|
|
|
102
|
|
|
|
|
461
|
|
|
0
|
|
|
|
|
0
|
|
|
428
|
|
|
|
|
3746
|
|
|
0
|
|
|
|
|
0
|
|
|
1062
|
|
|
|
|
7137
|
|
|
1
|
|
|
|
|
4
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
30
|
|
|
|
|
69
|
|
|
0
|
|
|
|
|
0
|
|
|
503
|
|
|
|
|
2447
|
|
|
23
|
|
|
|
|
55
|
|
|
103
|
|
|
|
|
575
|
|
|
0
|
|
|
|
|
0
|
|
|
118
|
|
|
|
|
46757
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
23
|
|
|
|
|
76
|
|
|
23
|
|
|
|
|
219
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
1
|
|
|
|
|
100
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
2
|
|
|
|
|
1871
|
|
|
5
|
|
|
|
|
229
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
7
|
|
|
|
|
6869
|
|
|
0
|
|
|
|
|
0
|
|
|
23
|
|
|
|
|
72
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
4
|
|
|
|
|
1918
|
|
|
134
|
|
|
|
|
806
|
|
|
4333
|
|
|
|
|
17633
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
1518
|
|
|
|
|
166197
|
|
|
106
|
|
|
|
|
436
|
|
|
0
|
|
|
|
|
0
|
|
|
3
|
|
|
|
|
23
|
|
|
1
|
|
|
|
|
5
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
2
|
|
|
|
|
1884
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
39
|
|
|
|
|
211
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
19
|
|
|
|
|
59
|
|
|
0
|
|
|
|
|
0
|
|
|
1
|
|
|
|
|
43
|
|
|
15
|
|
|
|
|
42
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
1
|
|
|
|
|
19
|
|
|
0
|
|
|
|
|
0
|
|
|
1
|
|
|
|
|
50
|
|
|
1
|
|
|
|
|
36
|
|
|
1
|
|
|
|
|
45
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
15
|
|
|
|
|
41
|
|
|
0
|
|
|
|
|
0
|
|
|
2
|
|
|
|
|
5438
|
|
|
0
|
|
|
|
|
0
|
|
|
1244
|
|
|
|
|
9164
|
|
|
0
|
|
|
|
|
0
|
|
|
4
|
|
|
|
|
49
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
9
|
|
|
|
|
43
|
|
|
0
|
|
|
|
|
0
|
|
|
38
|
|
|
|
|
254
|
|
|
16
|
|
|
|
|
102
|
|
|
0
|
|
|
|
|
0
|
|
|
28
|
|
|
|
|
100
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
1
|
|
|
|
|
20
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
1
|
|
|
|
|
50
|
|
|
32
|
|
|
|
|
122
|
|
|
3
|
|
|
|
|
24
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
25
|
|
|
|
|
77
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
2
|
|
|
|
|
13
|
|
|
278
|
|
|
|
|
1136
|
|
|
5
|
|
|
|
|
175
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
158
|
|
|
|
|
683
|
|
|
6
|
|
|
|
|
61
|
|
1016
|
2173
|
50
|
|
|
|
8913
|
if ($EVAL_ERROR) { croak 'ERROR ECOPR03, PRE-PROCESSOR: Failed to enable type checking for subroutine ' . $package_name . '::' . $subroutine_name . '(),' . "\n" . $EVAL_ERROR . "\n" . 'croaking'; } |
|
0
|
|
|
|
|
0
|
|
1017
|
|
|
|
|
|
|
|
1018
|
|
|
|
|
|
|
# do { no strict; |
1019
|
|
|
|
|
|
|
# RPerl::diag('in Class::activate_subroutine_args_checking(), have ' . $check_code_subroutine_name . '() = ' . "\n" . '[BEGIN_CHECK_CODE]' . "\n" . &{ $check_code_subroutine_name } . "\n" . ' [END_CHECK_CODE]' . "\n"); |
1020
|
|
|
|
|
|
|
# }; |
1021
|
|
|
|
|
|
|
|
1022
|
|
|
|
|
|
|
# DEPRECATED, CORRELATION #rp120: old subroutine header |
1023
|
|
|
|
|
|
|
# do not automatically export non-method subroutines because that is non-standard behavior, only provide standard Perl behavior |
1024
|
|
|
|
|
|
|
=DEPRECATED |
1025
|
|
|
|
|
|
|
if ( $subroutine_type =~ /\::method$/xms ) { |
1026
|
|
|
|
|
|
|
if ( $package_name eq '' ) { |
1027
|
|
|
|
|
|
|
croak( 'Received no package name for method ', $subroutine_name, ' in file ' . $module_filename_long . ' ... croaking' ); |
1028
|
|
|
|
|
|
|
} |
1029
|
|
|
|
|
|
|
|
1030
|
|
|
|
|
|
|
# $subroutine_definition_diag_code = "\n" . q{RPerl::diag("IN POST-INIT, method direct call MODE } . $package_name . '::' . $subroutine_name . q{\n"); } . "\n"; |
1031
|
|
|
|
|
|
|
# RPerl::diag("in Class::activate_subroutine_args_checking(), $subroutine_name is a method\n"); |
1032
|
|
|
|
|
|
|
# NEED UPGRADE: is it possible to activate non-type-checked RPerl subroutines & methods w/out creating new subroutines? |
1033
|
|
|
|
|
|
|
$subroutine_definition_code |
1034
|
|
|
|
|
|
|
= '*{' |
1035
|
|
|
|
|
|
|
. $package_name . '::' |
1036
|
|
|
|
|
|
|
. $subroutine_name |
1037
|
|
|
|
|
|
|
. '} = sub { ' |
1038
|
|
|
|
|
|
|
. $subroutine_definition_diag_code |
1039
|
|
|
|
|
|
|
. $subroutine_arguments_check_code |
1040
|
|
|
|
|
|
|
. 'return &${' |
1041
|
|
|
|
|
|
|
. $package_name . '::' |
1042
|
|
|
|
|
|
|
. $subroutine_name |
1043
|
|
|
|
|
|
|
. '}(@ARG); };'; |
1044
|
|
|
|
|
|
|
|
1045
|
|
|
|
|
|
|
# if ($subroutine_arguments_check_code ne q{}) { RPerl::diag('in Class::activate_subroutine_args_checking(), have method $subroutine_definition_code =' . "\n" . $subroutine_definition_code . "\n"); } |
1046
|
|
|
|
|
|
|
eval($subroutine_definition_code) |
1047
|
|
|
|
|
|
|
or croak($EVAL_ERROR); |
1048
|
|
|
|
|
|
|
if ($EVAL_ERROR) { croak($EVAL_ERROR); } |
1049
|
|
|
|
|
|
|
} |
1050
|
|
|
|
|
|
|
else { |
1051
|
|
|
|
|
|
|
# RPerl::diag( "in Class::activate_subroutine_args_checking(), $subroutine_name is a non-method subroutine\n" ); |
1052
|
|
|
|
|
|
|
if ( eval( 'defined(&main::' . $subroutine_name . ')' ) ) { |
1053
|
|
|
|
|
|
|
croak |
1054
|
|
|
|
|
|
|
"ERROR ECOPR00, PRE-PROCESSOR: Attempt by package '$package_name' to re-define shared global subroutine '$subroutine_name', please re-name your subroutine or make it a method, croaking"; |
1055
|
|
|
|
|
|
|
} |
1056
|
|
|
|
|
|
|
|
1057
|
|
|
|
|
|
|
# DEV NOTE: must load into both main:: and $package_name:: namespaces, |
1058
|
|
|
|
|
|
|
# in order to call subroutines w/out class prefix from within class file (package) itself, and not to use AUTOLOAD |
1059
|
|
|
|
|
|
|
if ( $package_name eq '' ) { $package_name_tmp = 'main'; } |
1060
|
|
|
|
|
|
|
else { $package_name_tmp = $package_name; } |
1061
|
|
|
|
|
|
|
|
1062
|
|
|
|
|
|
|
# $subroutine_definition_diag_code = "\n" . q{RPerl::diag("IN POST-INIT, subroutine direct call MODE main::} . $subroutine_name . q{\n"; } . "\n"); |
1063
|
|
|
|
|
|
|
$subroutine_definition_code |
1064
|
|
|
|
|
|
|
= '*{main::' |
1065
|
|
|
|
|
|
|
. $subroutine_name |
1066
|
|
|
|
|
|
|
. '} = sub { ' |
1067
|
|
|
|
|
|
|
. $subroutine_definition_diag_code |
1068
|
|
|
|
|
|
|
. $subroutine_arguments_check_code |
1069
|
|
|
|
|
|
|
. 'return &${' |
1070
|
|
|
|
|
|
|
. $package_name_tmp . '::' |
1071
|
|
|
|
|
|
|
. $subroutine_name |
1072
|
|
|
|
|
|
|
. '}(@ARG); };'; |
1073
|
|
|
|
|
|
|
|
1074
|
|
|
|
|
|
|
# if ($subroutine_arguments_check_code ne q{}) { RPerl::diag('in Class::activate_subroutine_args_checking(), have subroutine main:: $subroutine_definition_code =' . "\n" . $subroutine_definition_code . "\n"); } |
1075
|
|
|
|
|
|
|
eval($subroutine_definition_code) |
1076
|
|
|
|
|
|
|
or croak($EVAL_ERROR); |
1077
|
|
|
|
|
|
|
if ($EVAL_ERROR) { croak($EVAL_ERROR); } |
1078
|
|
|
|
|
|
|
|
1079
|
|
|
|
|
|
|
# no package name means 'main', handled above |
1080
|
|
|
|
|
|
|
if ( $package_name ne '' ) { |
1081
|
|
|
|
|
|
|
|
1082
|
|
|
|
|
|
|
# $subroutine_definition_diag_code = "\n" . {RPerl::diag("IN POST-INIT, subroutine direct call MODE } . $package_name . '::' . $subroutine_name . q{\n"; } . "\n"); |
1083
|
|
|
|
|
|
|
$subroutine_definition_code |
1084
|
|
|
|
|
|
|
= '*{' |
1085
|
|
|
|
|
|
|
. $package_name . '::' |
1086
|
|
|
|
|
|
|
. $subroutine_name |
1087
|
|
|
|
|
|
|
. '} = sub {' |
1088
|
|
|
|
|
|
|
. $subroutine_definition_diag_code |
1089
|
|
|
|
|
|
|
. $subroutine_arguments_check_code |
1090
|
|
|
|
|
|
|
. 'return &${' |
1091
|
|
|
|
|
|
|
. $package_name . '::' |
1092
|
|
|
|
|
|
|
. $subroutine_name |
1093
|
|
|
|
|
|
|
. '}(@ARG); };'; |
1094
|
|
|
|
|
|
|
|
1095
|
|
|
|
|
|
|
# if ($subroutine_arguments_check_code ne q{}) { |
1096
|
|
|
|
|
|
|
# RPerl::diag('in Class::activate_subroutine_args_checking(), have subroutine package:: $subroutine_definition_code =' . "\n" . $subroutine_definition_code . "\n"); |
1097
|
|
|
|
|
|
|
# } |
1098
|
|
|
|
|
|
|
eval($subroutine_definition_code) |
1099
|
|
|
|
|
|
|
or croak($EVAL_ERROR); |
1100
|
|
|
|
|
|
|
if ($EVAL_ERROR) { croak($EVAL_ERROR); } |
1101
|
|
|
|
|
|
|
} |
1102
|
|
|
|
|
|
|
} |
1103
|
|
|
|
|
|
|
=cut |
1104
|
|
|
|
|
|
|
} |
1105
|
|
|
|
|
|
|
|
1106
|
|
|
|
|
|
|
1; # end of class |
1107
|
|
|
|
|
|
|
|
1108
|
|
|
|
|
|
|
__END__ |
1109
|
|
|
|
|
|
|
|
1110
|
|
|
|
|
|
|
|
1111
|
|
|
|
|
|
|
# RPerl function/method autoloader, LONG FORM; allows syntax for typed functions/methods and automates get/set accessors/mutators for object properties; |
1112
|
|
|
|
|
|
|
# creates real subroutines to avoid AUTOLOADing any function/method more than once, performs operation inside AUTOLOAD that one time |
1113
|
|
|
|
|
|
|
# now fully deprecated in favor of INIT block above |
1114
|
|
|
|
|
|
|
our $AUTOLOAD; |
1115
|
|
|
|
|
|
|
sub AUTOLOAD |
1116
|
|
|
|
|
|
|
{ |
1117
|
|
|
|
|
|
|
RPerl::diag("IN AUTOLOAD, top of subroutine, received \$AUTOLOAD = '$AUTOLOAD', and \@ARG =\n" . Dumper(\@ARG) . "\n"); |
1118
|
|
|
|
|
|
|
no strict; |
1119
|
|
|
|
|
|
|
my $retval; |
1120
|
|
|
|
|
|
|
|
1121
|
|
|
|
|
|
|
# DISABLE RUNTIME ACCESSOR/MUTATOR BEHAVIOR |
1122
|
|
|
|
|
|
|
# if ($AUTOLOAD =~ /^([\w+::]*)(get|set)_(\w+)$/) |
1123
|
|
|
|
|
|
|
if (0) |
1124
|
|
|
|
|
|
|
{ |
1125
|
|
|
|
|
|
|
RPerl::diag("IN AUTOLOAD, accessor/mutator MODE, have \$1 = '$1', \$2 = '$2', \$3 = '$3'\n"); |
1126
|
|
|
|
|
|
|
if ($2 eq 'get') |
1127
|
|
|
|
|
|
|
{ |
1128
|
|
|
|
|
|
|
RPerl::diag("IN AUTOLOAD, accessor MODE\n"); |
1129
|
|
|
|
|
|
|
# eval "\*\{$AUTOLOAD\} \= sub \{ return \$\_\[0\]\-\>\{$3\}\; \}\;"; |
1130
|
|
|
|
|
|
|
eval "\*\{$AUTOLOAD\} \= sub \{ RPerl::diag(\"IN POST\-AUTOLOAD\, accessor MODE $AUTOLOAD\\n\"\; return \$\_\[0\]\-\>\{$3\}\; \}\;"; |
1131
|
|
|
|
|
|
|
$retval = $_[0]->{$3}; |
1132
|
|
|
|
|
|
|
} |
1133
|
|
|
|
|
|
|
else # ($2 eq 'set') |
1134
|
|
|
|
|
|
|
{ |
1135
|
|
|
|
|
|
|
RPerl::diag("IN AUTOLOAD, mutator MODE\n"); |
1136
|
|
|
|
|
|
|
# eval "\*\{$AUTOLOAD\} \= sub \{ \$\_\[0\]\-\>\{$3\} \= \$\_\[1\]\; return \$\_\[0\]\-\>\{$3\}\; \}\;"; |
1137
|
|
|
|
|
|
|
eval "\*\{$AUTOLOAD\} \= sub \{ RPerl::diag(\"IN POST\-AUTOLOAD\, mutator MODE $AUTOLOAD\\n\"\; \$\_\[0\]\-\>\{$3\} \= \$\_\[1\]\; return \$\_\[0\]\-\>\{$3\}\; \}\;"; |
1138
|
|
|
|
|
|
|
$_[0]->{$3} = $_[1]; |
1139
|
|
|
|
|
|
|
$retval = $_[0]->{$3}; |
1140
|
|
|
|
|
|
|
} |
1141
|
|
|
|
|
|
|
} |
1142
|
|
|
|
|
|
|
else |
1143
|
|
|
|
|
|
|
{ |
1144
|
|
|
|
|
|
|
RPerl::diag("IN AUTOLOAD, direct call MODE\n"); |
1145
|
|
|
|
|
|
|
# disable creating symtab entries here to avoid redefining subroutines in INIT block above; |
1146
|
|
|
|
|
|
|
# still need direct call mode here in case we want to call an RPerl function/method before the INIT block executes, |
1147
|
|
|
|
|
|
|
# such as when an RPerl class calls one of it's own functions/methods during compile time |
1148
|
|
|
|
|
|
|
# eval "\*\{$AUTOLOAD\} \= sub \{ return \&\$\{$AUTOLOAD\}\(\@\_\)\; \}\;"; # NEED UPGRADE: how can I do this w/out a subroutine? |
1149
|
|
|
|
|
|
|
# eval "\*\{$AUTOLOAD\} \= sub \{ RPerl::diag(\"IN POST\-AUTOLOAD\, direct call MODE $AUTOLOAD\\n\"\; return \&\$\{$AUTOLOAD\}\(\@\_\)\; \}\;"; # NEED UPGRADE: how can I do this w/out a subroutine? |
1150
|
|
|
|
|
|
|
if (defined(${$AUTOLOAD})) { $retval = &${$AUTOLOAD}(@ARG); } |
1151
|
|
|
|
|
|
|
else { die "Attempt to AUTOLOAD undefined subroutine '$AUTOLOAD', dying"; } |
1152
|
|
|
|
|
|
|
} |
1153
|
|
|
|
|
|
|
# is there any reason to encapsulate calls in an eval() to trap their errors??? |
1154
|
|
|
|
|
|
|
# else |
1155
|
|
|
|
|
|
|
# { |
1156
|
|
|
|
|
|
|
# my $eval_string = '&$' . $AUTOLOAD . '(@ARG);'; |
1157
|
|
|
|
|
|
|
# RPerl::diag("IN AUTOLOAD, eval call MODE, have \$eval_string = '$eval_string'\n"); |
1158
|
|
|
|
|
|
|
# $retval = eval $eval_string; |
1159
|
|
|
|
|
|
|
# } |
1160
|
|
|
|
|
|
|
|
1161
|
|
|
|
|
|
|
croak $EVAL_ERROR if ($EVAL_ERROR); # suppress '...propagated at RPerl/Class.pm' appended exception |
1162
|
|
|
|
|
|
|
# croak if ($EVAL_ERROR); # allow '...propagated at RPerl/Class.pm' appended exception |
1163
|
|
|
|
|
|
|
|
1164
|
|
|
|
|
|
|
# RPerl::diag("IN AUTOLOAD, bottom of subroutine, about to return \$retval = '$retval'\n"); |
1165
|
|
|
|
|
|
|
return $retval; |
1166
|
|
|
|
|
|
|
} |
1167
|
|
|
|
|
|
|
|
1168
|
|
|
|
|
|
|
|
1169
|
|
|
|
|
|
|
# RPerl object constructor, LONG FORM |
1170
|
|
|
|
|
|
|
# DEPRECATED still uses %properties hash instead of $properties hashref, does not support property initialization values |
1171
|
|
|
|
|
|
|
#sub new($class_name_const_str) |
1172
|
|
|
|
|
|
|
sub new_LONG FORM |
1173
|
|
|
|
|
|
|
{ |
1174
|
|
|
|
|
|
|
(my $class_name_const_str) = @ARG; |
1175
|
|
|
|
|
|
|
RPerl::diag("in Class.pm, have \$class_name_const_str = '$class_name_const_str'\n"); |
1176
|
|
|
|
|
|
|
my $properties_name_const_str = $class_name_const_str . '::properties'; |
1177
|
|
|
|
|
|
|
RPerl::diag("in Class.pm, have \$properties_name_const_str = '$properties_name_const_str'\n"); |
1178
|
|
|
|
|
|
|
my %properties = %{$properties_name_const_str}; |
1179
|
|
|
|
|
|
|
RPerl::diag("in Class.pm, have \%properties =\n" . Dumper(\%properties) . "\n"); |
1180
|
|
|
|
|
|
|
# my $new_obj = bless({%{$class_name_const_str . '::properties'}}, $class_name_const_str); |
1181
|
|
|
|
|
|
|
my $new_obj = bless({%properties}, $class_name_const_str); |
1182
|
|
|
|
|
|
|
RPerl::diag("in Class.pm, have \$new_obj =\n" . Dumper($new_obj) . "\n"); |
1183
|
|
|
|
|
|
|
return $new_obj; |
1184
|
|
|
|
|
|
|
} |