1# Manage session data structures on behalf of POE::Kernel.
2
3package POE::Resource::Sessions;
4
5use vars qw($VERSION);
6$VERSION = '1.368'; # NOTE - Should be #.### (three decimal places)
7
8# These methods are folded into POE::Kernel;
9package POE::Kernel;
10
11use strict;
12
13# Map stringy sessions to their references for _data_ses_resolve.
14my %kr_session_refs;
15# { $session_ref => $blessed, ... }
16
17### Session structure.
18my %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
33sub SS_SESSION    () { 0 }
34sub SS_REFCOUNT   () { 1 }
35sub SS_PARENT     () { 2 }
36sub SS_CHILDREN   () { 3 }
37sub SS_PROCESSES  () { 4 }
38
39BEGIN { $POE::Kernel::poe_kernel->[KR_SESSIONS] = \%kr_sessions; }
40
41sub _data_ses_relocate_kernel_id {
42  my ($self, $old_id, $new_id) = @_;
43
44  while (my ($sid, $ses_rec) = each %kr_sessions) {
45    my $children = $ses_rec->[SS_CHILDREN];
46    $children->{$new_id} = delete $children->{$old_id}
47      if exists $children->{$old_id};
48  }
49
50  $kr_sessions{$new_id} = delete $kr_sessions{$old_id}
51    if exists $kr_sessions{$old_id};
52}
53
54### End-run leak checking.
55
56sub _data_ses_clone {
57  %kr_session_refs = ();
58  foreach my $ses_ref (map { $_->[SS_SESSION] } values %kr_sessions) {
59    $kr_session_refs{$ses_ref} = $ses_ref;
60  }
61}
62
63sub _data_ses_finalize {
64  my $finalized_ok = 1;
65
66  while (my ($sid, $ses_rec) = each %kr_sessions) {
67    $finalized_ok = 0;
68    _warn(
69      "!!! Leaked session: $sid\n",
70      "!!!\trefcnt = $ses_rec->[SS_REFCOUNT]\n",
71      "!!!\tparent = $ses_rec->[SS_PARENT]\n",
72      "!!!\tchilds = ", join("; ", keys(%{$ses_rec->[SS_CHILDREN]})), "\n",
73      "!!!\tprocs  = ", join("; ", keys(%{$ses_rec->[SS_PROCESSES]})),"\n",
74    );
75  }
76
77  while (my ($stringy, $blessed) = each %kr_session_refs) {
78    $finalized_ok = 0;
79    _warn "!!! Leaked stringy session $stringy = $blessed\n";
80    _warn "!!!\tBad clone detected, while we're at it.\n" if (
81      $stringy ne "$blessed"
82    );
83  }
84
85  return $finalized_ok;
86}
87
88### Enter a new session into the back-end stuff.
89
90my %kr_marked_for_gc;
91my @kr_marked_for_gc;
92
93sub _data_ses_allocate {
94  my ($self, $session, $sid, $parent_id) = @_;
95
96  my $parent;
97  if (defined $parent_id) {
98    _trap "parent session $parent_id does not exist" unless (
99      exists $kr_sessions{$parent_id}
100    );
101
102    $parent = $kr_sessions{$parent_id}[SS_SESSION];
103
104    _trap "session $session is already allocated" if exists $kr_sessions{$sid};
105  }
106
107  TRACE_REFCNT and _warn "<rc> allocating $session";
108
109  $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  $self->_data_sid_set($sid, $session);
119
120  # For the stringy to blessed session reference lookup.
121  $kr_session_refs{$session} = $session;
122
123  # Manage parent/child relationship.
124  if (defined $parent_id) {
125    if (TRACE_SESSIONS) {
126      _warn(
127        "<ss> ",
128        $self->_data_alias_loggable($sid), " has parent ",
129        $self->_data_alias_loggable($parent_id)
130      );
131    }
132
133    $kr_sessions{$parent_id}->[SS_CHILDREN]->{$sid} = $session;
134    $self->_data_ses_refcount_inc($parent_id);
135  }
136
137  TRACE_REFCNT and _warn "<rc> $session marked for gc";
138  unless ($sid eq $self->ID) {
139    push @kr_marked_for_gc, $sid;
140    $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
152sub _data_ses_free {
153  my ($self, $sid) = @_;
154
155  TRACE_REFCNT and do {
156    _warn "<rc> freeing session $sid";
157    _trap("!!! free defunct session $sid?!\n") unless (
158      $self->_data_ses_exists($sid)
159    );
160  };
161
162  if (TRACE_SESSIONS) {
163    _warn "<ss> freeing ", $self->_data_alias_loggable($sid);
164  }
165
166  # Manage parent/child relationships.
167
168  my $parent   = $kr_sessions{$sid}->[SS_PARENT];
169  my @children = $self->_data_ses_get_children($sid);
170
171  if (defined $parent) {
172    my $parent_id = $parent->ID;
173
174    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    _trap "internal inconsistency ($parent_id/$sid)"
192      unless delete $kr_sessions{$parent_id}->[SS_CHILDREN]->{$sid};
193
194    $kr_sessions{$sid}->[SS_PARENT] = undef;
195
196    if (TRACE_SESSIONS) {
197      _cluck(
198        "<ss> removed ",
199        $self->_data_alias_loggable($sid), " from ",
200        $self->_data_alias_loggable($parent_id)
201      );
202    }
203
204    $self->_data_ses_refcount_dec($parent_id);
205
206    # Move the departing session's children to its parent.
207
208    foreach (@children) {
209      $self->_data_ses_move_child($_->ID, $parent_id)
210    }
211  }
212  elsif (ASSERT_DATA) {
213    _trap "no parent to give children to" if @children;
214  }
215
216  my $session = $kr_sessions{$sid}[SS_SESSION];
217
218  # Things which do not hold reference counts.
219
220  $self->_data_sid_clear($sid);                # Remove from SID tables.
221  $self->_data_sig_clear_session($sid);        # Remove all leftover signals.
222
223  # Things which do hold reference counts.
224
225  $self->_data_alias_clear_session($sid);      # Remove all leftover aliases.
226  $self->_data_extref_clear_session($sid);     # Remove all leftover extrefs.
227  $self->_data_handle_clear_session($sid);     # Remove all leftover handles.
228
229  $self->_data_ev_clear_session($sid);         # Remove all leftover events.
230
231  # Remove the session itself.
232
233  delete $kr_marked_for_gc{$sid};
234  delete $kr_sessions{$sid};
235  delete $kr_session_refs{$session};
236}
237
238### Move a session to a new parent.
239
240sub _data_ses_move_child {
241  my ($self, $sid, $new_parent_id) = @_;
242
243  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  if (TRACE_SESSIONS) {
251    _warn(
252      "<ss> moving ",
253      $self->_data_alias_loggable($sid), " to ",
254      $self->_data_alias_loggable($new_parent_id)
255    );
256  }
257
258  my $old_parent_id = $self->_data_ses_get_parent($sid)->ID;
259
260  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  delete $kr_sessions{$old_parent_id}->[SS_CHILDREN]->{$sid};
267
268  if (TRACE_SESSIONS) {
269    _warn(
270      "<ss> removed ",
271      $self->_data_alias_loggable($sid), " from ",
272      $self->_data_alias_loggable($old_parent_id)
273    );
274  }
275
276  $self->_data_ses_refcount_dec($old_parent_id);
277
278  # Change the session's parent.
279  $kr_sessions{$sid}->[SS_PARENT] = $kr_sessions{$new_parent_id}[SS_SESSION];
280
281  if (TRACE_SESSIONS) {
282    _warn(
283      "<ss> 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  $kr_sessions{$new_parent_id}->[SS_CHILDREN]->{$sid} = (
291    $kr_sessions{$sid}[SS_SESSION]
292  );
293
294  if (TRACE_SESSIONS) {
295    _warn(
296      "<ss> added ",
297      $self->_data_alias_loggable($sid), " as child of ",
298      $self->_data_alias_loggable($new_parent_id)
299    );
300  }
301
302  $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
313sub _data_ses_get_parent {
314  my ($self, $sid) = @_;
315  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  return $kr_sessions{$sid}->[SS_PARENT];
321}
322
323### Get a session's children.
324
325sub _data_ses_get_children {
326  my ($self, $sid) = @_;
327  if (ASSERT_DATA) {
328    _trap("retrieving children of a nonexistent session")
329      unless exists $kr_sessions{$sid};
330  }
331  return values %{$kr_sessions{$sid}->[SS_CHILDREN]};
332}
333
334### Is a session a child of another?
335
336sub _data_ses_is_child {
337  my ($self, $parent_id, $child_id) = @_;
338  if (ASSERT_DATA) {
339    _trap("testing is-child of a nonexistent parent session")
340      unless exists $kr_sessions{$parent_id};
341  }
342  return(
343    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
352sub _data_ses_exists {
353  my ($self, $sid) = @_;
354  return exists $kr_sessions{$sid};
355}
356
357### Resolve a session into its reference.
358
359sub _data_ses_resolve {
360  my ($self, $session) = @_;
361  return undef unless exists $kr_session_refs{$session}; # Prevents autoviv.
362  return $kr_session_refs{$session};
363}
364
365### Resolve a session ID into its reference.
366
367sub _data_ses_resolve_to_id {
368  my ($self, $session) = @_;
369  $session = $self->_data_ses_resolve($session);
370  return undef unless defined $session;
371  return $session->ID;
372}
373
374### Sweep the GC marks.
375
376sub _data_ses_gc_sweep {
377  my $self = shift;
378
379  TRACE_REFCNT and _warn "<rc> trying sweep";
380  while (@kr_marked_for_gc) {
381    my %temp_marked = %kr_marked_for_gc;
382    %kr_marked_for_gc = ();
383
384    my @todo = reverse @kr_marked_for_gc;
385    @kr_marked_for_gc = ();
386
387    # Never GC the POE::Kernel singleton.
388    delete $temp_marked{$self->ID};
389
390    foreach my $sid (@todo) {
391      next unless delete $temp_marked{$sid};
392      $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
403sub _data_ses_refcount_dec {
404  my ($self, $sid) = @_;
405
406  if (ASSERT_DATA) {
407    _trap("decrementing refcount of a nonexistent session")
408      unless exists $kr_sessions{$sid};
409  }
410
411  if (TRACE_REFCNT) {
412    _cluck(
413      "<rc> decrementing refcount for ",
414      $self->_data_alias_loggable($sid)
415    );
416  }
417
418  if (--$kr_sessions{$sid}->[SS_REFCOUNT] < 1) {
419    TRACE_REFCNT and _warn "<rc> session $sid marked for gc";
420    unless ($sid eq $self->ID) {
421      push @kr_marked_for_gc, $sid;
422      $kr_marked_for_gc{$sid} = $sid;
423    }
424  }
425
426  $self->_data_ses_dump_refcounts($sid) if TRACE_REFCNT;
427
428  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
438sub _data_ses_refcount_inc {
439  my ($self, $sid) = @_;
440
441  if (ASSERT_DATA) {
442    _trap("incrementing refcount for nonexistent session")
443      unless exists $kr_sessions{$sid};
444  }
445
446  if (TRACE_REFCNT) {
447    _cluck(
448      "<rc> incrementing refcount for ",
449      $self->_data_alias_loggable($sid)
450    );
451  }
452
453  if (++$kr_sessions{$sid}->[SS_REFCOUNT] > 0) {
454    TRACE_REFCNT and _warn "<rc> session $sid unmarked for gc";
455    delete $kr_marked_for_gc{$sid};
456  }
457  elsif (TRACE_REFCNT) {
458    _warn(
459      "??? session $sid refcount = $kr_sessions{$sid}->[SS_REFCOUNT]"
460    );
461  }
462
463  $self->_data_ses_dump_refcounts($sid) if TRACE_REFCNT;
464}
465
466sub _data_ses_dump_refcounts {
467  my ($self, $sid) = @_;
468
469  my $ss = $kr_sessions{$sid};
470
471  _warn(
472    "<rc> +----- GC test for ", $self->_data_alias_loggable($sid), "-----\n",
473    "<rc> | total refcnt  : ", $ss->[SS_REFCOUNT], "\n",
474    "<rc> | event count   : ", $self->_data_ev_get_count_to($sid), "\n",
475    "<rc> | post count    : ", $self->_data_ev_get_count_from($sid), "\n",
476    "<rc> | child sessions: ", scalar(keys(%{$ss->[SS_CHILDREN]})), "\n",
477    "<rc> | handles in use: ", $self->_data_handle_count_ses($sid), "\n",
478    "<rc> | aliases in use: ", $self->_data_alias_count_ses($sid), "\n",
479    "<rc> | extra refs    : ", $self->_data_extref_count_ses($sid), "\n",
480    "<rc> | pid count     : ", $self->_data_sig_session_awaits_pids($sid), "\n",
481    "<rc> +---------------------------------------------------\n",
482  );
483
484  unless ($ss->[SS_REFCOUNT] and $self->_data_sig_session_awaits_pids($sid)) {
485    _warn(
486      "<rc> | ", $self->_data_alias_loggable($sid),
487      " is eligible for garbage collection.\n",
488      "<rc> +---------------------------------------------------\n",
489    );
490  }
491
492  _carp "<rc> | called";
493}
494
495# Query a session's reference count.  Added for testing purposes.
496
497sub _data_ses_refcount {
498  my ($self, $sid) = @_;
499  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
505sub _data_ses_collect_garbage {
506  my ($self, $sid) = @_;
507  # TODO - Deprecation warning.
508  $self->_data_ses_gc_sweep();
509}
510
511### Return the number of sessions we know about.
512
513sub _data_ses_count {
514  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
524my %already_stopping;
525
526sub _data_ses_stop {
527  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  return if exists $already_stopping{$sid};
534  $already_stopping{$sid} = 1;
535
536  TRACE_REFCNT and _warn "<rc> stopping session $sid";
537
538  if (ASSERT_DATA) {
539    _trap("stopping a nonexistent session") unless exists $kr_sessions{$sid};
540  }
541
542  if (TRACE_SESSIONS) {
543    _warn("<ss> 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  my $parent = $self->_data_ses_get_parent($sid);
549
550  foreach my $child ($self->_data_ses_get_children($sid)) {
551    $self->_dispatch_event(
552      $parent, $self,
553      EN_CHILD, ET_CHILD, [ CHILD_GAIN, $child ],
554      __FILE__, __LINE__, undef, monotime(), -__LINE__
555    );
556    $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  my $session = $kr_sessions{$sid}[SS_SESSION];
568  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  if (defined $parent) {
578    $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  $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  unless (keys %kr_sessions) {
592    $self->loop_halt();
593  }
594
595  delete $already_stopping{$sid};
596}
597
5981;
599
600__END__
601
602=head1 NAME
603
604POE::Resource::Sessions - internal session manager for POE::Kernel
605
606=head1 SYNOPSIS
607
608There is no public API.
609
610=head1 DESCRIPTION
611
612POE::Resource::Sessions is a mix-in class for POE::Kernel.  It
613provides the internal features that manage sessions, regardless of the
614session type.  It is used internally by POE::Kernel. so it has no
615public interface.
616
617=head1 SEE ALSO
618
619See L<POE::Session> and L<POE::NFA> for one type of session.  CPAN
620also have others.
621
622See L<POE::Kernel/Sessions> for a discussion about POE::Kernel
623sessions.
624
625See L<POE::Kernel/Session Lifespans> to learn why sessions run, and
626how to stop them.
627
628See L<POE::Kernel/Session Management> for information about managing
629sessions in your applications, and the events that occur when sessions
630come and go.
631
632See L<POE::Kernel/Session Helper Methods> for friend methods between
633POE::Kernel and POE::Session classes.
634
635See L<POE::Kernel/Resources> for public information about POE
636resources.
637
638See L<POE::Resource> for general discussion about resources and the
639classes that manage them.
640
641=head1 BUGS
642
643None known.
644
645=head1 AUTHORS & COPYRIGHTS
646
647Please see L<POE> for more information about authors and contributors.
648
649=cut
650
651# rocco // vim: ts=2 sw=2 expandtab
652# TODO - Edit.
653