line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Storable::AMF0; |
2
|
|
|
|
|
|
|
# vim: ts=8 sw=4 sts=4 et |
3
|
52
|
|
|
52
|
|
128255
|
use strict; |
|
52
|
|
|
|
|
67
|
|
|
52
|
|
|
|
|
1251
|
|
4
|
52
|
|
|
52
|
|
171
|
use warnings; |
|
52
|
|
|
|
|
64
|
|
|
52
|
|
|
|
|
1211
|
|
5
|
52
|
|
|
52
|
|
235
|
use Fcntl qw(:flock); |
|
52
|
|
|
|
|
58
|
|
|
52
|
|
|
|
|
5887
|
|
6
|
|
|
|
|
|
|
our $VERSION = '1.22'; |
7
|
52
|
|
|
52
|
|
19542
|
use subs qw(freeze thaw); |
|
52
|
|
|
|
|
1024
|
|
|
52
|
|
|
|
|
227
|
|
8
|
52
|
|
|
52
|
|
2142
|
use Exporter 'import'; |
|
52
|
|
|
|
|
64
|
|
|
52
|
|
|
|
|
1553
|
|
9
|
52
|
|
|
52
|
|
181
|
use Carp qw(croak); |
|
52
|
|
|
|
|
59
|
|
|
52
|
|
|
|
|
26676
|
|
10
|
|
|
|
|
|
|
{ our @Bool = (bless( do{\(my $o = 0)},'JSON::PP::Boolean'), bless( do{\(my $o = 1)},'JSON::PP::Boolean')); |
11
|
|
|
|
|
|
|
local $@; |
12
|
|
|
|
|
|
|
eval { |
13
|
|
|
|
|
|
|
require Types::Serialiser; |
14
|
|
|
|
|
|
|
@Bool = (Types::Serialiser::false(), Types::Serialiser::true()); |
15
|
|
|
|
|
|
|
1 |
16
|
|
|
|
|
|
|
} or |
17
|
|
|
|
|
|
|
eval { |
18
|
|
|
|
|
|
|
require JSON::XS; |
19
|
|
|
|
|
|
|
@Bool = (JSON::XS::false(), JSON::XS::true()); |
20
|
|
|
|
|
|
|
1 |
21
|
|
|
|
|
|
|
}; |
22
|
|
|
|
|
|
|
}; |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
# Items to export into callers namespace by default. Note: do not export |
25
|
|
|
|
|
|
|
# names by default without a very good reason. Use EXPORT_OK instead. |
26
|
|
|
|
|
|
|
# Do not simply export all your public functions/methods/constants. |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
our @EXPORT_TAGS_ALL = qw( |
29
|
|
|
|
|
|
|
freeze thaw dclone |
30
|
|
|
|
|
|
|
retrieve lock_retrieve lock_store lock_nstore store nstore |
31
|
|
|
|
|
|
|
ref_lost_memory ref_clear |
32
|
|
|
|
|
|
|
deparse_amf new_amfdate perl_date |
33
|
|
|
|
|
|
|
new_date |
34
|
|
|
|
|
|
|
parse_option |
35
|
|
|
|
|
|
|
parse_serializator_option |
36
|
|
|
|
|
|
|
); |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
our %EXPORT_TAGS = ( 'all' => \@EXPORT_TAGS_ALL); |
39
|
|
|
|
|
|
|
our @EXPORT_OK = ( @EXPORT_TAGS_ALL ); |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
sub retrieve($) { |
42
|
32
|
|
|
32
|
1
|
49
|
my $file = shift; |
43
|
32
|
|
|
|
|
38
|
my $lock = shift; |
44
|
|
|
|
|
|
|
|
45
|
32
|
50
|
|
|
|
876
|
open my $fh, "<:raw", $file or croak "Fail on open file \"$file\" for reading $!"; |
46
|
32
|
100
|
|
|
|
81
|
flock $fh, LOCK_SH if $lock; |
47
|
32
|
|
|
|
|
35
|
my $buf; |
48
|
32
|
|
|
|
|
185
|
sysread $fh, $buf, (( sysseek $fh, 0, 2 ), sysseek $fh, 0,0)[0] ; |
49
|
32
|
|
|
|
|
554
|
return thaw($buf); |
50
|
|
|
|
|
|
|
} |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
sub lock_retrieve($) { |
53
|
6
|
|
|
6
|
1
|
15
|
$_[1] = 1; |
54
|
6
|
|
|
|
|
15
|
goto &retrieve; |
55
|
|
|
|
|
|
|
} |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
sub store($$) { |
58
|
15
|
|
|
15
|
1
|
42066
|
my ( $object, $file, $lock ) = @_; |
59
|
|
|
|
|
|
|
|
60
|
15
|
|
|
|
|
356
|
my $freeze = \freeze($object); |
61
|
15
|
50
|
|
|
|
45
|
unless (defined $$freeze ){ |
62
|
0
|
|
|
|
|
0
|
croak "Bad object $@"; |
63
|
|
|
|
|
|
|
} |
64
|
|
|
|
|
|
|
else { |
65
|
15
|
|
|
|
|
21
|
my $fh; |
66
|
15
|
100
|
|
|
|
22
|
if ($lock){ |
67
|
7
|
50
|
|
|
|
347
|
open $fh, ">>:raw", $file or croak "Fail on open file \"$file\" for writing $!"; |
68
|
7
|
50
|
|
|
|
251199
|
flock $fh, LOCK_EX if $lock; |
69
|
7
|
|
|
|
|
185
|
truncate $fh, 0; |
70
|
7
|
|
|
|
|
21
|
seek $fh,0,0; |
71
|
|
|
|
|
|
|
} |
72
|
|
|
|
|
|
|
else { |
73
|
8
|
50
|
|
|
|
560
|
open $fh, ">:raw", $file or croak "Fail on open file \"$file\" for writing $!"; |
74
|
|
|
|
|
|
|
} |
75
|
15
|
50
|
|
|
|
128
|
print $fh $$freeze if defined $$freeze; |
76
|
15
|
|
|
|
|
461
|
close $fh; |
77
|
|
|
|
|
|
|
}; |
78
|
|
|
|
|
|
|
} |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
sub lock_store($$) { |
81
|
7
|
|
|
7
|
1
|
18
|
$_[2] = 1; |
82
|
7
|
|
|
|
|
42
|
goto &store; |
83
|
|
|
|
|
|
|
} |
84
|
|
|
|
|
|
|
sub ref_lost_memory($); |
85
|
|
|
|
|
|
|
sub ref_clear($); |
86
|
|
|
|
|
|
|
{{ |
87
|
|
|
|
|
|
|
require XSLoader; |
88
|
|
|
|
|
|
|
XSLoader::load( 'Storable::AMF', $VERSION ); |
89
|
52
|
|
|
52
|
|
306
|
no warnings 'once'; |
|
52
|
|
|
|
|
70
|
|
|
52
|
|
|
|
|
2908
|
|
90
|
|
|
|
|
|
|
*nstore = \&store; |
91
|
|
|
|
|
|
|
*lock_nstore = \&lock_store; |
92
|
|
|
|
|
|
|
|
93
|
52
|
|
|
52
|
|
202
|
no strict 'refs'; |
|
52
|
|
|
|
|
66
|
|
|
52
|
|
|
|
|
24778
|
|
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
my $my_package = __PACKAGE__ . "::"; |
96
|
|
|
|
|
|
|
for my $other_package ( "Storable::AMF::", "Storable::AMF3::" ){ |
97
|
|
|
|
|
|
|
*{ $other_package . $_ } = *{ $my_package . $_} for qw(ref_clear ref_lost_memory VERSION); |
98
|
|
|
|
|
|
|
} |
99
|
|
|
|
|
|
|
*{"Storable::AMF::$_"} = *{"Storable::AMF0::$_"} for grep m/retrieve|store/, @EXPORT_OK; |
100
|
|
|
|
|
|
|
}}; |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
*refaddr = \&Scalar::Util::refaddr; |
103
|
|
|
|
|
|
|
*reftype = \&Scalar::Util::reftype; |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
sub _ref_selfref($$); |
106
|
|
|
|
|
|
|
sub _ref_selfref($$){ |
107
|
1448
|
|
|
1448
|
|
3301
|
require Scalar::Util; |
108
|
1448
|
|
|
|
|
1022
|
my $obj_addr = shift; |
109
|
1448
|
|
|
|
|
995
|
my $value = shift; |
110
|
1448
|
|
|
|
|
1552
|
my $addr = refaddr($value); |
111
|
1448
|
100
|
|
|
|
2659
|
return unless defined $addr; |
112
|
675
|
100
|
|
|
|
1460
|
if ( reftype($value) eq 'ARRAY' ) { |
|
|
50
|
|
|
|
|
|
113
|
|
|
|
|
|
|
|
114
|
366
|
100
|
|
|
|
768
|
return $$obj_addr{$addr} if exists $$obj_addr{$addr}; |
115
|
269
|
|
|
|
|
398
|
$$obj_addr{$addr} = 1; |
116
|
269
|
|
100
|
|
|
440
|
_ref_selfref( $obj_addr, $_ ) && return 1 for @$value; |
117
|
215
|
|
|
|
|
200
|
$$obj_addr{$addr} = 0; |
118
|
|
|
|
|
|
|
} |
119
|
|
|
|
|
|
|
elsif ( reftype($value) eq 'HASH' ) { |
120
|
|
|
|
|
|
|
|
121
|
309
|
100
|
|
|
|
610
|
return $$obj_addr{$addr} if exists $$obj_addr{$addr}; |
122
|
231
|
|
|
|
|
270
|
$$obj_addr{$addr} = 1; |
123
|
231
|
|
100
|
|
|
704
|
_ref_selfref( $obj_addr, $_ ) && return 1 for values %$value; |
124
|
213
|
|
|
|
|
220
|
$$obj_addr{$addr} = 0; |
125
|
|
|
|
|
|
|
} |
126
|
|
|
|
|
|
|
|
127
|
428
|
|
|
|
|
825
|
return; |
128
|
|
|
|
|
|
|
} |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
sub ref_clear($) { |
131
|
1581
|
|
|
1581
|
1
|
601431
|
my $ref = shift; |
132
|
1581
|
|
|
|
|
1096
|
my %addr; |
133
|
1581
|
|
|
|
|
3849
|
require Scalar::Util; |
134
|
1581
|
100
|
|
|
|
3833
|
return unless ( refaddr($ref)); |
135
|
726
|
|
|
|
|
509
|
my @r; |
136
|
726
|
100
|
|
|
|
1680
|
if ( reftype($ref) eq 'ARRAY' ) { |
|
|
50
|
|
|
|
|
|
137
|
399
|
|
|
|
|
552
|
@r = @$ref; |
138
|
399
|
|
|
|
|
378
|
@$ref = (); |
139
|
399
|
|
|
|
|
797
|
ref_clear($_) for @r; |
140
|
|
|
|
|
|
|
} |
141
|
|
|
|
|
|
|
elsif ( reftype($ref) eq 'HASH' ) { |
142
|
327
|
|
|
|
|
579
|
@r = values %$ref; |
143
|
327
|
|
|
|
|
371
|
%$ref = (); |
144
|
327
|
|
|
|
|
668
|
ref_clear($_) for @r; |
145
|
|
|
|
|
|
|
} |
146
|
|
|
|
|
|
|
} |
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
sub ref_lost_memory($) { |
149
|
533
|
|
|
533
|
1
|
188976
|
my $ref = shift; |
150
|
533
|
|
|
|
|
403
|
my %obj_addr; |
151
|
533
|
|
|
|
|
640
|
return _ref_selfref( \%obj_addr, $ref ); |
152
|
|
|
|
|
|
|
} |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
1; |
155
|
|
|
|
|
|
|
__END__ |