line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# Manage session data structures on behalf of POE::Kernel. |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
package POE::Resource::Sessions; |
4
|
|
|
|
|
|
|
|
5
|
176
|
|
|
176
|
|
911
|
use vars qw($VERSION); |
|
176
|
|
|
|
|
294
|
|
|
176
|
|
|
|
|
12089
|
|
6
|
|
|
|
|
|
|
$VERSION = '1.366'; # NOTE - Should be #.### (three decimal places) |
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
# These methods are folded into POE::Kernel; |
9
|
|
|
|
|
|
|
package POE::Kernel; |
10
|
|
|
|
|
|
|
|
11
|
176
|
|
|
176
|
|
763
|
use strict; |
|
176
|
|
|
|
|
597
|
|
|
176
|
|
|
|
|
18961
|
|
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
# Map stringy sessions to their references for _data_ses_resolve. |
14
|
|
|
|
|
|
|
my %kr_session_refs; |
15
|
|
|
|
|
|
|
# { $session_ref => $blessed, ... } |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
### Session structure. |
18
|
|
|
|
|
|
|
my %kr_sessions; |
19
|
|
|
|
|
|
|
# { $session_id => |
20
|
|
|
|
|
|
|
# [ $blessed_session, SS_SESSION |
21
|
|
|
|
|
|
|
# $total_reference_count, SS_REFCOUNT |
22
|
|
|
|
|
|
|
# $parent_session, SS_PARENT |
23
|
|
|
|
|
|
|
# { $child_session_id => $blessed_ref, SS_CHILDREN |
24
|
|
|
|
|
|
|
# ..., |
25
|
|
|
|
|
|
|
# }, |
26
|
|
|
|
|
|
|
# { $process_id => $placeholder_value, SS_PROCESSES |
27
|
|
|
|
|
|
|
# ..., |
28
|
|
|
|
|
|
|
# }, |
29
|
|
|
|
|
|
|
# ], |
30
|
|
|
|
|
|
|
# ..., |
31
|
|
|
|
|
|
|
# }; |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
sub SS_SESSION () { 0 } |
34
|
|
|
|
|
|
|
sub SS_REFCOUNT () { 1 } |
35
|
|
|
|
|
|
|
sub SS_PARENT () { 2 } |
36
|
|
|
|
|
|
|
sub SS_CHILDREN () { 3 } |
37
|
|
|
|
|
|
|
sub SS_PROCESSES () { 4 } |
38
|
|
|
|
|
|
|
|
39
|
176
|
|
|
176
|
|
374930
|
BEGIN { $POE::Kernel::poe_kernel->[KR_SESSIONS] = \%kr_sessions; } |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
sub _data_ses_relocate_kernel_id { |
42
|
4
|
|
|
4
|
|
20
|
my ($self, $old_id, $new_id) = @_; |
43
|
|
|
|
|
|
|
|
44
|
4
|
|
|
|
|
64
|
while (my ($sid, $ses_rec) = each %kr_sessions) { |
45
|
8
|
|
|
|
|
41
|
my $children = $ses_rec->[SS_CHILDREN]; |
46
|
8
|
50
|
|
|
|
76
|
$children->{$new_id} = delete $children->{$old_id} |
47
|
|
|
|
|
|
|
if exists $children->{$old_id}; |
48
|
|
|
|
|
|
|
} |
49
|
|
|
|
|
|
|
|
50
|
4
|
50
|
|
|
|
36
|
$kr_sessions{$new_id} = delete $kr_sessions{$old_id} |
51
|
|
|
|
|
|
|
if exists $kr_sessions{$old_id}; |
52
|
|
|
|
|
|
|
} |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
### End-run leak checking. |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
sub _data_ses_clone { |
57
|
0
|
|
|
0
|
|
0
|
%kr_session_refs = (); |
58
|
0
|
|
|
|
|
0
|
foreach my $ses_ref (map { $_->[SS_SESSION] } values %kr_sessions) { |
|
0
|
|
|
|
|
0
|
|
59
|
0
|
|
|
|
|
0
|
$kr_session_refs{$ses_ref} = $ses_ref; |
60
|
|
|
|
|
|
|
} |
61
|
|
|
|
|
|
|
} |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
sub _data_ses_finalize { |
64
|
191
|
|
|
191
|
|
583
|
my $finalized_ok = 1; |
65
|
|
|
|
|
|
|
|
66
|
191
|
|
|
|
|
736
|
while (my ($sid, $ses_rec) = each %kr_sessions) { |
67
|
0
|
|
|
|
|
0
|
$finalized_ok = 0; |
68
|
0
|
|
|
|
|
0
|
_warn( |
69
|
|
|
|
|
|
|
"!!! Leaked session: $sid\n", |
70
|
|
|
|
|
|
|
"!!!\trefcnt = $ses_rec->[SS_REFCOUNT]\n", |
71
|
|
|
|
|
|
|
"!!!\tparent = $ses_rec->[SS_PARENT]\n", |
72
|
0
|
|
|
|
|
0
|
"!!!\tchilds = ", join("; ", keys(%{$ses_rec->[SS_CHILDREN]})), "\n", |
73
|
0
|
|
|
|
|
0
|
"!!!\tprocs = ", join("; ", keys(%{$ses_rec->[SS_PROCESSES]})),"\n", |
74
|
|
|
|
|
|
|
); |
75
|
|
|
|
|
|
|
} |
76
|
|
|
|
|
|
|
|
77
|
191
|
|
|
|
|
775
|
while (my ($stringy, $blessed) = each %kr_session_refs) { |
78
|
0
|
|
|
|
|
0
|
$finalized_ok = 0; |
79
|
0
|
|
|
|
|
0
|
_warn "!!! Leaked stringy session $stringy = $blessed\n"; |
80
|
0
|
0
|
|
|
|
0
|
_warn "!!!\tBad clone detected, while we're at it.\n" if ( |
81
|
|
|
|
|
|
|
$stringy ne "$blessed" |
82
|
|
|
|
|
|
|
); |
83
|
|
|
|
|
|
|
} |
84
|
|
|
|
|
|
|
|
85
|
191
|
|
|
|
|
483
|
return $finalized_ok; |
86
|
|
|
|
|
|
|
} |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
### Enter a new session into the back-end stuff. |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
my %kr_marked_for_gc; |
91
|
|
|
|
|
|
|
my @kr_marked_for_gc; |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
sub _data_ses_allocate { |
94
|
1090
|
|
|
1090
|
|
2070
|
my ($self, $session, $sid, $parent_id) = @_; |
95
|
|
|
|
|
|
|
|
96
|
1090
|
|
|
|
|
1216
|
my $parent; |
97
|
1090
|
100
|
|
|
|
2619
|
if (defined $parent_id) { |
98
|
821
|
100
|
|
|
|
2414
|
_trap "parent session $parent_id does not exist" unless ( |
99
|
|
|
|
|
|
|
exists $kr_sessions{$parent_id} |
100
|
|
|
|
|
|
|
); |
101
|
|
|
|
|
|
|
|
102
|
820
|
|
|
|
|
1588
|
$parent = $kr_sessions{$parent_id}[SS_SESSION]; |
103
|
|
|
|
|
|
|
|
104
|
820
|
100
|
|
|
|
2173
|
_trap "session $session is already allocated" if exists $kr_sessions{$sid}; |
105
|
|
|
|
|
|
|
} |
106
|
|
|
|
|
|
|
|
107
|
1088
|
|
|
|
|
2986
|
TRACE_REFCNT and _warn " allocating $session"; |
108
|
|
|
|
|
|
|
|
109
|
1088
|
|
|
|
|
5825
|
$kr_sessions{$sid} = |
110
|
|
|
|
|
|
|
[ $session, # SS_SESSION |
111
|
|
|
|
|
|
|
0, # SS_REFCOUNT |
112
|
|
|
|
|
|
|
$parent, # SS_PARENT |
113
|
|
|
|
|
|
|
{ }, # SS_CHILDREN |
114
|
|
|
|
|
|
|
{ }, # SS_PROCESSES |
115
|
|
|
|
|
|
|
]; |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
# For the ID to session reference lookup. |
118
|
1088
|
|
|
|
|
4358
|
$self->_data_sid_set($sid, $session); |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
# For the stringy to blessed session reference lookup. |
121
|
1088
|
|
|
|
|
3537
|
$kr_session_refs{$session} = $session; |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
# Manage parent/child relationship. |
124
|
1088
|
100
|
|
|
|
2848
|
if (defined $parent_id) { |
125
|
819
|
|
|
|
|
927
|
if (TRACE_SESSIONS) { |
126
|
|
|
|
|
|
|
_warn( |
127
|
|
|
|
|
|
|
" ", |
128
|
|
|
|
|
|
|
$self->_data_alias_loggable($sid), " has parent ", |
129
|
|
|
|
|
|
|
$self->_data_alias_loggable($parent_id) |
130
|
|
|
|
|
|
|
); |
131
|
|
|
|
|
|
|
} |
132
|
|
|
|
|
|
|
|
133
|
819
|
|
|
|
|
2705
|
$kr_sessions{$parent_id}->[SS_CHILDREN]->{$sid} = $session; |
134
|
819
|
|
|
|
|
2971
|
$self->_data_ses_refcount_inc($parent_id); |
135
|
|
|
|
|
|
|
} |
136
|
|
|
|
|
|
|
|
137
|
965
|
|
|
|
|
1770
|
TRACE_REFCNT and _warn " $session marked for gc"; |
138
|
1088
|
100
|
|
|
|
41375
|
unless ($sid eq $self->ID) { |
139
|
942
|
|
|
|
|
3630
|
push @kr_marked_for_gc, $sid; |
140
|
819
|
|
|
|
|
3318
|
$kr_marked_for_gc{$sid} = $sid; |
141
|
|
|
|
|
|
|
} |
142
|
|
|
|
|
|
|
} |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
# Release a session's resources, and remove it. This doesn't do |
145
|
|
|
|
|
|
|
# garbage collection for the session itself because that should |
146
|
|
|
|
|
|
|
# already have happened. |
147
|
|
|
|
|
|
|
# |
148
|
|
|
|
|
|
|
# TODO This is yet another place where resources will need to register |
149
|
|
|
|
|
|
|
# a function. Every resource's _data_???_clear_session is called |
150
|
|
|
|
|
|
|
# here. |
151
|
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
sub _data_ses_free { |
153
|
1202
|
|
|
790
|
|
4179
|
my ($self, $sid) = @_; |
154
|
|
|
|
|
|
|
|
155
|
790
|
|
|
|
|
851
|
TRACE_REFCNT and do { |
156
|
|
|
|
|
|
|
_warn " freeing session $sid"; |
157
|
|
|
|
|
|
|
_trap("!!! free defunct session $sid?!\n") unless ( |
158
|
|
|
|
|
|
|
$self->_data_ses_exists($sid) |
159
|
|
|
|
|
|
|
); |
160
|
|
|
|
|
|
|
}; |
161
|
|
|
|
|
|
|
|
162
|
790
|
|
|
|
|
2046
|
if (TRACE_SESSIONS) { |
163
|
|
|
|
|
|
|
_warn " freeing ", $self->_data_alias_loggable($sid); |
164
|
|
|
|
|
|
|
} |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
# Manage parent/child relationships. |
167
|
|
|
|
|
|
|
|
168
|
790
|
|
|
|
|
2721
|
my $parent = $kr_sessions{$sid}->[SS_PARENT]; |
169
|
790
|
|
|
|
|
1224
|
my @children = $self->_data_ses_get_children($sid); |
170
|
|
|
|
|
|
|
|
171
|
790
|
100
|
|
|
|
2032
|
if (defined $parent) { |
172
|
685
|
|
|
|
|
3464
|
my $parent_id = $parent->ID; |
173
|
|
|
|
|
|
|
|
174
|
685
|
|
|
|
|
1423
|
if (ASSERT_DATA) { |
175
|
|
|
|
|
|
|
_trap "session is its own parent" if $parent_id eq $sid; |
176
|
|
|
|
|
|
|
_trap "session's parent ($parent_id) doesn't exist" |
177
|
|
|
|
|
|
|
unless exists $kr_sessions{$parent_id}; |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
unless ($self->_data_ses_is_child($parent_id, $sid)) { |
180
|
|
|
|
|
|
|
_trap( |
181
|
|
|
|
|
|
|
$self->_data_alias_loggable($sid), " isn't a child of ", |
182
|
|
|
|
|
|
|
$self->_data_alias_loggable($parent_id), " (it's a child of ", |
183
|
|
|
|
|
|
|
$self->_data_alias_loggable($self->_data_ses_get_parent($sid)->ID), |
184
|
|
|
|
|
|
|
")" |
185
|
|
|
|
|
|
|
); |
186
|
|
|
|
|
|
|
} |
187
|
|
|
|
|
|
|
} |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
# Remove the departing session from its parent. |
190
|
|
|
|
|
|
|
|
191
|
685
|
50
|
|
|
|
1781
|
_trap "internal inconsistency ($parent_id/$sid)" |
192
|
|
|
|
|
|
|
unless delete $kr_sessions{$parent_id}->[SS_CHILDREN]->{$sid}; |
193
|
|
|
|
|
|
|
|
194
|
597
|
|
|
|
|
1498
|
$kr_sessions{$sid}->[SS_PARENT] = undef; |
195
|
|
|
|
|
|
|
|
196
|
597
|
|
|
|
|
996
|
if (TRACE_SESSIONS) { |
197
|
|
|
|
|
|
|
_cluck( |
198
|
|
|
|
|
|
|
" removed ", |
199
|
|
|
|
|
|
|
$self->_data_alias_loggable($sid), " from ", |
200
|
|
|
|
|
|
|
$self->_data_alias_loggable($parent_id) |
201
|
|
|
|
|
|
|
); |
202
|
|
|
|
|
|
|
} |
203
|
|
|
|
|
|
|
|
204
|
362
|
|
|
|
|
955
|
$self->_data_ses_refcount_dec($parent_id); |
205
|
|
|
|
|
|
|
|
206
|
|
|
|
|
|
|
# Move the departing session's children to its parent. |
207
|
|
|
|
|
|
|
|
208
|
597
|
|
|
|
|
1836
|
foreach (@children) { |
209
|
538
|
|
|
|
|
1310
|
$self->_data_ses_move_child($_->ID, $parent_id) |
210
|
|
|
|
|
|
|
} |
211
|
|
|
|
|
|
|
} |
212
|
235
|
|
|
|
|
202
|
elsif (ASSERT_DATA) { |
213
|
|
|
|
|
|
|
_trap "no parent to give children to" if @children; |
214
|
|
|
|
|
|
|
} |
215
|
|
|
|
|
|
|
|
216
|
618
|
|
|
|
|
1927
|
my $session = $kr_sessions{$sid}[SS_SESSION]; |
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
# Things which do not hold reference counts. |
219
|
|
|
|
|
|
|
|
220
|
618
|
|
|
|
|
1271
|
$self->_data_sid_clear($sid); # Remove from SID tables. |
221
|
383
|
|
|
|
|
774
|
$self->_data_sig_clear_session($sid); # Remove all leftover signals. |
222
|
|
|
|
|
|
|
|
223
|
|
|
|
|
|
|
# Things which do hold reference counts. |
224
|
|
|
|
|
|
|
|
225
|
467
|
|
|
|
|
1366
|
$self->_data_alias_clear_session($sid); # Remove all leftover aliases. |
226
|
704
|
|
|
|
|
108397
|
$self->_data_extref_clear_session($sid); # Remove all leftover extrefs. |
227
|
704
|
|
|
|
|
2353
|
$self->_data_handle_clear_session($sid); # Remove all leftover handles. |
228
|
|
|
|
|
|
|
|
229
|
402
|
|
|
|
|
1038
|
$self->_data_ev_clear_session($sid); # Remove all leftover events. |
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
# Remove the session itself. |
232
|
|
|
|
|
|
|
|
233
|
487
|
|
|
|
|
1392
|
delete $kr_marked_for_gc{$sid}; |
234
|
789
|
|
|
|
|
2677
|
delete $kr_sessions{$sid}; |
235
|
789
|
|
|
|
|
2992
|
delete $kr_session_refs{$session}; |
236
|
|
|
|
|
|
|
} |
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
### Move a session to a new parent. |
239
|
|
|
|
|
|
|
|
240
|
|
|
|
|
|
|
sub _data_ses_move_child { |
241
|
731
|
|
|
22
|
|
2231
|
my ($self, $sid, $new_parent_id) = @_; |
242
|
|
|
|
|
|
|
|
243
|
731
|
|
|
|
|
1784
|
if (ASSERT_DATA) { |
244
|
|
|
|
|
|
|
_trap("moving nonexistent child to another parent") |
245
|
|
|
|
|
|
|
unless exists $kr_sessions{$sid}; |
246
|
|
|
|
|
|
|
_trap("moving child to a nonexistent parent") |
247
|
|
|
|
|
|
|
unless exists $kr_sessions{$new_parent_id}; |
248
|
|
|
|
|
|
|
} |
249
|
|
|
|
|
|
|
|
250
|
731
|
|
|
|
|
2348
|
if (TRACE_SESSIONS) { |
251
|
|
|
|
|
|
|
_warn( |
252
|
|
|
|
|
|
|
" moving ", |
253
|
|
|
|
|
|
|
$self->_data_alias_loggable($sid), " to ", |
254
|
|
|
|
|
|
|
$self->_data_alias_loggable($new_parent_id) |
255
|
|
|
|
|
|
|
); |
256
|
|
|
|
|
|
|
} |
257
|
|
|
|
|
|
|
|
258
|
730
|
|
|
|
|
2737
|
my $old_parent_id = $self->_data_ses_get_parent($sid)->ID; |
259
|
|
|
|
|
|
|
|
260
|
408
|
|
|
|
|
1464
|
if (ASSERT_DATA) { |
261
|
|
|
|
|
|
|
_trap("moving child from a nonexistent parent") |
262
|
|
|
|
|
|
|
unless exists $kr_sessions{$old_parent_id}; |
263
|
|
|
|
|
|
|
} |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
# Remove the session from its old parent. |
266
|
408
|
|
|
|
|
646
|
delete $kr_sessions{$old_parent_id}->[SS_CHILDREN]->{$sid}; |
267
|
|
|
|
|
|
|
|
268
|
408
|
|
|
|
|
1255
|
if (TRACE_SESSIONS) { |
269
|
|
|
|
|
|
|
_warn( |
270
|
|
|
|
|
|
|
" removed ", |
271
|
|
|
|
|
|
|
$self->_data_alias_loggable($sid), " from ", |
272
|
|
|
|
|
|
|
$self->_data_alias_loggable($old_parent_id) |
273
|
|
|
|
|
|
|
); |
274
|
|
|
|
|
|
|
} |
275
|
|
|
|
|
|
|
|
276
|
408
|
|
|
|
|
1380
|
$self->_data_ses_refcount_dec($old_parent_id); |
277
|
|
|
|
|
|
|
|
278
|
|
|
|
|
|
|
# Change the session's parent. |
279
|
20
|
|
|
|
|
45
|
$kr_sessions{$sid}->[SS_PARENT] = $kr_sessions{$new_parent_id}[SS_SESSION]; |
280
|
|
|
|
|
|
|
|
281
|
20
|
|
|
|
|
51
|
if (TRACE_SESSIONS) { |
282
|
|
|
|
|
|
|
_warn( |
283
|
|
|
|
|
|
|
" changed parent of ", |
284
|
|
|
|
|
|
|
$self->_data_alias_loggable($sid), " to ", |
285
|
|
|
|
|
|
|
$self->_data_alias_loggable($new_parent_id) |
286
|
|
|
|
|
|
|
); |
287
|
|
|
|
|
|
|
} |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
# Add the current session to the new parent's children. |
290
|
20
|
|
|
|
|
24
|
$kr_sessions{$new_parent_id}->[SS_CHILDREN]->{$sid} = ( |
291
|
|
|
|
|
|
|
$kr_sessions{$sid}[SS_SESSION] |
292
|
|
|
|
|
|
|
); |
293
|
|
|
|
|
|
|
|
294
|
20
|
|
|
|
|
48
|
if (TRACE_SESSIONS) { |
295
|
|
|
|
|
|
|
_warn( |
296
|
|
|
|
|
|
|
" added ", |
297
|
|
|
|
|
|
|
$self->_data_alias_loggable($sid), " as child of ", |
298
|
|
|
|
|
|
|
$self->_data_alias_loggable($new_parent_id) |
299
|
|
|
|
|
|
|
); |
300
|
|
|
|
|
|
|
} |
301
|
|
|
|
|
|
|
|
302
|
20
|
|
|
|
|
223
|
$self->_data_ses_refcount_inc($new_parent_id); |
303
|
|
|
|
|
|
|
|
304
|
|
|
|
|
|
|
# We do not call _data_ses_collect_garbage() here. This function is |
305
|
|
|
|
|
|
|
# called in batch for a departing session, to move its children to |
306
|
|
|
|
|
|
|
# its parent. The GC test would be superfluous here. Rather, it's |
307
|
|
|
|
|
|
|
# up to the caller to do the proper GC test after moving things |
308
|
|
|
|
|
|
|
# around. |
309
|
|
|
|
|
|
|
} |
310
|
|
|
|
|
|
|
|
311
|
|
|
|
|
|
|
### Get a session's parent. |
312
|
|
|
|
|
|
|
|
313
|
|
|
|
|
|
|
sub _data_ses_get_parent { |
314
|
1609
|
|
|
1589
|
|
3854
|
my ($self, $sid) = @_; |
315
|
1609
|
|
|
|
|
1817
|
if (ASSERT_DATA || ASSERT_USAGE) { |
316
|
|
|
|
|
|
|
_trap("undefined session ID") unless defined $sid; |
317
|
|
|
|
|
|
|
_trap("retrieving parent of a nonexistent session") |
318
|
|
|
|
|
|
|
unless exists $kr_sessions{$sid}; |
319
|
|
|
|
|
|
|
} |
320
|
1609
|
|
|
|
|
4938
|
return $kr_sessions{$sid}->[SS_PARENT]; |
321
|
|
|
|
|
|
|
} |
322
|
|
|
|
|
|
|
|
323
|
|
|
|
|
|
|
### Get a session's children. |
324
|
|
|
|
|
|
|
|
325
|
|
|
|
|
|
|
sub _data_ses_get_children { |
326
|
4548
|
|
|
3151
|
|
8436
|
my ($self, $sid) = @_; |
327
|
4547
|
|
|
|
|
10502
|
if (ASSERT_DATA) { |
328
|
|
|
|
|
|
|
_trap("retrieving children of a nonexistent session") |
329
|
|
|
|
|
|
|
unless exists $kr_sessions{$sid}; |
330
|
|
|
|
|
|
|
} |
331
|
3171
|
|
|
|
|
5344
|
return values %{$kr_sessions{$sid}->[SS_CHILDREN]}; |
|
3170
|
|
|
|
|
4339
|
|
332
|
|
|
|
|
|
|
} |
333
|
|
|
|
|
|
|
|
334
|
|
|
|
|
|
|
### Is a session a child of another? |
335
|
|
|
|
|
|
|
|
336
|
|
|
|
|
|
|
sub _data_ses_is_child { |
337
|
3001
|
|
|
550
|
|
9139
|
my ($self, $parent_id, $child_id) = @_; |
338
|
550
|
|
|
|
|
601
|
if (ASSERT_DATA) { |
339
|
|
|
|
|
|
|
_trap("testing is-child of a nonexistent parent session") |
340
|
|
|
|
|
|
|
unless exists $kr_sessions{$parent_id}; |
341
|
|
|
|
|
|
|
} |
342
|
|
|
|
|
|
|
return( |
343
|
550
|
|
33
|
|
|
1303
|
exists $kr_sessions{$parent_id} && |
344
|
|
|
|
|
|
|
exists $kr_sessions{$parent_id}->[SS_CHILDREN]->{$child_id} |
345
|
|
|
|
|
|
|
); |
346
|
|
|
|
|
|
|
} |
347
|
|
|
|
|
|
|
|
348
|
|
|
|
|
|
|
### Determine whether a session exists. We should only need to verify |
349
|
|
|
|
|
|
|
### this for sessions provided by the outside. Internally, our code |
350
|
|
|
|
|
|
|
### should be so clean it's not necessary. |
351
|
|
|
|
|
|
|
|
352
|
|
|
|
|
|
|
sub _data_ses_exists { |
353
|
7138
|
|
|
6589
|
|
13346
|
my ($self, $sid) = @_; |
354
|
6589
|
|
|
|
|
21030
|
return exists $kr_sessions{$sid}; |
355
|
|
|
|
|
|
|
} |
356
|
|
|
|
|
|
|
|
357
|
|
|
|
|
|
|
### Resolve a session into its reference. |
358
|
|
|
|
|
|
|
|
359
|
|
|
|
|
|
|
sub _data_ses_resolve { |
360
|
3976
|
|
|
3976
|
|
4503
|
my ($self, $session) = @_; |
361
|
3976
|
100
|
|
|
|
10352
|
return undef unless exists $kr_session_refs{$session}; # Prevents autoviv. |
362
|
3767
|
|
|
|
|
8978
|
return $kr_session_refs{$session}; |
363
|
|
|
|
|
|
|
} |
364
|
|
|
|
|
|
|
|
365
|
|
|
|
|
|
|
### Resolve a session ID into its reference. |
366
|
|
|
|
|
|
|
|
367
|
|
|
|
|
|
|
sub _data_ses_resolve_to_id { |
368
|
34
|
|
|
34
|
|
47
|
my ($self, $session) = @_; |
369
|
34
|
|
|
|
|
77
|
$session = $self->_data_ses_resolve($session); |
370
|
34
|
100
|
|
|
|
90
|
return undef unless defined $session; |
371
|
32
|
|
|
|
|
91
|
return $session->ID; |
372
|
|
|
|
|
|
|
} |
373
|
|
|
|
|
|
|
|
374
|
|
|
|
|
|
|
### Sweep the GC marks. |
375
|
|
|
|
|
|
|
|
376
|
|
|
|
|
|
|
sub _data_ses_gc_sweep { |
377
|
3962
|
|
|
3962
|
|
5901
|
my $self = shift; |
378
|
|
|
|
|
|
|
|
379
|
3962
|
|
|
|
|
6123
|
TRACE_REFCNT and _warn " trying sweep"; |
380
|
3962
|
|
|
|
|
17960
|
while (@kr_marked_for_gc) { |
381
|
810
|
|
|
|
|
2954
|
my %temp_marked = %kr_marked_for_gc; |
382
|
810
|
|
|
|
|
1702
|
%kr_marked_for_gc = (); |
383
|
|
|
|
|
|
|
|
384
|
810
|
|
|
|
|
2292
|
my @todo = reverse @kr_marked_for_gc; |
385
|
810
|
|
|
|
|
2266
|
@kr_marked_for_gc = (); |
386
|
|
|
|
|
|
|
|
387
|
|
|
|
|
|
|
# Never GC the POE::Kernel singleton. |
388
|
810
|
|
|
|
|
2739
|
delete $temp_marked{$self->ID}; |
389
|
|
|
|
|
|
|
|
390
|
810
|
|
|
|
|
2162
|
foreach my $sid (@todo) { |
391
|
1524
|
100
|
|
|
|
4989
|
next unless delete $temp_marked{$sid}; |
392
|
484
|
|
|
|
|
2458
|
$self->_data_ses_stop($sid); |
393
|
|
|
|
|
|
|
} |
394
|
|
|
|
|
|
|
} |
395
|
|
|
|
|
|
|
} |
396
|
|
|
|
|
|
|
|
397
|
|
|
|
|
|
|
### Decrement a session's main reference count. This is called by |
398
|
|
|
|
|
|
|
### each watcher when the last thing it watches for the session goes |
399
|
|
|
|
|
|
|
### away. In other words, a session's reference count should only |
400
|
|
|
|
|
|
|
### enumerate the different types of things being watched; not the |
401
|
|
|
|
|
|
|
### number of each. |
402
|
|
|
|
|
|
|
|
403
|
|
|
|
|
|
|
sub _data_ses_refcount_dec { |
404
|
4544
|
|
|
4544
|
|
6848
|
my ($self, $sid) = @_; |
405
|
|
|
|
|
|
|
|
406
|
4544
|
|
|
|
|
4570
|
if (ASSERT_DATA) { |
407
|
|
|
|
|
|
|
_trap("decrementing refcount of a nonexistent session") |
408
|
|
|
|
|
|
|
unless exists $kr_sessions{$sid}; |
409
|
|
|
|
|
|
|
} |
410
|
|
|
|
|
|
|
|
411
|
4544
|
|
|
|
|
9239
|
if (TRACE_REFCNT) { |
412
|
|
|
|
|
|
|
_cluck( |
413
|
|
|
|
|
|
|
" decrementing refcount for ", |
414
|
|
|
|
|
|
|
$self->_data_alias_loggable($sid) |
415
|
|
|
|
|
|
|
); |
416
|
|
|
|
|
|
|
} |
417
|
|
|
|
|
|
|
|
418
|
4543
|
100
|
|
|
|
6003
|
if (--$kr_sessions{$sid}->[SS_REFCOUNT] < 1) { |
419
|
3736
|
|
|
|
|
11179
|
TRACE_REFCNT and _warn " session $sid marked for gc"; |
420
|
2855
|
100
|
|
|
|
924836
|
unless ($sid eq $self->ID) { |
421
|
1338
|
|
|
|
|
4905
|
push @kr_marked_for_gc, $sid; |
422
|
1086
|
|
|
|
|
4784
|
$kr_marked_for_gc{$sid} = $sid; |
423
|
|
|
|
|
|
|
} |
424
|
|
|
|
|
|
|
} |
425
|
|
|
|
|
|
|
|
426
|
1740
|
|
|
|
|
2261
|
$self->_data_ses_dump_refcounts($sid) if TRACE_REFCNT; |
427
|
|
|
|
|
|
|
|
428
|
2873
|
|
|
|
|
4570
|
if (ASSERT_DATA and $kr_sessions{$sid}->[SS_REFCOUNT] < 0) { |
429
|
|
|
|
|
|
|
_trap( |
430
|
|
|
|
|
|
|
$self->_data_alias_loggable($sid), |
431
|
|
|
|
|
|
|
" reference count went below zero" |
432
|
|
|
|
|
|
|
); |
433
|
|
|
|
|
|
|
} |
434
|
|
|
|
|
|
|
} |
435
|
|
|
|
|
|
|
|
436
|
|
|
|
|
|
|
### Increment a session's main reference count. |
437
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
sub _data_ses_refcount_inc { |
439
|
8653
|
|
|
5117
|
|
19887
|
my ($self, $sid) = @_; |
440
|
|
|
|
|
|
|
|
441
|
7270
|
|
|
|
|
767288
|
if (ASSERT_DATA) { |
442
|
|
|
|
|
|
|
_trap("incrementing refcount for nonexistent session") |
443
|
|
|
|
|
|
|
unless exists $kr_sessions{$sid}; |
444
|
|
|
|
|
|
|
} |
445
|
|
|
|
|
|
|
|
446
|
5118
|
|
|
|
|
9961
|
if (TRACE_REFCNT) { |
447
|
|
|
|
|
|
|
_cluck( |
448
|
|
|
|
|
|
|
" incrementing refcount for ", |
449
|
|
|
|
|
|
|
$self->_data_alias_loggable($sid) |
450
|
|
|
|
|
|
|
); |
451
|
|
|
|
|
|
|
} |
452
|
|
|
|
|
|
|
|
453
|
5116
|
100
|
|
|
|
7219
|
if (++$kr_sessions{$sid}->[SS_REFCOUNT] > 0) { |
454
|
5116
|
|
|
|
|
22811
|
TRACE_REFCNT and _warn " session $sid unmarked for gc"; |
455
|
5116
|
|
|
|
|
1881922
|
delete $kr_marked_for_gc{$sid}; |
456
|
|
|
|
|
|
|
} |
457
|
4009
|
|
|
|
|
14980
|
elsif (TRACE_REFCNT) { |
458
|
|
|
|
|
|
|
_warn( |
459
|
|
|
|
|
|
|
"??? session $sid refcount = $kr_sessions{$sid}->[SS_REFCOUNT]" |
460
|
|
|
|
|
|
|
); |
461
|
|
|
|
|
|
|
} |
462
|
|
|
|
|
|
|
|
463
|
3654
|
|
|
|
|
11298
|
$self->_data_ses_dump_refcounts($sid) if TRACE_REFCNT; |
464
|
|
|
|
|
|
|
} |
465
|
|
|
|
|
|
|
|
466
|
|
|
|
|
|
|
sub _data_ses_dump_refcounts { |
467
|
6202
|
|
|
4740
|
|
9819
|
my ($self, $sid) = @_; |
468
|
|
|
|
|
|
|
|
469
|
7289
|
|
|
|
|
14766
|
my $ss = $kr_sessions{$sid}; |
470
|
|
|
|
|
|
|
|
471
|
4740
|
|
|
|
|
18790
|
_warn( |
472
|
|
|
|
|
|
|
" +----- GC test for ", $self->_data_alias_loggable($sid), "-----\n", |
473
|
|
|
|
|
|
|
" | total refcnt : ", $ss->[SS_REFCOUNT], "\n", |
474
|
|
|
|
|
|
|
" | event count : ", $self->_data_ev_get_count_to($sid), "\n", |
475
|
|
|
|
|
|
|
" | post count : ", $self->_data_ev_get_count_from($sid), "\n", |
476
|
4740
|
|
|
|
|
13498
|
" | child sessions: ", scalar(keys(%{$ss->[SS_CHILDREN]})), "\n", |
477
|
|
|
|
|
|
|
" | handles in use: ", $self->_data_handle_count_ses($sid), "\n", |
478
|
|
|
|
|
|
|
" | aliases in use: ", $self->_data_alias_count_ses($sid), "\n", |
479
|
|
|
|
|
|
|
" | extra refs : ", $self->_data_extref_count_ses($sid), "\n", |
480
|
|
|
|
|
|
|
" | pid count : ", $self->_data_sig_session_awaits_pids($sid), "\n", |
481
|
|
|
|
|
|
|
" +---------------------------------------------------\n", |
482
|
|
|
|
|
|
|
); |
483
|
|
|
|
|
|
|
|
484
|
4740
|
100
|
100
|
|
|
38505
|
unless ($ss->[SS_REFCOUNT] and $self->_data_sig_session_awaits_pids($sid)) { |
485
|
4537
|
|
|
|
|
13349
|
_warn( |
486
|
|
|
|
|
|
|
" | ", $self->_data_alias_loggable($sid), |
487
|
|
|
|
|
|
|
" is eligible for garbage collection.\n", |
488
|
|
|
|
|
|
|
" +---------------------------------------------------\n", |
489
|
|
|
|
|
|
|
); |
490
|
|
|
|
|
|
|
} |
491
|
|
|
|
|
|
|
|
492
|
4740
|
|
|
|
|
20257
|
_carp " | called"; |
493
|
|
|
|
|
|
|
} |
494
|
|
|
|
|
|
|
|
495
|
|
|
|
|
|
|
# Query a session's reference count. Added for testing purposes. |
496
|
|
|
|
|
|
|
|
497
|
|
|
|
|
|
|
sub _data_ses_refcount { |
498
|
43
|
|
|
43
|
|
2778
|
my ($self, $sid) = @_; |
499
|
43
|
|
|
|
|
257
|
return $kr_sessions{$sid}->[SS_REFCOUNT]; |
500
|
|
|
|
|
|
|
} |
501
|
|
|
|
|
|
|
|
502
|
|
|
|
|
|
|
### Compatibility function to do a GC sweep on attempted garbage |
503
|
|
|
|
|
|
|
### collection. The tests still try to call this. |
504
|
|
|
|
|
|
|
|
505
|
|
|
|
|
|
|
sub _data_ses_collect_garbage { |
506
|
1
|
|
|
1
|
|
361
|
my ($self, $sid) = @_; |
507
|
|
|
|
|
|
|
# TODO - Deprecation warning. |
508
|
1
|
|
|
|
|
6
|
$self->_data_ses_gc_sweep(); |
509
|
|
|
|
|
|
|
} |
510
|
|
|
|
|
|
|
|
511
|
|
|
|
|
|
|
### Return the number of sessions we know about. |
512
|
|
|
|
|
|
|
|
513
|
|
|
|
|
|
|
sub _data_ses_count { |
514
|
4453
|
|
|
4453
|
|
16068
|
return scalar keys %kr_sessions; |
515
|
|
|
|
|
|
|
} |
516
|
|
|
|
|
|
|
|
517
|
|
|
|
|
|
|
### Close down a session by force. |
518
|
|
|
|
|
|
|
|
519
|
|
|
|
|
|
|
# Stop a session, dispatching _stop, _parent, and _child as necessary. |
520
|
|
|
|
|
|
|
# |
521
|
|
|
|
|
|
|
# Dispatch _stop to a session, removing it from the kernel's data |
522
|
|
|
|
|
|
|
# structures as a side effect. |
523
|
|
|
|
|
|
|
|
524
|
|
|
|
|
|
|
my %already_stopping; |
525
|
|
|
|
|
|
|
|
526
|
|
|
|
|
|
|
sub _data_ses_stop { |
527
|
788
|
|
|
788
|
|
1874
|
my ($self, $sid) = @_; |
528
|
|
|
|
|
|
|
|
529
|
|
|
|
|
|
|
# Don't stop a session that's already in the throes of stopping. |
530
|
|
|
|
|
|
|
# This can happen with exceptions, during die() in _stop. It can |
531
|
|
|
|
|
|
|
# probably be removed if exceptions are. |
532
|
|
|
|
|
|
|
|
533
|
788
|
50
|
|
|
|
2078
|
return if exists $already_stopping{$sid}; |
534
|
788
|
|
|
|
|
1505
|
$already_stopping{$sid} = 1; |
535
|
|
|
|
|
|
|
|
536
|
788
|
|
|
|
|
1877
|
TRACE_REFCNT and _warn " stopping session $sid"; |
537
|
|
|
|
|
|
|
|
538
|
788
|
|
|
|
|
1620
|
if (ASSERT_DATA) { |
539
|
|
|
|
|
|
|
_trap("stopping a nonexistent session") unless exists $kr_sessions{$sid}; |
540
|
|
|
|
|
|
|
} |
541
|
|
|
|
|
|
|
|
542
|
788
|
|
|
|
|
2125
|
if (TRACE_SESSIONS) { |
543
|
|
|
|
|
|
|
_warn(" stopping ", $self->_data_alias_loggable($sid)); |
544
|
|
|
|
|
|
|
} |
545
|
|
|
|
|
|
|
|
546
|
|
|
|
|
|
|
# Maintain referential integrity between parents and children. |
547
|
|
|
|
|
|
|
# First move the children of the stopping session up to its parent. |
548
|
787
|
|
|
|
|
867
|
my $parent = $self->_data_ses_get_parent($sid); |
549
|
|
|
|
|
|
|
|
550
|
787
|
|
|
|
|
2296
|
foreach my $child ($self->_data_ses_get_children($sid)) { |
551
|
707
|
|
|
|
|
2823
|
$self->_dispatch_event( |
552
|
|
|
|
|
|
|
$parent, $self, |
553
|
|
|
|
|
|
|
EN_CHILD, ET_CHILD, [ CHILD_GAIN, $child ], |
554
|
|
|
|
|
|
|
__FILE__, __LINE__, undef, monotime(), -__LINE__ |
555
|
|
|
|
|
|
|
); |
556
|
386
|
|
|
|
|
1078
|
$self->_dispatch_event( |
557
|
|
|
|
|
|
|
$child, $self, |
558
|
|
|
|
|
|
|
EN_PARENT, ET_PARENT, |
559
|
|
|
|
|
|
|
[ $self->_data_ses_get_parent($child->ID), $parent, ], |
560
|
|
|
|
|
|
|
__FILE__, __LINE__, undef, monotime(), -__LINE__ |
561
|
|
|
|
|
|
|
); |
562
|
|
|
|
|
|
|
} |
563
|
|
|
|
|
|
|
|
564
|
|
|
|
|
|
|
# Referential integrity has been dealt with. Now notify the session |
565
|
|
|
|
|
|
|
# that it has been stopped. |
566
|
|
|
|
|
|
|
|
567
|
81
|
|
|
|
|
167
|
my $session = $kr_sessions{$sid}[SS_SESSION]; |
568
|
402
|
|
|
|
|
960
|
my $stop_return = $self->_dispatch_event( |
569
|
|
|
|
|
|
|
$session, $self->get_active_session(), |
570
|
|
|
|
|
|
|
EN_STOP, ET_STOP, [], |
571
|
|
|
|
|
|
|
__FILE__, __LINE__, undef, monotime(), -__LINE__ |
572
|
|
|
|
|
|
|
); |
573
|
|
|
|
|
|
|
|
574
|
|
|
|
|
|
|
# If the departing session has a parent, notify it that the session |
575
|
|
|
|
|
|
|
# is being lost. |
576
|
|
|
|
|
|
|
|
577
|
787
|
100
|
|
|
|
1930
|
if (defined $parent) { |
578
|
766
|
|
|
|
|
2710
|
$self->_dispatch_event( |
579
|
|
|
|
|
|
|
$parent, $self, |
580
|
|
|
|
|
|
|
EN_CHILD, ET_CHILD, [ CHILD_LOSE, $session, $stop_return ], |
581
|
|
|
|
|
|
|
__FILE__, __LINE__, undef, monotime(), -__LINE__ |
582
|
|
|
|
|
|
|
); |
583
|
|
|
|
|
|
|
} |
584
|
|
|
|
|
|
|
|
585
|
|
|
|
|
|
|
# Deallocate the session. |
586
|
|
|
|
|
|
|
|
587
|
701
|
|
|
|
|
2719
|
$self->_data_ses_free($sid); |
588
|
|
|
|
|
|
|
|
589
|
|
|
|
|
|
|
# Stop the main loop if everything is gone. |
590
|
|
|
|
|
|
|
# XXX - Under Tk this is called twice. Why? WHY is it called twice? |
591
|
703
|
100
|
|
|
|
3290
|
unless (keys %kr_sessions) { |
592
|
728
|
|
|
|
|
2304
|
$self->loop_halt(); |
593
|
|
|
|
|
|
|
} |
594
|
|
|
|
|
|
|
|
595
|
552
|
|
|
|
|
1744
|
delete $already_stopping{$sid}; |
596
|
|
|
|
|
|
|
} |
597
|
|
|
|
|
|
|
|
598
|
|
|
|
|
|
|
1; |
599
|
|
|
|
|
|
|
|
600
|
|
|
|
|
|
|
__END__ |