typo fixes
[poe:poe-test-loops.git] / lib / POE / Test / Loops / ses_session.pm
1 #!/usr/bin/perl -w
2 # vim: ts=2 sw=2 expandtab
3
4 # Tests basic compilation and events.
5
6 use strict;
7
8 use lib qw(./mylib ../mylib);
9
10 sub POE::Kernel::ASSERT_DEFAULT () { 1 }
11
12 BEGIN {
13   package POE::Kernel;
14   use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'});
15 }
16
17 use Test::More tests => 41;
18 use POE;
19
20 diag("This test generates some STDERR during trace testing.");
21
22 ### Test parameters and results.
23
24 my $machine_count  = 10;
25 my $event_count    = 5;
26 my $sigalrm_caught = 0;
27 my $sigpipe_caught = 0;
28 my $sender_count   = 0;
29 my $got_heap_count = 0;
30 my $default_count  = 0;
31
32 die "machine count must be even" if $machine_count & 1;
33
34 ### Status registers for each state machine instance.
35
36 my ( @completions, @objpack );
37
38 #------------------------------------------------------------------------------
39 # Define a simple state machine.
40
41 sub task_start {
42   my ($kernel, $session, $heap, $id) = @_[KERNEL, SESSION, HEAP, ARG0];
43   $heap->{count} = 0;
44   $kernel->yield( count => $id );
45 }
46
47 sub task_run {
48   my ($kernel, $session, $heap, $id) = @_[KERNEL, SESSION, HEAP, ARG0];
49
50   $sender_count++ if $_[SENDER] == $session;
51
52   if ($heap->{count} & 1) {
53     $kernel->yield( bogus => $id ); # _default
54   }
55   else {
56     $kernel->post( $session, bogus => $id ); # _default
57   }
58
59   if ( $kernel->call( $session, next_count => $id ) < $event_count ) {
60
61     if ($heap->{count} & 1) {
62       $kernel->yield( count => $id );
63     }
64     else {
65       $kernel->post( $session, count => $id );
66     }
67
68   }
69   else {
70     $heap->{id} = $id;
71   }
72 }
73
74 sub task_default {
75   return 0 if $_[ARG0] eq '_signal'; # ignore signals
76   $default_count++ if $_[STATE] eq '_default';
77 }
78
79 sub task_next_count {
80   my ($kernel, $session, $heap, $id) = @_[KERNEL, SESSION, HEAP, ARG0];
81   ++$heap->{count};
82 }
83
84 sub task_stop {
85   $completions[$_[HEAP]->{id}] = $_[HEAP]->{count};
86   $got_heap_count++ if (
87     defined($_[HEAP]->{got_heap}) and
88     $_[HEAP]->{got_heap} == $_[HEAP]->{id}
89   );
90 }
91
92 #------------------------------------------------------------------------------
93 # Test simple signals.
94
95 # Spawn a quick state machine to test signals.  This is a classic
96 # example of inline states being just that: inline anonymous coderefs.
97 # It makes quick hacks quicker!
98 POE::Session->create(
99   inline_states => {
100     _start => sub {
101       $_[HEAP]->{kills_to_go} = $event_count;
102       $_[KERNEL]->sig( ALRM => 'sigalrm_target' );
103       $_[KERNEL]->sig( PIPE => 'sigpipe_target' );
104       $_[KERNEL]->delay( fire_signals => 0.5 );
105     },
106     fire_signals => sub {
107       if ($_[HEAP]->{kills_to_go}--) {
108         $_[KERNEL]->delay( fire_signals => 0.5 );
109         if ($^O eq 'MSWin32') {
110           $_[KERNEL]->signal( $_[KERNEL], 'ALRM' );
111           $_[KERNEL]->signal( $_[KERNEL], 'PIPE' );
112         }
113         else {
114           kill ALRM => $$;
115           kill PIPE => $$;
116         }
117       }
118       # One last timer so the session lingers long enough to catch
119       # the final signal.
120       else {
121         $_[KERNEL]->delay( done_waiting => 1 );
122       }
123     },
124     sigalrm_target => sub {
125       $sigalrm_caught++ if $_[ARG0] eq 'ALRM';
126       $_[KERNEL]->sig_handled();
127     },
128     sigpipe_target => sub {
129       $sigpipe_caught++ if $_[ARG0] eq 'PIPE';
130       $_[KERNEL]->sig_handled();
131     },
132     done_waiting => sub {
133       $_[KERNEL]->sig( ALRM => undef );
134       $_[KERNEL]->sig( PIPE => undef );
135     },
136     _stop => sub { }, # Pacify assertions.
137   }
138 );
139
140 # Spawn ten state machines.
141 for (my $i=0; $i<$machine_count; $i++) {
142
143   POE::Session->create(
144     inline_states => {
145       _start     => \&task_start,
146       _stop      => \&task_stop,
147       count      => \&task_run,
148       next_count => \&task_next_count,
149       _default   => \&task_default,
150     },
151     args => [ $i ],
152     heap => { got_heap => $i },
153   );
154 }
155
156 #------------------------------------------------------------------------------
157 # Simple client/server sessions using events as inter-session
158 # communications.  Tests postbacks, too.
159
160 POE::Session->create(
161   inline_states => {
162     _start => sub {
163       $_[KERNEL]->alias_set( 'server' );
164       $_[HEAP]->{response} = 0;
165     },
166     sync_query => sub {
167       $_[ARG0]->( ++$_[HEAP]->{response} );
168     },
169     query => sub {
170       $_[ARG0]->( ++$_[HEAP]->{response} );
171     },
172     _stop => sub { }, # Pacify assertions.
173   },
174 );
175
176 # A simple client session.  It requests five counts and then stops.
177 # Its magic is that it passes a postback for the response.
178
179 my $postback_test = 1;
180 my $callback_test = 1;
181
182 POE::Session->create(
183   inline_states => {
184     _start => sub {
185       $_[KERNEL]->yield( 'query' );
186       $_[HEAP]->{cookie} = 0;
187     },
188     query => sub {
189       $_[KERNEL]->post(
190         server =>
191         query  => $_[SESSION]->postback(response => ++$_[HEAP]->{cookie})
192       );
193       $_[HEAP]->{sync_called_back} = 0;
194       $_[KERNEL]->call(
195         server     =>
196         sync_query =>
197         $_[SESSION]->callback(sync_response => ++$_[HEAP]->{cookie})
198       );
199       $callback_test = 0 unless $_[HEAP]->{sync_called_back};
200     },
201     sync_response => sub {
202       my ($req, $rsp) = ($_[ARG0]->[0], $_[ARG1]->[0] + 1);
203       $callback_test = 0 unless $req == $rsp;
204       $_[HEAP]->{sync_called_back} = 1;
205     },
206     response => sub {
207       my ($req, $rsp) = ($_[ARG0]->[0], $_[ARG1]->[0] - 1);
208       $postback_test = 0 unless $req == $rsp;
209       if ($_[HEAP]->{cookie} < 5) {
210         $_[KERNEL]->yield( 'query' );
211       }
212     },
213     _stop => sub {
214       is(
215         $_[KERNEL]->get_active_session(), $_[SESSION],
216         "get_active_session within session"
217       );
218       is(
219         $_[KERNEL]->get_active_session()->get_heap(), $_[HEAP],
220         "get_heap during stop"
221       );
222     },
223   }
224 );
225
226 #------------------------------------------------------------------------------
227 # Unmapped package session.
228
229 package UnmappedPackage;
230 use POE::Session; # for constants
231
232 sub _start {
233   $_[KERNEL]->yield( 'count' );
234   $_[HEAP]->{count} = 0;
235   $_[HEAP]->{id} = $_[ARG0];
236 }
237
238 sub count {
239   return unless $_[OBJECT] eq __PACKAGE__;
240   $_[KERNEL]->yield( 'count' ) if ++$_[HEAP]->{count} < $event_count;
241 }
242
243 sub _stop {
244   $objpack[$_[HEAP]->{id}] = $_[HEAP]->{count};
245 }
246
247 #------------------------------------------------------------------------------
248 # Unmapped object session.
249
250 package UnmappedObject;
251 use POE::Session; # for constants
252
253 # Trivial constructor.
254 sub new { bless [ ], shift; }
255
256 sub _start {
257   $_[KERNEL]->yield( 'count' );
258   $_[HEAP]->{count} = 0;
259   $_[HEAP]->{id} = $_[ARG0];
260 }
261
262 sub count {
263   return unless ref($_[OBJECT]) eq __PACKAGE__;
264   $_[KERNEL]->yield( 'count' ) if ++$_[HEAP]->{count} < $event_count;
265 }
266
267 sub _stop {
268   $objpack[$_[HEAP]->{id}] = $_[HEAP]->{count};
269 }
270
271 #------------------------------------------------------------------------------
272 # Unmapped package session.
273
274 package MappedPackage;
275 use POE::Session; # for constants
276
277 sub my_start {
278   $_[KERNEL]->yield( 'count' );
279   $_[HEAP]->{count} = 0;
280   $_[HEAP]->{id} = $_[ARG0];
281 }
282
283 sub my_count {
284   return unless $_[OBJECT] eq __PACKAGE__;
285   $_[KERNEL]->yield( 'count' ) if ++$_[HEAP]->{count} < $event_count;
286 }
287
288 sub my_stop {
289   $objpack[$_[HEAP]->{id}] = $_[HEAP]->{count};
290 }
291
292 #------------------------------------------------------------------------------
293 # Unmapped object session.
294
295 package MappedObject;
296 use POE::Session; # for constants
297
298 # Trivial constructor.
299 sub new { bless [ ], shift; }
300
301 sub my_start {
302   $_[KERNEL]->yield( 'count' );
303   $_[HEAP]->{count} = 0;
304   $_[HEAP]->{id} = $_[ARG0];
305 }
306
307 sub my_count {
308   return unless ref($_[OBJECT]) eq __PACKAGE__;
309   $_[KERNEL]->yield( 'count' ) if ++$_[HEAP]->{count} < $event_count;
310 }
311
312 sub my_stop {
313   $objpack[$_[HEAP]->{id}] = $_[HEAP]->{count};
314 }
315
316 #------------------------------------------------------------------------------
317 # Test the Package and Object sessions.
318
319 package main;
320
321 # New style (create) object session without event to method name map.
322 POE::Session->create(
323   object_states => [
324     UnmappedObject->new() => [ '_start', 'count', '_stop' ],
325   ],
326   args => [ 0 ],
327 );
328
329 # New style (create) object session with event to method name map.
330 POE::Session->create(
331   object_states => [
332     MappedObject->new => {
333       _start => 'my_start',
334       count  => 'my_count',
335       _stop  => 'my_stop',
336     },
337   ],
338   args => [ 1 ],
339 );
340
341 # New style (create) package session without event to method name map.
342 POE::Session->create(
343   package_states => [
344     UnmappedPackage => [ '_start', 'count', '_stop' ],
345   ],
346   args => [ 2 ],
347 );
348
349 # New style (create) package session with event to method name map.
350 POE::Session->create(
351   package_states => [
352     MappedPackage => {
353       _start => 'my_start',
354       count  => 'my_count',
355       _stop  => 'my_stop',
356     },
357   ],
358   args => [ 3 ],
359 );
360
361 #------------------------------------------------------------------------------
362 # Test changing options
363 POE::Session->create(
364   inline_states => {
365     _start => sub {
366       my $orig = $_[SESSION]->option(default => 1);
367       Test::More::ok($orig, "option original value");
368       my $rv = $_[SESSION]->option('default');
369       Test::More::ok($rv, "set default option successfully");
370       $rv = $_[SESSION]->option('default' => $orig);
371       Test::More::ok($rv, "reset default option successfully");
372       $rv = $_[SESSION]->option('default');
373       Test::More::ok(!($rv xor $orig), "reset default option successfully");
374
375       $_[KERNEL]->yield("idle");
376     },
377     idle => sub { },
378     _stop => sub { }, # Pacify assertions.
379   },
380   options => { default => 1 },
381 );
382
383 #------------------------------------------------------------------------------
384 # Test deprecation of new(), test invalid arguments to create()
385 eval { POE::Session->new("foo" => sub { } ) };
386 ok($@ ne '', "new() is deprecated");
387
388 eval { POE::Session->create("an", "odd", "number", "of", "elephants") };
389 ok($@ ne '', "create() doesn't accept an odd number of args");
390
391 #------------------------------------------------------------------------------
392 # Main loop.
393
394 is(
395   $poe_kernel->get_active_session(), $poe_kernel,
396   "get_active_session before POE::Kernel->run()"
397 );
398
399 POE::Kernel->run();
400
401 is(
402   $poe_kernel->get_active_session(), $poe_kernel,
403   "get_active_session after POE::Kernel->run()"
404 );
405
406 #------------------------------------------------------------------------------
407 # Final tests.
408
409 # Now make sure they've run.
410 for (my $i=0; $i<$machine_count; $i++) {
411   is(
412     $completions[$i], $event_count,
413     "test $i ran"
414   );
415 }
416
417 # Were all the signals caught?
418 SKIP: {
419   if (($^O eq "MSWin32" or $^O eq "MacOS") and not $ENV{POE_DANTIC}) {
420     skip "$^O does not support signals", 2;
421   }
422
423   is(
424     $sigalrm_caught, $event_count,
425     "caught enough SIGALRMs"
426   );
427
428   is(
429     $sigpipe_caught, $event_count,
430     "caught enough SIGPIPEs"
431   );
432 }
433
434 # Did the postbacks work?
435 ok( $postback_test, "postback test" );
436 ok( $callback_test, "callback test" );
437
438 # Gratuitous tests to appease the coverage gods.
439 ok(
440   (ARG1 == ARG0+1) && (ARG2 == ARG1+1) && (ARG3 == ARG2+1) &&
441   (ARG4 == ARG3+1) && (ARG5 == ARG4+1) && (ARG6 == ARG5+1) &&
442   (ARG7 == ARG6+1) && (ARG8 == ARG7+1) && (ARG9 == ARG8+1),
443   "ARG constants are good"
444 );
445
446 is(
447   $sender_count, $machine_count * $event_count,
448   "sender_count"
449 );
450
451 is(
452   $default_count, $machine_count * $event_count,
453   "default_count"
454 );
455
456 is(
457   $got_heap_count, $machine_count,
458   "got_heap_count"
459 );
460
461 # Object/package sessions.
462 is_deeply(
463   \@objpack, [ ($event_count) x 4 ],
464   "object/package session event count"
465 );
466
467 my $sessions_destroyed = 0;
468 my $objects_destroyed = 0;
469 my $stop_called = 0;
470 my $parent_called = 0;
471 my $child_called = 0;
472
473 package POE::MySession;
474
475 use vars qw(@ISA);
476
477 use POE::Session;
478 @ISA = qw(POE::Session);
479
480 sub DESTROY {
481   $_[0]->SUPER::DESTROY;
482   $sessions_destroyed++;
483 }
484
485 package MyObject;
486
487 sub new { bless {} }
488 sub DESTROY { $objects_destroyed++ }
489
490 package main;
491
492 POE::MySession->create(
493   inline_states => {
494     _start => sub {
495       $_[HEAP]->{object} = MyObject->new;
496       POE::MySession->create(
497         inline_states => {
498           _start => sub {
499             $_[HEAP]->{object} = MyObject->new;
500             POE::MySession->create(
501               inline_states => {
502                 _start => sub {
503                   $_[HEAP]->{object} = MyObject->new;
504                   POE::MySession->create(
505                     inline_states => {
506                       _start => sub {
507                         $_[HEAP]->{object} = MyObject->new;
508                         $_[KERNEL]->delay(nonexistent => 3600);
509                         $_[KERNEL]->alias_set('test4');
510                       },
511                       _parent => sub {
512                         $parent_called++;
513                       },
514                       _child => sub { }, # To shush ASSERT
515                       _stop => sub {
516                         $stop_called++;
517                       },
518                     },
519                   );
520                   $_[KERNEL]->delay(nonexistent => 3600);
521                   $_[KERNEL]->alias_set('test3');
522                 },
523                 _parent => sub {
524                   $parent_called++;
525                 },
526                 _child => sub {
527                   $child_called++ if $_[ARG0] eq 'lose';
528                 },
529                 _stop => sub {
530                   $stop_called++;
531                 },
532               },
533             );
534             $_[KERNEL]->delay(nonexistent => 3600);
535             $_[KERNEL]->alias_set('test2');
536           },
537           _parent => sub {
538             $parent_called++;
539           },
540           _child => sub {
541             $child_called++ if $_[ARG0] eq 'lose';
542           },
543           _stop => sub {
544             $stop_called++;
545           },
546         },
547       );
548       $_[KERNEL]->delay(nonexistent => 3600);
549       $_[KERNEL]->alias_set('test1');
550       $_[KERNEL]->yield("stop");
551     },
552     _parent => sub {
553       $parent_called++;
554     },
555     _child => sub {
556       $child_called++ if $_[ARG0] eq 'lose';
557     },
558     _stop => sub {
559       $stop_called++;
560     },
561     stop => sub {
562       POE::Kernel->stop();
563
564       my $expected;
565       if ($] >= 5.004 and $] < 5.00405) {
566         diag( "Note: We find your choice of Perl versions disturbing" );
567         diag( "primarily due to the number of bugs POE triggers within" );
568         diag( "it.  You should seriously consider upgrading." );
569         $expected = 0;
570       }
571       else {
572         $expected = 3;
573       }
574
575       is(
576         $sessions_destroyed, $expected,
577         "$sessions_destroyed sessions destroyed (expected $expected)"
578       );
579
580       # 5.004 and 5.005 have some nasty gc issues. Near as I can tell,
581       # data inside the heap is surviving the session DESTROY. This
582       # isn't possible in a sane and normal world. So if this is giving
583       # you fits, consider it a sign that your "legacy perl" fetish is
584       # bizarre and harmful.
585       if ($] >= 5.006 or ($] >= 5.004 and $] < 5.00405)) {
586         $expected = 3;
587       } else {
588         $expected = 2;
589         diag("Detected a memory leak in Perl version $].");
590         diag("Please consider upgrading if you use Perl in production.");
591       }
592
593       is(
594         $objects_destroyed, $expected,
595         "$objects_destroyed objects destroyed (expected $expected)"
596       );
597     }
598   }
599 );
600
601 POE::Kernel->run();
602
603 is(
604   $stop_called, 0,
605   "_stop wasn't called"
606 );
607
608 is(
609   $child_called, 0,
610   "_child wasn't called"
611 );
612
613 is(
614   $parent_called, 0,
615   "_parent wasn't called"
616 );
617
618 my $expected;
619 if ($] >= 5.004 and $] < 5.00405) {
620   diag( "Seriously.  We've had to create special cases just to cater" );
621   diag( "to your freakish 'legacy buggy perl' fetish.  Consider upgrading" );
622   $expected = 0;
623 }
624 else {
625   $expected = 4;
626 }
627
628 is(
629   $sessions_destroyed, $expected,
630   "destroyed $sessions_destroyed sessions (expected $expected)"
631 );
632
633 # 5.004 and 5.005 have some nasty gc issues. Near as I can tell,
634 # data inside the heap is surviving the session DESTROY. This
635 # isn't possible in a sane and normal world.
636 if($] >= '5.006') {
637   $expected = 4;
638 }
639 elsif ($] == 5.005_04 or $] == 5.004_05) {
640   $expected = 3;
641   diag( "Here's yet another special test case to work around memory" );
642   diag( "leaks in Perl $]." );
643 }
644 else {
645   $expected = 4;
646 }
647
648 is(
649   $objects_destroyed, $expected,
650   "destroyed $objects_destroyed objects (expected $expected)"
651 );
652
653 # This simple session just makes sure we can start another Session and
654 # another Kernel.  If all goes well, it'll dispatch some events and
655 # exit normally.
656
657 # The restart test dumps core when using Tk with Perl 5.8.0 and
658 # beyond, but only if they're built without threading support.  It
659 # happens consistently in a pure Tk test case.  It happens
660 # consistently in POE's "make test" suite.  It doesn't happen at all
661 # when running the test by hand.
662 #
663 # http://rt.cpan.org/Ticket/Display.html?id=8588 is tracking the Tk
664 # test case.  Wish us luck there.
665 #
666 # Meanwhile, these tests will be skipped under Tk if Perl is 5.8.0 or
667 # beyond, and it's not built for threading.
668
669 SKIP: {
670 #  use Config;
671 #  skip "Restarting Tk dumps core in single-threaded perl $]", 6 if (
672 #    $] >= 5.008 and
673 #    exists $INC{"Tk.pm"} and
674 #    !$Config{useithreads}
675 #  );
676
677   POE::Session->create(
678     options => { trace => 1, default => 1, debug => 1 },
679     inline_states => {
680       _start => sub {
681         pass("restarted event loop session _start");
682         $_[KERNEL]->yield("woot");
683         $_[KERNEL]->delay(narf => 1);
684       },
685       woot => sub {
686         pass("restarted event loop session yield()");
687       },
688       narf => sub {
689         pass("restarted event loop session timer delay()");
690       },
691       _stop => sub {
692         pass("restarted event loop session _stop");
693       },
694     }
695   );
696
697   POE::Kernel->run();
698   pass("restarted event loop returned normally");
699 }
700
701 1;