view release on metacpan or  search on metacpan

lib/POE/Resource/Sessions.pm  view on Meta::CPAN

# Manage session data structures on behalf of POE::Kernel.

package POE::Resource::Sessions;

use vars qw($VERSION);
$VERSION = '1.370'; # NOTE - Should be #.### (three decimal places)

# These methods are folded into POE::Kernel;
package POE::Kernel;

use strict;

# Map stringy sessions to their references for _data_ses_resolve.
my %kr_session_refs;
# { $session_ref => $blessed, ... }

### Session structure.
my %kr_sessions;
#  { $session_id =>
#    [ $blessed_session,         SS_SESSION
#      $total_reference_count,   SS_REFCOUNT
#      $parent_session,          SS_PARENT
#      { $child_session_id => $blessed_ref,  SS_CHILDREN
#        ...,
#      },
#      { $process_id => $placeholder_value,  SS_PROCESSES
#        ...,
#      },
#    ],
#    ...,
#  };

sub SS_SESSION    () { 0 }
sub SS_REFCOUNT   () { 1 }
sub SS_PARENT     () { 2 }
sub SS_CHILDREN   () { 3 }
sub SS_PROCESSES  () { 4 }

BEGIN { $POE::Kernel::poe_kernel->[KR_SESSIONS] = \%kr_sessions; }

sub _data_ses_relocate_kernel_id {
  my ($self, $old_id, $new_id) = @_;

  while (my ($sid, $ses_rec) = each %kr_sessions) {
    my $children = $ses_rec->[SS_CHILDREN];
    $children->{$new_id} = delete $children->{$old_id}
      if exists $children->{$old_id};
  }

  $kr_sessions{$new_id} = delete $kr_sessions{$old_id}
    if exists $kr_sessions{$old_id};
}

### End-run leak checking.

sub _data_ses_clone {
  %kr_session_refs = ();
  foreach my $ses_ref (map { $_->[SS_SESSION] } values %kr_sessions) {
    $kr_session_refs{$ses_ref} = $ses_ref;
  }
}

sub _data_ses_finalize {
  my $finalized_ok = 1;

  while (my ($sid, $ses_rec) = each %kr_sessions) {
    $finalized_ok = 0;
    _warn(
      "!!! Leaked session: $sid\n",
      "!!!\trefcnt = $ses_rec->[SS_REFCOUNT]\n",
      "!!!\tparent = $ses_rec->[SS_PARENT]\n",
      "!!!\tchilds = ", join("; ", keys(%{$ses_rec->[SS_CHILDREN]})), "\n",
      "!!!\tprocs  = ", join("; ", keys(%{$ses_rec->[SS_PROCESSES]})),"\n",
    );
  }

  while (my ($stringy, $blessed) = each %kr_session_refs) {
    $finalized_ok = 0;
    _warn "!!! Leaked stringy session $stringy = $blessed\n";
    _warn "!!!\tBad clone detected, while we're at it.\n" if (
      $stringy ne "$blessed"
    );
  }

  return $finalized_ok;
}

### Enter a new session into the back-end stuff.

my %kr_marked_for_gc;
my @kr_marked_for_gc;

sub _data_ses_allocate {
  my ($self, $session, $sid, $parent_id) = @_;

  my $parent;
  if (defined $parent_id) {
    _trap "parent session $parent_id does not exist" unless (
      exists $kr_sessions{$parent_id}
    );