line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# You may distribute under the terms of either the GNU General Public License |
2
|
|
|
|
|
|
|
# or the Artistic License (the same terms as Perl itself) |
3
|
|
|
|
|
|
|
# |
4
|
|
|
|
|
|
|
# (C) Paul Evans, 2012-2020 -- leonerd@leonerd.org.uk |
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
package Struct::Dumb; |
7
|
|
|
|
|
|
|
|
8
|
7
|
|
|
7
|
|
352962
|
use strict; |
|
7
|
|
|
|
|
59
|
|
|
7
|
|
|
|
|
166
|
|
9
|
7
|
|
|
7
|
|
26
|
use warnings; |
|
7
|
|
|
|
|
10
|
|
|
7
|
|
|
|
|
236
|
|
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
our $VERSION = '0.12'; |
12
|
|
|
|
|
|
|
|
13
|
7
|
|
|
7
|
|
34
|
use Carp; |
|
7
|
|
|
|
|
7
|
|
|
7
|
|
|
|
|
403
|
|
14
|
|
|
|
|
|
|
|
15
|
7
|
|
|
7
|
|
50
|
use Scalar::Util qw( refaddr ); |
|
7
|
|
|
|
|
10
|
|
|
7
|
|
|
|
|
366
|
|
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
# 'overloading.pm' was only added in 5.10 |
18
|
|
|
|
|
|
|
# Before that we can't easily implement forbidding of @{} overload, so lets not |
19
|
7
|
|
|
7
|
|
72
|
use constant HAVE_OVERLOADING => eval { require overloading }; |
|
7
|
|
|
|
|
18
|
|
|
7
|
|
|
|
|
9
|
|
|
7
|
|
|
|
|
1921
|
|
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
=head1 NAME |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
C - make simple lightweight record-like structures |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
=head1 SYNOPSIS |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
use Struct::Dumb; |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
struct Point => [qw( x y )]; |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
my $point = Point(10, 20); |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
printf "Point is at (%d, %d)\n", $point->x, $point->y; |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
$point->y = 30; |
36
|
|
|
|
|
|
|
printf "Point is now at (%d, %d)\n", $point->x, $point->y; |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
Z<> |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
struct Point3D => [qw( x y z )], named_constructor => 1; |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
my $point3d = Point3D( z => 12, x => 100, y => 50 ); |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
printf "Point3d's height is %d\n", $point3d->z; |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
Z<> |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
struct Point3D => [qw( x y z )], predicate => "is_Point3D"; |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
my $point3d = Point3D( 1, 2, 3 ); |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
printf "This is a Point3D\n" if is_Point3D( $point3d ); |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
Z<> |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
use Struct::Dumb qw( -named_constructors ) |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
struct Point3D => [qw( x y z )]; |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
my $point3d = Point3D( x => 100, z => 12, y => 50 ); |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
=head1 DESCRIPTION |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
C creates record-like structure types, similar to the C |
65
|
|
|
|
|
|
|
keyword in C, C++ or C#, or C in Pascal. An invocation of this module |
66
|
|
|
|
|
|
|
will create a construction function which returns new object references with |
67
|
|
|
|
|
|
|
the given field values. These references all respond to lvalue methods that |
68
|
|
|
|
|
|
|
access or modify the values stored. |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
It's specifically and intentionally not meant to be an object class. You |
71
|
|
|
|
|
|
|
cannot subclass it. You cannot provide additional methods. You cannot apply |
72
|
|
|
|
|
|
|
roles or mixins or metaclasses or traits or antlers or whatever else is in |
73
|
|
|
|
|
|
|
fashion this week. |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
On the other hand, it is tiny, creates cheap lightweight array-backed |
76
|
|
|
|
|
|
|
structures, uses nothing outside of core. It's intended simply to be a |
77
|
|
|
|
|
|
|
slightly nicer way to store data structures, where otherwise you might be |
78
|
|
|
|
|
|
|
tempted to abuse a hash, complete with the risk of typoing key names. The |
79
|
|
|
|
|
|
|
constructor will C if passed the wrong number of arguments, as will |
80
|
|
|
|
|
|
|
attempts to refer to fields that don't exist. Accessor-mutators will C |
81
|
|
|
|
|
|
|
if invoked with arguments. (This helps detect likely bugs such as accidentally |
82
|
|
|
|
|
|
|
passing in the new value as an argument, or attempting to invoke a stored |
83
|
|
|
|
|
|
|
C reference by passing argument values directly to the accessor.) |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
$ perl -E 'use Struct::Dumb; struct Point => [qw( x y )]; Point(30)' |
86
|
|
|
|
|
|
|
usage: main::Point($x, $y) at -e line 1 |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
$ perl -E 'use Struct::Dumb; struct Point => [qw( x y )]; Point(10,20)->z' |
89
|
|
|
|
|
|
|
main::Point does not have a 'z' field at -e line 1 |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
$ perl -E 'use Struct::Dumb; struct Point => [qw( x y )]; Point(1,2)->x(3)' |
92
|
|
|
|
|
|
|
main::Point->x invoked with arguments at -e line 1. |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
Objects in this class are (currently) backed by an ARRAY reference store, |
95
|
|
|
|
|
|
|
though this is an internal implementation detail and should not be relied on |
96
|
|
|
|
|
|
|
by using code. Attempting to dereference the object as an ARRAY will throw an |
97
|
|
|
|
|
|
|
exception. |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
=head2 CONSTRUCTOR FORMS |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
The C and C declarations create two different kinds |
102
|
|
|
|
|
|
|
of constructor function, depending on the setting of the C |
103
|
|
|
|
|
|
|
option. When false, the constructor takes positional values in the same order |
104
|
|
|
|
|
|
|
as the fields were declared. When true, the constructor takes a key/value pair |
105
|
|
|
|
|
|
|
list in no particular order, giving the value of each named field. |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
This option can be specified to the C and C |
108
|
|
|
|
|
|
|
functions. It defaults to false, but it can be set on a per-package basis to |
109
|
|
|
|
|
|
|
default true by supplying the C<-named_constructors> option on the C |
110
|
|
|
|
|
|
|
statement. |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
When using named constructors, individual fields may be declared as being |
113
|
|
|
|
|
|
|
optional. By preceeding the field name with a C> character, the constructor |
114
|
|
|
|
|
|
|
is instructed not to complain if a named parameter is not given for that |
115
|
|
|
|
|
|
|
field; instead it will be set to C. |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
struct Person => [qw( name age ?address )], |
118
|
|
|
|
|
|
|
named_constructor => 1; |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
my $bob = Person( name => "Bob", age => 20 ); |
121
|
|
|
|
|
|
|
# This is valid because 'address' is marked as optional |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
=cut |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
sub import |
126
|
|
|
|
|
|
|
{ |
127
|
10
|
|
|
10
|
|
60
|
my $pkg = shift; |
128
|
10
|
|
|
|
|
18
|
my $caller = caller; |
129
|
|
|
|
|
|
|
|
130
|
10
|
|
|
|
|
13
|
my %default_opts; |
131
|
|
|
|
|
|
|
my %syms; |
132
|
|
|
|
|
|
|
|
133
|
10
|
|
|
|
|
20
|
foreach ( @_ ) { |
134
|
2
|
100
|
|
|
|
6
|
if( $_ eq "-named_constructors" ) { |
135
|
1
|
|
|
|
|
2
|
$default_opts{named_constructor} = 1; |
136
|
|
|
|
|
|
|
} |
137
|
|
|
|
|
|
|
else { |
138
|
1
|
|
|
|
|
3
|
$syms{$_}++; |
139
|
|
|
|
|
|
|
} |
140
|
|
|
|
|
|
|
} |
141
|
|
|
|
|
|
|
|
142
|
10
|
100
|
|
|
|
40
|
keys %syms or $syms{struct}++; |
143
|
|
|
|
|
|
|
|
144
|
10
|
|
|
|
|
25
|
my %export; |
145
|
|
|
|
|
|
|
|
146
|
10
|
100
|
|
|
|
28
|
if( delete $syms{struct} ) { |
147
|
|
|
|
|
|
|
$export{struct} = sub { |
148
|
7
|
|
|
7
|
|
1242
|
my ( $name, $fields, @opts ) = @_; |
149
|
7
|
|
|
|
|
33
|
_struct( $name, $fields, scalar caller, lvalue => 1, %default_opts, @opts ); |
150
|
9
|
|
|
|
|
35
|
}; |
151
|
|
|
|
|
|
|
} |
152
|
10
|
100
|
|
|
|
39
|
if( delete $syms{readonly_struct} ) { |
153
|
|
|
|
|
|
|
$export{readonly_struct} = sub { |
154
|
1
|
|
|
1
|
|
71
|
my ( $name, $fields, @opts ) = @_; |
155
|
1
|
|
|
|
|
6
|
_struct( $name, $fields, scalar caller, lvalue => 0, %default_opts, @opts ); |
156
|
1
|
|
|
|
|
4
|
}; |
157
|
|
|
|
|
|
|
} |
158
|
|
|
|
|
|
|
|
159
|
10
|
50
|
|
|
|
20
|
if( keys %syms ) { |
160
|
0
|
|
|
|
|
0
|
croak "Unrecognised export symbols " . join( ", ", keys %syms ); |
161
|
|
|
|
|
|
|
} |
162
|
|
|
|
|
|
|
|
163
|
7
|
|
|
7
|
|
41
|
no strict 'refs'; |
|
7
|
|
|
|
|
12
|
|
|
7
|
|
|
|
|
2685
|
|
164
|
10
|
|
|
|
|
26
|
*{"${caller}::$_"} = $export{$_} for keys %export; |
|
10
|
|
|
|
|
5556
|
|
165
|
|
|
|
|
|
|
} |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
=head1 FUNCTIONS |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
=cut |
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
my %_STRUCT_PACKAGES; |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
sub _struct |
174
|
|
|
|
|
|
|
{ |
175
|
8
|
|
|
8
|
|
31
|
my ( $name, $_fields, $caller, %opts ) = @_; |
176
|
|
|
|
|
|
|
|
177
|
8
|
|
|
|
|
16
|
my $lvalue = !!$opts{lvalue}; |
178
|
8
|
|
|
|
|
18
|
my $named = !!$opts{named_constructor}; |
179
|
|
|
|
|
|
|
|
180
|
8
|
|
|
|
|
23
|
my $pkg = "${caller}::$name"; |
181
|
|
|
|
|
|
|
|
182
|
8
|
|
|
|
|
17
|
my @fields = @$_fields; |
183
|
|
|
|
|
|
|
|
184
|
8
|
|
|
|
|
11
|
my %optional; |
185
|
8
|
|
66
|
|
|
43
|
s/^\?// and $optional{$_}++ for @fields; |
186
|
|
|
|
|
|
|
|
187
|
8
|
|
|
|
|
11
|
my $constructor; |
188
|
8
|
100
|
|
|
|
20
|
if( $named ) { |
189
|
|
|
|
|
|
|
$constructor = sub { |
190
|
6
|
|
|
6
|
|
1598
|
my %values = @_; |
191
|
6
|
|
|
|
|
9
|
my @values; |
192
|
6
|
|
|
|
|
25
|
foreach ( @fields ) { |
193
|
18
|
100
|
100
|
|
|
209
|
exists $values{$_} or $optional{$_} or |
194
|
|
|
|
|
|
|
croak "usage: $pkg requires '$_'"; |
195
|
17
|
|
|
|
|
32
|
push @values, delete $values{$_}; |
196
|
|
|
|
|
|
|
} |
197
|
5
|
100
|
|
|
|
12
|
if( my ( $extrakey ) = keys %values ) { |
198
|
1
|
|
|
|
|
87
|
croak "usage: $pkg does not recognise '$extrakey'"; |
199
|
|
|
|
|
|
|
} |
200
|
4
|
|
|
|
|
11
|
bless \@values, $pkg; |
201
|
3
|
|
|
|
|
13
|
}; |
202
|
|
|
|
|
|
|
} |
203
|
|
|
|
|
|
|
else { |
204
|
5
|
|
|
|
|
8
|
my $fieldcount = @fields; |
205
|
5
|
|
|
|
|
28
|
my $argnames = join ", ", map "\$$_", @fields; |
206
|
|
|
|
|
|
|
$constructor = sub { |
207
|
9
|
100
|
|
9
|
|
2294
|
@_ == $fieldcount or croak "usage: $pkg($argnames)"; |
208
|
8
|
|
|
|
|
80
|
bless [ @_ ], $pkg; |
209
|
5
|
|
|
|
|
24
|
}; |
210
|
|
|
|
|
|
|
} |
211
|
|
|
|
|
|
|
|
212
|
8
|
|
|
|
|
14
|
my %subs; |
213
|
8
|
|
|
|
|
27
|
foreach ( 0 .. $#fields ) { |
214
|
20
|
|
|
|
|
26
|
my $idx = $_; |
215
|
20
|
|
|
|
|
30
|
my $field = $fields[$idx]; |
216
|
|
|
|
|
|
|
|
217
|
|
|
|
|
|
|
BEGIN { |
218
|
7
|
|
|
7
|
|
1587
|
overloading->unimport if HAVE_OVERLOADING; |
219
|
|
|
|
|
|
|
} |
220
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
$subs{$field} = $lvalue |
222
|
8
|
100
|
|
8
|
|
1660
|
? sub :lvalue { @_ > 1 and croak "$pkg->$field invoked with arguments"; |
223
|
7
|
|
|
|
|
30
|
shift->[$idx] } |
224
|
1
|
50
|
|
1
|
|
5
|
: sub { @_ > 1 and croak "$pkg->$field invoked with arguments"; |
225
|
20
|
100
|
|
|
|
92
|
shift->[$idx] }; |
|
1
|
|
|
|
|
6
|
|
226
|
|
|
|
|
|
|
} |
227
|
8
|
|
|
0
|
|
27
|
$subs{DESTROY} = sub {}; |
228
|
|
|
|
|
|
|
$subs{AUTOLOAD} = sub :lvalue { |
229
|
2
|
|
|
2
|
|
688
|
my ( $field ) = our $AUTOLOAD =~ m/::([^:]+)$/; |
230
|
2
|
|
|
|
|
208
|
croak "$pkg does not have a '$field' field"; |
231
|
0
|
|
|
|
|
0
|
my $dummy; ## croak can't be last because it isn't lvalue, so this line is required |
232
|
8
|
|
|
|
|
28
|
}; |
233
|
|
|
|
|
|
|
|
234
|
7
|
|
|
7
|
|
45
|
no strict 'refs'; |
|
7
|
|
|
|
|
18
|
|
|
7
|
|
|
|
|
2781
|
|
235
|
8
|
|
|
|
|
30
|
*{"${pkg}::$_"} = $subs{$_} for keys %subs; |
|
36
|
|
|
|
|
127
|
|
236
|
8
|
|
|
|
|
13
|
*{"${caller}::$name"} = $constructor; |
|
8
|
|
|
|
|
25
|
|
237
|
|
|
|
|
|
|
|
238
|
8
|
100
|
|
|
|
34
|
if( my $predicate = $opts{predicate} ) { |
239
|
1
|
|
50
|
2
|
|
9
|
*{"${caller}::$predicate"} = sub { ( ref($_[0]) || "" ) eq $pkg }; |
|
1
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
12
|
|
240
|
|
|
|
|
|
|
} |
241
|
|
|
|
|
|
|
|
242
|
8
|
|
|
|
|
33
|
*{"${pkg}::_forbid_arrayification"} = sub { |
243
|
1
|
|
|
1
|
|
2
|
return if !HAVE_OVERLOADING and caller eq __PACKAGE__; |
244
|
1
|
|
|
|
|
63
|
croak "Cannot use $pkg as an ARRAY reference" |
245
|
8
|
|
|
|
|
29
|
}; |
246
|
|
|
|
|
|
|
|
247
|
8
|
|
|
|
|
43
|
require overload; |
248
|
|
|
|
|
|
|
$pkg->overload::OVERLOAD( |
249
|
2
|
|
|
2
|
|
6
|
'@{}' => sub { $_[0]->_forbid_arrayification; return $_[0] }, |
|
1
|
|
|
|
|
5
|
|
250
|
1
|
|
|
1
|
|
254
|
'0+' => sub { refaddr $_[0] }, |
251
|
1
|
|
|
1
|
|
12
|
'""' => sub { sprintf "%s=Struct::Dumb(%#x)", $pkg, refaddr $_[0] }, |
252
|
1
|
|
|
1
|
|
2
|
'bool' => sub { 1 }, |
253
|
8
|
|
|
|
|
78
|
fallback => 1, |
254
|
|
|
|
|
|
|
); |
255
|
|
|
|
|
|
|
|
256
|
8
|
|
|
|
|
470
|
$_STRUCT_PACKAGES{$pkg} = { |
257
|
|
|
|
|
|
|
named => $named, |
258
|
|
|
|
|
|
|
fields => \@fields, |
259
|
|
|
|
|
|
|
} |
260
|
|
|
|
|
|
|
} |
261
|
|
|
|
|
|
|
|
262
|
|
|
|
|
|
|
=head2 struct |
263
|
|
|
|
|
|
|
|
264
|
|
|
|
|
|
|
struct $name => [ @fieldnames ], |
265
|
|
|
|
|
|
|
named_constructor => (1|0), |
266
|
|
|
|
|
|
|
predicate => "is_$name"; |
267
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
Creates a new structure type. This exports a new function of the type's name |
269
|
|
|
|
|
|
|
into the caller's namespace. Invoking this function returns a new instance of |
270
|
|
|
|
|
|
|
a type that implements those field names, as accessors and mutators for the |
271
|
|
|
|
|
|
|
fields. |
272
|
|
|
|
|
|
|
|
273
|
|
|
|
|
|
|
Takes the following options: |
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
=over 4 |
276
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
=item named_constructor => BOOL |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
Determines whether the structure will take positional or named arguments. |
280
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
=item predicate => STR |
282
|
|
|
|
|
|
|
|
283
|
|
|
|
|
|
|
If defined, gives the name of a second function to export to the caller's |
284
|
|
|
|
|
|
|
namespace. This function will be a type test predicate; that is, a function |
285
|
|
|
|
|
|
|
that takes a single argmuent, and returns true if-and-only-if that argument is |
286
|
|
|
|
|
|
|
an instance of this structure type. |
287
|
|
|
|
|
|
|
|
288
|
|
|
|
|
|
|
=back |
289
|
|
|
|
|
|
|
|
290
|
|
|
|
|
|
|
=cut |
291
|
|
|
|
|
|
|
|
292
|
|
|
|
|
|
|
=head2 readonly_struct |
293
|
|
|
|
|
|
|
|
294
|
|
|
|
|
|
|
readonly_struct $name => [ @fieldnames ], |
295
|
|
|
|
|
|
|
... |
296
|
|
|
|
|
|
|
|
297
|
|
|
|
|
|
|
Similar to L, but instances of this type are immutable once |
298
|
|
|
|
|
|
|
constructed. The field accessor methods will not be marked with the |
299
|
|
|
|
|
|
|
C<:lvalue> attribute. |
300
|
|
|
|
|
|
|
|
301
|
|
|
|
|
|
|
Takes the same options as L. |
302
|
|
|
|
|
|
|
|
303
|
|
|
|
|
|
|
=cut |
304
|
|
|
|
|
|
|
|
305
|
|
|
|
|
|
|
=head1 DATA::DUMP FILTER |
306
|
|
|
|
|
|
|
|
307
|
|
|
|
|
|
|
I |
308
|
|
|
|
|
|
|
|
309
|
|
|
|
|
|
|
If L is loaded, an extra filter is applied so that struct |
310
|
|
|
|
|
|
|
instances are printed in a format matching that which would construct them. |
311
|
|
|
|
|
|
|
|
312
|
|
|
|
|
|
|
struct Colour => [qw( red green blue )]; |
313
|
|
|
|
|
|
|
|
314
|
|
|
|
|
|
|
use Data::Dump; |
315
|
|
|
|
|
|
|
|
316
|
|
|
|
|
|
|
my %hash = ( col => Colour( 0.8, 0.5, 0.2 ) ); |
317
|
|
|
|
|
|
|
Data::Dump::dd \%hash; |
318
|
|
|
|
|
|
|
|
319
|
|
|
|
|
|
|
# prints {col => main::Colour(0.8, 0.5, 0.2)} |
320
|
|
|
|
|
|
|
|
321
|
|
|
|
|
|
|
=head1 NOTES |
322
|
|
|
|
|
|
|
|
323
|
|
|
|
|
|
|
=head2 Allowing ARRAY dereference |
324
|
|
|
|
|
|
|
|
325
|
|
|
|
|
|
|
The way that forbidding access to instances as if they were ARRAY references |
326
|
|
|
|
|
|
|
is currently implemented uses an internal method on the generated structure |
327
|
|
|
|
|
|
|
class called C<_forbid_arrayification>. If special circumstances require that |
328
|
|
|
|
|
|
|
this exception mechanism be bypassed, the method can be overloaded with an |
329
|
|
|
|
|
|
|
empty C body, allowing the struct instances in that class to be |
330
|
|
|
|
|
|
|
accessed like normal ARRAY references. For good practice this should be |
331
|
|
|
|
|
|
|
limited by a C override. |
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
For example, L needs to access the instances as plain ARRAY |
334
|
|
|
|
|
|
|
references so it can walk the data structure looking for reference cycles. |
335
|
|
|
|
|
|
|
|
336
|
|
|
|
|
|
|
use Devel::Cycle; |
337
|
|
|
|
|
|
|
|
338
|
|
|
|
|
|
|
{ |
339
|
|
|
|
|
|
|
no warnings 'redefine'; |
340
|
|
|
|
|
|
|
local *Point::_forbid_arrayification = sub {}; |
341
|
|
|
|
|
|
|
|
342
|
|
|
|
|
|
|
memory_cycle_ok( $point ); |
343
|
|
|
|
|
|
|
} |
344
|
|
|
|
|
|
|
|
345
|
|
|
|
|
|
|
=head1 TODO |
346
|
|
|
|
|
|
|
|
347
|
|
|
|
|
|
|
=over 4 |
348
|
|
|
|
|
|
|
|
349
|
|
|
|
|
|
|
=item * |
350
|
|
|
|
|
|
|
|
351
|
|
|
|
|
|
|
Consider adding an C option, giving name of another function to |
352
|
|
|
|
|
|
|
convert structs to key/value pairs, or a HASH ref. |
353
|
|
|
|
|
|
|
|
354
|
|
|
|
|
|
|
=back |
355
|
|
|
|
|
|
|
|
356
|
|
|
|
|
|
|
=head1 AUTHOR |
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
Paul Evans |
359
|
|
|
|
|
|
|
|
360
|
|
|
|
|
|
|
=cut |
361
|
|
|
|
|
|
|
|
362
|
|
|
|
|
|
|
sub maybe_apply_datadump_filter |
363
|
|
|
|
|
|
|
{ |
364
|
0
|
0
|
|
0
|
0
|
0
|
return unless $INC{"Data/Dump.pm"}; |
365
|
|
|
|
|
|
|
|
366
|
0
|
|
|
|
|
0
|
require Data::Dump::Filtered; |
367
|
|
|
|
|
|
|
|
368
|
|
|
|
|
|
|
Data::Dump::Filtered::add_dump_filter( sub { |
369
|
0
|
|
|
0
|
|
0
|
my ( $ctx, $obj ) = @_; |
370
|
0
|
0
|
|
|
|
0
|
return undef unless my $meta = $_STRUCT_PACKAGES{ $ctx->class }; |
371
|
|
|
|
|
|
|
|
372
|
|
|
|
|
|
|
BEGIN { |
373
|
7
|
|
|
7
|
|
1552
|
overloading->unimport if HAVE_OVERLOADING; |
374
|
|
|
|
|
|
|
} |
375
|
|
|
|
|
|
|
|
376
|
0
|
|
|
|
|
0
|
my $fields = $meta->{fields}; |
377
|
|
|
|
|
|
|
return { |
378
|
|
|
|
|
|
|
dump => sprintf "%s(%s)", $ctx->class, |
379
|
|
|
|
|
|
|
join ", ", map { |
380
|
0
|
0
|
|
|
|
0
|
( $meta->{named} ? "$fields->[$_] => " : "" ) . |
|
0
|
|
|
|
|
0
|
|
381
|
|
|
|
|
|
|
Data::Dump::dump($obj->[$_]) |
382
|
|
|
|
|
|
|
} 0 .. $#$fields |
383
|
|
|
|
|
|
|
}; |
384
|
0
|
|
|
|
|
0
|
}); |
385
|
|
|
|
|
|
|
} |
386
|
|
|
|
|
|
|
|
387
|
|
|
|
|
|
|
if( defined &Data::Dump::dump ) { |
388
|
|
|
|
|
|
|
maybe_apply_datadump_filter; |
389
|
|
|
|
|
|
|
} |
390
|
|
|
|
|
|
|
else { |
391
|
|
|
|
|
|
|
# A package var we observe that Data/Dump.pm seems to set when loaded |
392
|
|
|
|
|
|
|
# We can't attach to VERSION because too many other things get upset by |
393
|
|
|
|
|
|
|
# that. |
394
|
|
|
|
|
|
|
$Data::Dump::DEBUG = bless \( my $x = \&maybe_apply_datadump_filter ), |
395
|
|
|
|
|
|
|
"Struct::Dumb::_DestroyWatch"; |
396
|
|
|
|
|
|
|
} |
397
|
|
|
|
|
|
|
|
398
|
|
|
|
|
|
|
{ |
399
|
|
|
|
|
|
|
package Struct::Dumb::_DestroyWatch; |
400
|
|
|
|
|
|
|
my $GD = 0; |
401
|
6
|
|
|
6
|
|
5173
|
END { $GD = 1 } |
402
|
0
|
0
|
|
0
|
|
0
|
sub DESTROY { ${$_[0]}->() unless $GD; } |
|
0
|
|
|
|
|
0
|
|
403
|
|
|
|
|
|
|
} |
404
|
|
|
|
|
|
|
|
405
|
|
|
|
|
|
|
0x55AA; |