File Coverage

blib/lib/POE/Resource/Sessions.pm
Criterion Covered Total %
statement 150 161 93.1
branch 34 40 85.0
condition 4 6 66.6
subroutine 22 23 95.6
pod n/a
total 210 230 91.3


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__