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