Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

New features and fixes before 0.0908

  • Loading branch information...
commit 1d16713677f31ed75ffa28420c4f01e408a4752f 1 parent f8c5c52
Rocco Caputo authored
32 Changes
@@ -8,6 +8,38 @@ Versions with "_xx" subversions are internal test releases. Most
8 8 subversions are available from <http://www.newts.org/~troc/poe.html>.
9 9
10 10
  11 +0.0908 2000.??.??
  12 +-----------------
  13 +
  14 +Added logging to samples/poing.perl. Now it records up and down times
  15 +to a tab-delimited file.
  16 +
  17 +Added POE::Kernel::select_(pause|resume)_write, to pause and resume a
  18 +write select without bothering to maintain POE::Kernel's reference
  19 +counts on the filehandle. Made POE::Wheel::ReadWrite use this instead
  20 +of POE::Kernel::select_write, which should improve performance a
  21 +little bit.
  22 +
  23 +POE::Kernel::call was setting $! to 0 when it oughtn't. $! now
  24 +properly reflects the status of POE::Kernel::call.
  25 +
  26 +Removed the place-holder test that suggested people trie the samples
  27 +directory.
  28 +
  29 +Added t/01_sessions.t to test sessions (new and inline create) and
  30 +basic events (post and yield);
  31 +
  32 +Added t/02_alarms.t to test delayed events (alarm, delay, alarm_add
  33 +and delay_add).
  34 +
  35 +Tweaked the Win32 EINPROGRESS support to quietly turn itself off in
  36 +the case that ActiveState adds this constant to POSIX.pm.
  37 +
  38 +Added POE::Kernel::(alarm|delay)_add to post additional alarms to a
  39 +particular state. Unlike POE::Kernel::(alarm|delay), these don't
  40 +clear existing alarms for the destination state.
  41 +
  42 +
11 43 0.0907 2000.03.02
12 44 -----------------
13 45
4 MANIFEST
@@ -25,6 +25,7 @@ POE/Wheel/ListenAccept.pm
25 25 POE/Wheel/ReadWrite.pm
26 26 POE/Wheel/SocketFactory.pm
27 27 README
  28 +lib/TestSetup.pm
28 29 samples/create.perl
29 30 samples/fakelogin.perl
30 31 samples/filterchange.perl
@@ -52,4 +53,5 @@ samples/udp.perl
52 53 samples/watermarks.perl
53 54 samples/wheels.perl
54 55 samples/wheels2.perl
55   -t/test.t
  56 +t/01_sessions.t
  57 +t/02_alarms.t
2  lib/POE.pm
@@ -5,7 +5,7 @@ package POE;
5 5
6 6 use vars qw($VERSION);
7 7
8   -$VERSION = 0.09_07;
  8 +$VERSION = 0.09_08;
9 9
10 10 use strict;
11 11 use Carp;
244 lib/POE/Kernel.pm
@@ -25,7 +25,7 @@ BEGIN {
25 25 # Provide a dummy EINPROGRESS for systems that don't have one. Give
26 26 # it an improbable errno value.
27 27 if ($^O eq 'MSWin32') {
28   - eval "sub EINPROGRESS () { 3.141 }";
  28 + eval '*EINPROGRESS = sub { 3.141 };'
29 29 }
30 30 }
31 31
@@ -414,16 +414,20 @@ sub _dispatch_state {
414 414 $self->[KR_SESSION_IDS]->{$new_session->[SS_ID]} = $session;
415 415 # add to parent's children
416 416 DEB_RELATION and do {
417   - die "$session is its own parent\a" if ($session eq $source_session);
418   - die "!!! $session already is a child of $source_session\a"
  417 + die "Session ", $session->ID, " is its own parent\a"
  418 + if ($session eq $source_session);
  419 + die( "!!! Session ", $session->ID,
  420 + " already is a child of session ", $source_session->ID, "\a"
  421 + )
419 422 if (exists $sessions->{$source_session}->[SS_CHILDREN]->{$session});
420 423 };
421 424 $sessions->{$source_session}->[SS_CHILDREN]->{$session} = $session;
422 425 $sessions->{$source_session}->[SS_REFCOUNT]++;
423 426
424 427 DEB_REFCOUNT and do {
425   - warn("+++ parent ($source_session) receives child: ",
426   - $sessions->{$source_session}->[SS_REFCOUNT], "\n"
  428 + warn( "+++ Parent session ", $source_session->ID,
  429 + " receives child. New refcount=",
  430 + $sessions->{$source_session}->[SS_REFCOUNT], "\n"
427 431 );
428 432 };
429 433 }
@@ -472,13 +476,15 @@ sub _dispatch_state {
472 476 # the session may have been GC'd
473 477 unless (exists $self->[KR_SESSIONS]->{$session}) {
474 478 DEB_EVENTS and do {
475   - warn ">>> discarding $state to $session (session was GC'd)\n";
  479 + warn( ">>> discarding $state to session ",
  480 + $session->ID, " (session was GC'd)\n"
  481 + );
476 482 };
477 483 return;
478 484 }
479 485
480 486 DEB_EVENTS and do {
481   - warn ">>> dispatching $state to $session\n";
  487 + warn ">>> dispatching $state to session ", $session->ID, "\n";
482 488 };
483 489 # dispatch this object's state
484 490 my $hold_active_session = $self->[KR_ACTIVE_SESSION];
@@ -498,7 +504,7 @@ sub _dispatch_state {
498 504 $self->[KR_ACTIVE_SESSION] = $hold_active_session;
499 505
500 506 DEB_EVENTS and do {
501   - warn "<<< $session -> $state returns ($return)\n";
  507 + warn "<<< Session ", $session->ID, " -> $state returns ($return)\n";
502 508 };
503 509 # if _start, notify parent
504 510 if ($type) {
@@ -514,8 +520,11 @@ sub _dispatch_state {
514 520 my $parent = $sessions->{$session}->[SS_PARENT];
515 521 if (defined $parent) {
516 522 DEB_RELATION and do {
517   - die "$session is its own parent\a" if ($session eq $parent);
518   - die "$session is not a child of $parent\a"
  523 + die "Session ", $session->ID, " is its own parent\a"
  524 + if ($session eq $parent);
  525 + die( "Session ", $session->ID, " is not a child of session ",
  526 + $parent->ID, "\a"
  527 + )
519 528 unless (($session eq $parent) ||
520 529 exists($sessions->{$parent}->[SS_CHILDREN]->{$session})
521 530 );
@@ -523,8 +532,9 @@ sub _dispatch_state {
523 532 delete $sessions->{$parent}->[SS_CHILDREN]->{$session};
524 533 $sessions->{$parent}->[SS_REFCOUNT]--;
525 534 DEB_REFCOUNT and do {
526   - warn("--- parent $parent loses child $session: ",
527   - $sessions->{$parent}->[SS_REFCOUNT], "\n"
  535 + warn( "--- parent session ", $parent->ID, " loses child session ",
  536 + $session->ID, ". New refcount=",
  537 + $sessions->{$parent}->[SS_REFCOUNT], "\n"
528 538 );
529 539 die "\a" if ($sessions->{$parent}->[SS_REFCOUNT] < 0);
530 540 };
@@ -533,7 +543,9 @@ sub _dispatch_state {
533 543 my @children = values %{$sessions->{$session}->[SS_CHILDREN]};
534 544 foreach (@children) {
535 545 DEB_RELATION and do {
536   - die "$_ is already a child of $parent\a"
  546 + die( "Session ", $_->ID, " is already a child of session ",
  547 + $parent->ID, "\a"
  548 + )
537 549 if (exists $sessions->{$parent}->[SS_CHILDREN]->{$_});
538 550 };
539 551 $sessions->{$_}->[SS_PARENT] = $parent;
@@ -541,16 +553,17 @@ sub _dispatch_state {
541 553 $sessions->{$parent}->[SS_CHILDREN]->{$_} = $_;
542 554 $sessions->{$parent}->[SS_REFCOUNT]++;
543 555 DEB_REFCOUNT and do {
544   - warn("+++ parent $parent receives child: ",
545   - $sessions->{$parent}->[SS_REFCOUNT], "\n"
  556 + warn( "+++ parent session ", $parent->ID,
  557 + " receives child. new refcount=",
  558 + $sessions->{$parent}->[SS_REFCOUNT], "\n"
546 559 );
547 560 };
548 561 }
549 562 delete $sessions->{$session}->[SS_CHILDREN]->{$_};
550 563 $sessions->{$session}->[SS_REFCOUNT]--;
551 564 DEB_REFCOUNT and do {
552   - warn("--- session $session loses child: ",
553   - $sessions->{$session}->[SS_REFCOUNT], "\n"
  565 + warn( "--- session ", $session->ID, " loses child. new refcount=",
  566 + $sessions->{$session}->[SS_REFCOUNT], "\n"
554 567 );
555 568 die "\a" if ($sessions->{$session}->[SS_REFCOUNT] < 0);
556 569 };
@@ -571,8 +584,8 @@ sub _dispatch_state {
571 584 };
572 585 $sessions->{$session}->[SS_REFCOUNT]--;
573 586 DEB_REFCOUNT and do {
574   - warn("--- discarding event for $session: ",
575   - $sessions->{$session}->[SS_REFCOUNT], "\n"
  587 + warn( "--- discarding event for session ", $session->ID, ": ",
  588 + $sessions->{$session}->[SS_REFCOUNT], "\n"
576 589 );
577 590 die "\a" if ($sessions->{$session}->[SS_REFCOUNT] < 0);
578 591 };
@@ -598,23 +611,23 @@ sub _dispatch_state {
598 611 DEB_GC and do {
599 612 my $errors = 0;
600 613 if (my $leaked = $sessions->{$session}->[SS_REFCOUNT]) {
601   - warn "*** LEAK: refcount = $leaked ($session)\a\n";
  614 + warn "*** LEAK: refcount = $leaked (session ", $session->ID, ")\a\n";
602 615 $errors++;
603 616 }
604 617 if (my $leaked = keys(%{$sessions->{$session}->[SS_CHILDREN]})) {
605   - warn "*** LEAK: children = $leaked ($session)\a\n";
  618 + warn "*** LEAK: children = $leaked (session ", $session->ID, ")\a\n";
606 619 $errors++;
607 620 }
608 621 if (my $leaked = keys(%{$sessions->{$session}->[SS_HANDLES]})) {
609   - warn "*** LEAK: handles = $leaked ($session)\a\n";
  622 + warn "*** LEAK: handles = $leaked (session ", $session->ID, ")\a\n";
610 623 $errors++;
611 624 }
612 625 if (my $leaked = keys(%{$sessions->{$session}->[SS_SIGNALS]})) {
613   - warn "*** LEAK: signals = $leaked ($session)\a\n";
  626 + warn "*** LEAK: signals = $leaked (session ", $session->ID, ")\a\n";
614 627 $errors++;
615 628 }
616 629 if (my $leaked = keys(%{$sessions->{$session}->[SS_ALIASES]})) {
617   - warn "*** LEAK: aliases = $leaked ($session)\a\n";
  630 + warn "*** LEAK: aliases = $leaked (session ", $session->ID, ")\a\n";
618 631 $errors++;
619 632 }
620 633 die "\a" if ($errors);
@@ -774,9 +787,10 @@ sub run {
774 787
775 788 $self->[KR_SESSIONS]->{$event->[ST_SESSION]}->[SS_REFCOUNT]--;
776 789 DEB_REFCOUNT and do {
777   - warn("--- dispatching event to $event->[ST_SESSION]: ",
778   - $self->[KR_SESSIONS]->{$event->[ST_SESSION]}->[SS_REFCOUNT],
779   - "\n"
  790 + warn( "--- dispatching event to session ", $event->[ST_SESSION]->ID,
  791 + ": ",
  792 + $self->[KR_SESSIONS]->{$event->[ST_SESSION]}->[SS_REFCOUNT],
  793 + "\n"
780 794 );
781 795 die "\a" if
782 796 ($self->[KR_SESSIONS]->{$event->[ST_SESSION]}->[SS_REFCOUNT] < 0);
@@ -894,7 +908,7 @@ sub session_alloc {
894 908 my $kr_active_session = $self->[KR_ACTIVE_SESSION];
895 909
896 910 DEB_RELATION and do {
897   - die "session $session already exists\a"
  911 + die "session ", $session->ID, " already exists\a"
898 912 if (exists $self->[KR_SESSIONS]->{$session});
899 913 };
900 914
@@ -910,7 +924,7 @@ sub session_free {
910 924 my ($self, $session) = @_;
911 925
912 926 DEB_RELATION and do {
913   - die "session $session doesn't exist\a"
  927 + die "session ", $session->ID, " doesn't exist\a"
914 928 unless (exists $self->[KR_SESSIONS]->{$session});
915 929 };
916 930
@@ -928,7 +942,7 @@ sub _collect_garbage {
928 942 my $ss = $self->[KR_SESSIONS]->{$session};
929 943
930 944 DEB_GC and do {
931   - warn ",----- GC test for ", $session->ID, " -----\n";
  945 + warn ",----- GC test for session ", $session->ID, " -----\n";
932 946 warn "| ref. count : $ss->[SS_REFCOUNT]\n";
933 947 warn "| event count : $ss->[SS_EVCOUNT]\n";
934 948 warn "| child sessions: ", scalar(keys(%{$ss->[SS_CHILDREN]})), "\n";
@@ -1000,7 +1014,7 @@ sub _enqueue_state {
1000 1014 };
1001 1015
1002 1016 DEB_EVENTS and do {
1003   - warn "}}} enqueuing $state for $session\n";
  1017 + warn "}}} enqueuing $state for session ", $session->ID, "\n";
1004 1018 };
1005 1019
1006 1020 if (exists $self->[KR_SESSIONS]->{$session}) {
@@ -1102,7 +1116,7 @@ sub _enqueue_state {
1102 1116 $self->[KR_SESSIONS]->{$session}->[SS_REFCOUNT]++;
1103 1117
1104 1118 DEB_REFCOUNT and do {
1105   - warn("+++ enqueuing state for $session: ",
  1119 + warn("+++ enqueuing state for session ", $session->ID, ": ",
1106 1120 $self->[KR_SESSIONS]->{$session}->[SS_REFCOUNT], "\n"
1107 1121 );
1108 1122 };
@@ -1126,7 +1140,7 @@ sub post {
1126 1140 return 1;
1127 1141 }
1128 1142 DEB_STRICT and do {
1129   - warn "Cannot resolve alias $destination for session\n";
  1143 + warn "Cannot resolve alias $destination into a session\n";
1130 1144 confess;
1131 1145 };
1132 1146 return undef;
@@ -1150,15 +1164,14 @@ sub yield {
1150 1164 sub call {
1151 1165 my ($self, $destination, $state_name, @etc) = @_;
1152 1166 if (defined($destination = $self->alias_resolve($destination))) {
1153   - my $retval = $self->_dispatch_state( $destination,
1154   - $self->[KR_ACTIVE_SESSION],
1155   - $state_name, ET_USER, \@etc
1156   - );
1157 1167 $! = 0;
1158   - return $retval;
  1168 + return $self->_dispatch_state( $destination,
  1169 + $self->[KR_ACTIVE_SESSION],
  1170 + $state_name, ET_USER, \@etc
  1171 + );
1159 1172 }
1160 1173 DEB_STRICT and do {
1161   - warn "Cannot resolve alias $destination for session\n";
  1174 + warn "Cannot resolve alias $destination into session\n";
1162 1175 confess;
1163 1176 };
1164 1177 return undef;
@@ -1205,7 +1218,7 @@ sub alarm {
1205 1218 };
1206 1219 $self->[KR_SESSIONS]->{$kr_active_session}->[SS_REFCOUNT]--;
1207 1220 DEB_REFCOUNT and do {
1208   - warn("--- removing alarm for $kr_active_session: ",
  1221 + warn("--- removing alarm for session ", $kr_active_session->ID, ": ",
1209 1222 $self->[KR_SESSIONS]->{$kr_active_session}->[SS_REFCOUNT], "\n"
1210 1223 );
1211 1224 die if ($self->[KR_SESSIONS]->{$kr_active_session}->[SS_REFCOUNT] < 0);
@@ -1224,6 +1237,19 @@ sub alarm {
1224 1237 }
1225 1238 }
1226 1239
  1240 +# This will be a version of alarm that doesn't clobber existing ones.
  1241 +sub alarm_add {
  1242 + my ($self, $state, $time, @etc) = @_;
  1243 + my $kr_active_session = $self->[KR_ACTIVE_SESSION];
  1244 +
  1245 + if ($time < (my $now = time())) {
  1246 + $time = $now;
  1247 + }
  1248 + $self->_enqueue_state( $kr_active_session, $kr_active_session,
  1249 + $state, ET_ALARM, $time, [ @etc ]
  1250 + );
  1251 +}
  1252 +
1227 1253 sub delay {
1228 1254 my ($self, $state, $delay, @etc) = @_;
1229 1255 if (defined $delay) {
@@ -1234,6 +1260,14 @@ sub delay {
1234 1260 }
1235 1261 }
1236 1262
  1263 +# This will be a version of delay that doesn't clobber existing ones.
  1264 +sub delay_add {
  1265 + my ($self, $state, $delay, @etc) = @_;
  1266 + if (defined $delay) {
  1267 + $self->alarm_add($state, time() + $delay, @etc);
  1268 + }
  1269 +}
  1270 +
1237 1271 #==============================================================================
1238 1272 # SELECTS
1239 1273 #==============================================================================
@@ -1289,7 +1323,7 @@ sub _internal_select {
1289 1323 $kr_session->[SS_HANDLES]->{$handle} = [ $handle, 0, [ 0, 0, 0 ] ];
1290 1324 $kr_session->[SS_REFCOUNT]++;
1291 1325 DEB_REFCOUNT and do {
1292   - warn("+++ added select for $session: ",
  1326 + warn("+++ added select for session ", $session->ID, ": ",
1293 1327 $kr_session->[SS_REFCOUNT], "\n"
1294 1328 );
1295 1329 };
@@ -1338,7 +1372,7 @@ sub _internal_select {
1338 1372 delete $kr_session->[SS_HANDLES]->{$handle};
1339 1373 $kr_session->[SS_REFCOUNT]--;
1340 1374 DEB_REFCOUNT and do {
1341   - warn("--- removed select for $session: ",
  1375 + warn("--- removed select for session ", $session->ID, ": ",
1342 1376 $kr_session->[SS_REFCOUNT], "\n"
1343 1377 );
1344 1378 die if ($kr_session->[SS_REFCOUNT] < 0);
@@ -1372,6 +1406,40 @@ sub select_expedite {
1372 1406 $self->_internal_select($self->[KR_ACTIVE_SESSION], $handle, $state, 2);
1373 1407 };
1374 1408
  1409 +sub select_pause_write {
  1410 + my ($self, $handle) = @_;
  1411 +
  1412 + # Don't bother if the kernel isn't tracking the handle.
  1413 + return 0 unless exists $self->[KR_HANDLES]->{$handle};
  1414 +
  1415 + # Don't bother if the kernel isn't tracking the handle's write status.
  1416 + return 0 unless $self->[KR_HANDLES]->{$handle}->[HND_VECCOUNT]->[VEC_WR];
  1417 +
  1418 + # Turn off the select vector's write bit for us. We don't do any
  1419 + # housekeeping since we're only pausing the handle. It's assumed
  1420 + # that we'll resume it again at some point.
  1421 +
  1422 + vec($self->[KR_VECTORS]->[VEC_WR], fileno($handle), 1) = 0;
  1423 + return 1;
  1424 +}
  1425 +
  1426 +sub select_resume_write {
  1427 + my ($self, $handle) = @_;
  1428 +
  1429 + # Don't bother if the kernel isn't tracking the handle.
  1430 + return 0 unless exists $self->[KR_HANDLES]->{$handle};
  1431 +
  1432 + # Don't bother if the kernel isn't tracking the handle's write status.
  1433 + return 0 unless $self->[KR_HANDLES]->{$handle}->[HND_VECCOUNT]->[VEC_WR];
  1434 +
  1435 + # Turn off the select vector's write bit for us. We don't do any
  1436 + # housekeeping since we're only pausing the handle. It's assumed
  1437 + # that we'll resume it again at some point.
  1438 +
  1439 + vec($self->[KR_VECTORS]->[VEC_WR], fileno($handle), 1) = 1;
  1440 + return 1;
  1441 +}
  1442 +
1375 1443 #==============================================================================
1376 1444 # ALIASES
1377 1445 #==============================================================================
@@ -1392,7 +1460,7 @@ sub alias_set {
1392 1460 $self->[KR_SESSIONS]->{$kr_active_session}->[SS_ALIASES]->{$name} = 1;
1393 1461 $self->[KR_SESSIONS]->{$kr_active_session}->[SS_REFCOUNT]++;
1394 1462 DEB_REFCOUNT and do {
1395   - warn("+++ added alias for $kr_active_session: ",
  1463 + warn("+++ added alias for session ", $kr_active_session->ID, ": ",
1396 1464 $self->[KR_SESSIONS]->{$kr_active_session}->[SS_REFCOUNT], "\n"
1397 1465 );
1398 1466 };
@@ -1405,7 +1473,7 @@ sub _internal_alias_remove {
1405 1473 delete $self->[KR_SESSIONS]->{$session}->[SS_ALIASES]->{$name};
1406 1474 $self->[KR_SESSIONS]->{$session}->[SS_REFCOUNT]--;
1407 1475 DEB_REFCOUNT and do {
1408   - warn("--- removed alias for $session: ",
  1476 + warn("--- removed alias for session ", $session->ID, ": ",
1409 1477 $self->[KR_SESSIONS]->{$session}->[SS_REFCOUNT], "\n"
1410 1478 );
1411 1479 die if ($self->[KR_SESSIONS]->{$session}->[SS_REFCOUNT] < 0);
@@ -1614,6 +1682,8 @@ POE::Kernel - POE Event Queue and Resource Manager
1614 1682 $kernel->select_read( $file_handle, $read_state_name );
1615 1683 $kernel->select_write( $file_handle, $write_state_name );
1616 1684 $kernel->select_expedite( $file_handle, $expedite_state_name );
  1685 + $kernel->select_pause_write( $file_handle );
  1686 + $kernel->select_resume_write( $file_handle );
1617 1687
1618 1688 # Signals:
1619 1689 $kernel->sig( $signal_name, $state_name ); # Registers a handler.
@@ -1806,33 +1876,52 @@ uses (usually the UNIX epoch). If $time is in the past, it will be
1806 1876 clipped to time(), making the alarm() call synonymous to post() but
1807 1877 with some extra overhead.
1808 1878
1809   -Alarms are keyed by state name. That is, there can be only one
1810   -pending alarm for any given state. This is a design bug, and there
1811   -are plans to fix it.
  1879 +alarm() ensures that its alarm is the only one queued for the current
  1880 +session and given state. It does this by scouring the queue and
  1881 +removing all others matching the combination of session and state. As
  1882 +of 0.0908, the alarm_add() method can post additional alarms without
  1883 +scouring previous ones away.
1812 1884
1813 1885 @args are passed to the alarm handler as C<@_[ARG0..$#_]>.
1814 1886
1815   -It is possible to remove an alarm that hasn't yet been dispatched:
  1887 +It is possible to remove alarms from the queue by posting an alarm
  1888 +without additional parameters. This triggers the queue scour without
  1889 +posting an alarm. For example:
1816 1890
1817 1891 $kernel->alarm( $state ); # Removes the alarm for $state
1818 1892
1819   -Subsequent alarms set for the same name will overwrite previous ones.
1820   -This is useful for timeout timers that must be continually refreshed.
1821   -
1822 1893 As of version 0.0904, the alarm() function will only remove alarms.
1823 1894 Other types of events will remain in the queue.
1824 1895
  1896 +=item*
  1897 +
  1898 +POE::Kernel::alarm_add( $state, $time, @args )
  1899 +
  1900 +The alarm_add() method enqueues an event for the current session with
  1901 +a future dispatch time, specified in seconds since whatever epoch
  1902 +time() uses (usually the UNIX epoch). If $time is in the past, it
  1903 +will be clipped to time(), making the alarm_add() call synonymous to
  1904 +post() but with some extra overhead.
  1905 +
  1906 +Unlike alarm(), however, it does not scour the queue for previous
  1907 +alarms matching the current session/state pair. Since it doesn't
  1908 +scour, adding an empty alarm won't clear others from the queue.
  1909 +
  1910 +This function may be faster than alarm() since the scour phase is
  1911 +skipped.
  1912 +
1825 1913 =item *
1826 1914
1827   -POE::Kernel::delay( $state, $seconds, @args );
  1915 +POE::Kernel::delay( $state, $seconds, @args )
1828 1916
1829 1917 The delay() method is an alias for:
1830 1918
1831 1919 $kernel->alarm( $state, time() + $seconds, @args );
1832 1920
1833   -However, because time() is called within the POE::Kernel package, it
1834   -uses Time::HiRes if it's available. This saves programs from having
1835   -to figure out if Time::HiRes is available themselves.
  1921 +However it silently uses Time::HiRes if it's available, so time()
  1922 +automagically has an increased resolution when it can. This saves
  1923 +programs from having to figure out whether Time::HiRes is available
  1924 +themselves.
1836 1925
1837 1926 All the details for POE::Kernel::alarm() apply to delay() as well.
1838 1927 For example, delays may be removed by omitting the $seconds and @args
@@ -1843,6 +1932,21 @@ parameters:
1843 1932 As of version 0.0904, the delay() function will only remove alarms.
1844 1933 Other types of events will remain in the queue.
1845 1934
  1935 +=item *
  1936 +
  1937 +POE::Kernel::delay_add( $state, $seconds, @args )
  1938 +
  1939 +The delay_add() method works like delay(), but it allows duplicate
  1940 +alarms. It is equivalent to:
  1941 +
  1942 + $kernel->alarm_add( $state, time() + $seconds, @args );
  1943 +
  1944 +The "empty delay" syntax is meaningless since alarm_add() does not
  1945 +scour the queue for duplicates.
  1946 +
  1947 +This function may be faster than delay() since the scour phase is
  1948 +skipped.
  1949 +
1846 1950 =back
1847 1951
1848 1952 =head2 Alias Management Methods
@@ -1921,23 +2025,31 @@ are removed for undefined states.
1921 2025 =item *
1922 2026
1923 2027 POE::Kernel::select_read( $filehandle, $read_state )
1924   -
1925   -The select_read() method adds or removes a file handle's read select.
1926   -It leaves the other two unchanged.
1927   -
1928   -=item *
1929   -
1930 2028 POE::Kernel::select_write( $filehandle, $write_state )
  2029 +POE::Kernel::select_expedite( $filehandle, $expedite_state )
1931 2030
1932   -The select_write() method adds or removes a file handle's write
1933   -select. It leaves the other two unchanged.
  2031 +These methods add, remove or change the state that is called when a
  2032 +filehandle becomes ready for reading, writing, or out-of-band reading,
  2033 +respectively. They work like POE::Kernel::select, except they allow
  2034 +individual aspects of a filehandle to be changed.
  2035 +
  2036 +If the state parameter is undefined, then the filehandle watcher is
  2037 +removed; otherwise it's added or changed. These functions have a
  2038 +moderate amount of overhead, since they update POE::Kernel's
  2039 +reference-counting structures.
1934 2040
1935 2041 =item *
1936 2042
1937   -POE::Kernel::select_expedite( $filehandle, $expedite_state )
  2043 +POE::Kernel::select_pause_write( $filehandle );
  2044 +POE::Kernel::select_resume_write( $filehandle );
  2045 +
  2046 +These methods allow a write select to be paused and resumed without
  2047 +the overhead of maintaining POE::Kernel's reference-counting
  2048 +structures.
1938 2049
1939   -The select_expedite() method adds or removes a file handle's expedite
1940   -select. It leaves the other two unchanged.
  2050 +It is most useful for write select handlers that may need to pause
  2051 +write-okay events when their outbound buffers are empty and resume
  2052 +them when new output is enqueued.
1941 2053
1942 2054 =back
1943 2055
10 lib/POE/Wheel/ReadWrite.pm
@@ -199,11 +199,17 @@ sub _define_write_state {
199 199 # call and a flushed call at the same time (if the low mark
200 200 # is 1).
201 201 unless ($$driver_buffered_out_octets) {
202   - $k->select_write($handle);
  202 + $k->select_pause_write($handle);
203 203 $event_flushed && $k->call($me, $event_flushed);
204 204 }
205 205 }
206 206 );
  207 +
  208 + $poe_kernel->select_write($self->[HANDLE_INPUT], $self->[STATE_WRITE]);
  209 +
  210 + # Pause the write select immediately, unless output is pending.
  211 + $poe_kernel->select_pause_write($self->[HANDLE_INPUT])
  212 + unless ($self->[DRIVER_BUFFERED_OUT_OCTETS]);
207 213 }
208 214
209 215 #------------------------------------------------------------------------------
@@ -328,7 +334,7 @@ sub put {
328 334 if ( $self->[DRIVER_BUFFERED_OUT_OCTETS] =
329 335 $self->[DRIVER_BOTH]->put($self->[FILTER_OUTPUT]->put(\@chunks))
330 336 ) {
331   - $poe_kernel->select_write($self->[HANDLE_OUTPUT], $self->[STATE_WRITE]);
  337 + $poe_kernel->select_resume_write($self->[HANDLE_OUTPUT]);
332 338 }
333 339
334 340 # Return true if the high watermark has been reached.
2  lib/POE/Wheel/SocketFactory.pm
@@ -17,7 +17,7 @@ sub DEBUG () { 0 }
17 17 # it an improbable errno value.
18 18 BEGIN {
19 19 if ($^O eq 'MSWin32') {
20   - eval "sub EINPROGRESS () { 3.141 }";
  20 + eval '*EINPROGRESS = sub { 3.141 };'
21 21 }
22 22 }
23 23
13 mylib/TestSetup.pm
... ... @@ -0,0 +1,13 @@
  1 +# Standard test setup things.
  2 +# $Id$
  3 +
  4 +package TestSetup;
  5 +
  6 +sub import {
  7 + my $something_poorly_documented = shift;
  8 + $ENV{PERL_DL_NONLAZY} = 0 if ($^O eq 'freebsd');
  9 + select(STDOUT); $|=1;
  10 + print "1..$_[0]\n";
  11 +}
  12 +
  13 +1;
92 tests/01_sessions.t
... ... @@ -0,0 +1,92 @@
  1 +#!/usr/bin/perl -w
  2 +# $Id$
  3 +
  4 +# Tests basic compilation and events.
  5 +
  6 +use strict;
  7 +use lib qw(.. ../lib);
  8 +use TestSetup qw(13);
  9 +use POE;
  10 +
  11 +### Test parameters.
  12 +
  13 +my $machine_count = 10;
  14 +my $event_count = 10;
  15 +
  16 +### Status registers for each state machine instance.
  17 +
  18 +my @completions;
  19 +
  20 +### Define a simple state machine.
  21 +
  22 +sub task_start {
  23 + my ($kernel, $heap, $id) = @_[KERNEL, HEAP, ARG0];
  24 + $heap->{count} = 0;
  25 + $kernel->yield( count => $id );
  26 +}
  27 +
  28 +sub task_run {
  29 + my ($kernel, $session, $heap, $id) = @_[KERNEL, SESSION, HEAP, ARG0];
  30 + if (++$heap->{count} < $event_count) {
  31 +
  32 + if ($heap->{count} & 1) {
  33 + $kernel->yield( count => $id );
  34 + }
  35 + else {
  36 + $kernel->post( $session, count => $id );
  37 + }
  38 +
  39 + }
  40 + else {
  41 + $heap->{id} = $id;
  42 + }
  43 +}
  44 +
  45 +sub task_stop {
  46 + $completions[$_[HEAP]->{id}] = $_[HEAP]->{count};
  47 +}
  48 +
  49 +### Main loop.
  50 +
  51 +print "ok 1\n";
  52 +
  53 +# Spawn ten state machines.
  54 +for (my $i=0; $i<$machine_count; $i++) {
  55 +
  56 + # Odd instances, try POE::Session->create
  57 + if ($i & 1) {
  58 + POE::Session->create
  59 + ( inline_states =>
  60 + { _start => \&task_start,
  61 + _stop => \&task_stop,
  62 + count => \&task_run,
  63 + },
  64 + args => [ $i ],
  65 + );
  66 + }
  67 +
  68 + # Even instances, try POE::Session->new
  69 + else {
  70 + POE::Session->new
  71 + ( _start => \&task_start,
  72 + _stop => \&task_stop,
  73 + count => \&task_run,
  74 + [ $i ],
  75 + );
  76 + }
  77 +}
  78 +
  79 +print "ok 2\n";
  80 +
  81 +# Now run them 'til they complete.
  82 +$poe_kernel->run();
  83 +
  84 +# Now make sure they've run.
  85 +for (my $i=0; $i<$machine_count; $i++) {
  86 + print 'not ' unless $completions[$i] == $event_count;
  87 + print 'ok ', $i+3, "\n";
  88 +}
  89 +
  90 +print "ok 13\n";
  91 +
  92 +exit;
266 tests/02_alarms.t
... ... @@ -0,0 +1,266 @@
  1 +#!/usr/bin/perl -w
  2 +# $Id$
  3 +
  4 +# Tests alarms.
  5 +
  6 +use strict;
  7 +use lib qw(.. ../lib);
  8 +use TestSetup qw(13);
  9 +use POE;
  10 +
  11 +### Test parameters.
  12 +
  13 +my $machine_count = 10;
  14 +my $event_count = 10;
  15 +
  16 +### Status registers for each state machine instance.
  17 +
  18 +my @status;
  19 +
  20 +### Define a simple state machine.
  21 +
  22 +sub test_start {
  23 + my ($kernel, $heap) = @_[KERNEL, HEAP];
  24 +
  25 + # Path #1: single alarm; make sure it rings.
  26 + $heap->{test}->{path_one} = 0;
  27 + $kernel->alarm( path_one => time() + 2, 1.1 );
  28 +
  29 + # Path #2: two alarms; make sure only the second one rings.
  30 + $heap->{test}->{path_two} = 0;
  31 + $kernel->alarm( path_two => time() + 2, 2.1 );
  32 + $kernel->alarm( path_two => time() + 2, 2.2 );
  33 +
  34 + # Path #3: two alarms; make sure they both ring in order.
  35 + $heap->{test}->{path_three} = 0;
  36 + $kernel->alarm_add( path_three => time() + 2, 3.1 );
  37 + $kernel->alarm_add( path_three => time() + 2, 3.2 );
  38 +
  39 + # Path #4: interleaved alarm and alarm_add; only the last two should
  40 + # ring, in order.
  41 + $heap->{test}->{path_four} = 0;
  42 + $kernel->alarm( path_four => time() + 2, 4.1 );
  43 + $kernel->alarm_add( path_four => time() + 2, 4.2 );
  44 + $kernel->alarm( path_four => time() + 2, 4.3 );
  45 + $kernel->alarm_add( path_four => time() + 2, 4.4 );
  46 +
  47 + # Path #5: an alarm that is squelched; nothing should ring.
  48 + $heap->{test}->{path_five} = 1;
  49 + $kernel->alarm( path_five => time() + 2, 5.1 );
  50 + $kernel->alarm( 'path_five' );
  51 +
  52 +
  53 + # Path #6: single delay; make sure it rings.
  54 + $heap->{test}->{path_six} = 0;
  55 + $kernel->delay( path_six => 2, 6.1 );
  56 +
  57 + # Path #7: two delays; make sure only the second one rings.
  58 + $heap->{test}->{path_seven} = 0;
  59 + $kernel->delay( path_seven => 2, 7.1 );
  60 + $kernel->delay( path_seven => 2, 7.2 );
  61 +
  62 + # Path #8: two delays; make sure they both ring in order.
  63 + $heap->{test}->{path_eight} = 0;
  64 + $kernel->delay_add( path_eight => 2, 8.1 );
  65 + $kernel->delay_add( path_eight => 2, 8.2 );
  66 +
  67 + # Path #9: interleaved delay and delay_add; only the last two should
  68 + # ring, in order.
  69 + $heap->{test}->{path_nine} = 0;
  70 + $kernel->alarm( path_nine => 2, 9.1 );
  71 + $kernel->alarm_add( path_nine => 2, 9.2 );
  72 + $kernel->alarm( path_nine => 2, 9.3 );
  73 + $kernel->alarm_add( path_nine => 2, 9.4 );
  74 +
  75 + # Path #10: a delay that is squelched; nothing should ring.
  76 + $heap->{test}->{path_ten} = 1;
  77 + $kernel->delay( path_ten => 2, 10.1 );
  78 + $kernel->alarm( 'path_ten' );
  79 +
  80 + # And a final test: Since the alarms are being waited for in
  81 + # parallel, the program should take close to 2 seconds to run. Mark
  82 + # the start time for this test.
  83 + $heap->{start_time} = time();
  84 +}
  85 +
  86 +sub test_stop {
  87 + my $heap = $_[HEAP];
  88 +
  89 + print 'not ' unless $heap->{test}->{path_one} == 1;
  90 + print "ok 2\n";
  91 +
  92 + print 'not ' unless $heap->{test}->{path_two} == 1;
  93 + print "ok 3\n";
  94 +
  95 + print 'not ' unless $heap->{test}->{path_three} == 11;
  96 + print "ok 4\n";
  97 +
  98 + print 'not ' unless $heap->{test}->{path_four} == 11;
  99 + print "ok 5\n";
  100 +
  101 + print 'not ' unless $heap->{test}->{path_five} == 1;
  102 + print "ok 6\n";
  103 +
  104 + print 'not ' unless $heap->{test}->{path_six} == 1;
  105 + print "ok 7\n";
  106 +
  107 + print 'not ' unless $heap->{test}->{path_seven} == 1;
  108 + print "ok 8\n";
  109 +
  110 + print 'not ' unless $heap->{test}->{path_eight} == 11;
  111 + print "ok 9\n";
  112 +
  113 + print 'not ' unless $heap->{test}->{path_nine} == 11;
  114 + print "ok 10\n";
  115 +
  116 + print 'not ' unless $heap->{test}->{path_ten} == 1;
  117 + print "ok 11\n";
  118 +
  119 + # Here's where we check the overall run time.
  120 + print 'not' if (time() - $heap->{start_time} > 3);
  121 + print "ok 12\n";
  122 +}
  123 +
  124 +sub test_path_one {
  125 + my ($heap, $test_id) = @_[HEAP, ARG0];
  126 +
  127 + if ($test_id == 1.1) {
  128 + $heap->{test}->{path_one} += 1;
  129 + }
  130 + else {
  131 + $heap->{test}->{path_one} += 1000;
  132 + }
  133 +}
  134 +
  135 +sub test_path_two {
  136 + my ($heap, $test_id) = @_[HEAP, ARG0];
  137 +
  138 + if ($test_id == 2.2) {
  139 + $heap->{test}->{path_two} += 1;
  140 + }
  141 + else {
  142 + $heap->{test}->{path_two} += 1000;
  143 + }
  144 +}
  145 +
  146 +sub test_path_three {
  147 + my ($heap, $test_id) = @_[HEAP, ARG0];
  148 +
  149 + if (($test_id == 3.1) and ($heap->{test}->{path_three} == 0)) {
  150 + $heap->{test}->{path_three} += 1;
  151 + }
  152 + elsif (($test_id == 3.2) and ($heap->{test}->{path_three} == 1)) {
  153 + $heap->{test}->{path_three} += 10;
  154 + }
  155 + else {
  156 + $heap->{test}->{path_three} += 1000;
  157 + }
  158 +}
  159 +
  160 +sub test_path_four {
  161 + my ($heap, $test_id) = @_[HEAP, ARG0];
  162 +
  163 + if (($test_id == 4.3) and ($heap->{test}->{path_four} == 0)) {
  164 + $heap->{test}->{path_four} += 1;
  165 + }
  166 + elsif (($test_id == 4.4) and ($heap->{test}->{path_four} == 1)) {
  167 + $heap->{test}->{path_four} += 10;
  168 + }
  169 + else {
  170 + $heap->{test}->{path_four} += 1000;
  171 + }
  172 +}
  173 +
  174 +sub test_path_five {
  175 + my ($heap, $test_id) = @_[HEAP, ARG0];
  176 +
  177 + $heap->{test}->{path_five} += 1;
  178 +}
  179 +
  180 +sub test_path_six {
  181 + my ($heap, $test_id) = @_[HEAP, ARG0];
  182 +
  183 + if ($test_id == 6.1) {
  184 + $heap->{test}->{path_six} += 1;
  185 + }
  186 + else {
  187 + $heap->{test}->{path_six} += 1000;
  188 + }
  189 +}
  190 +
  191 +sub test_path_seven {
  192 + my ($heap, $test_id) = @_[HEAP, ARG0];
  193 +
  194 + if ($test_id == 7.2) {
  195 + $heap->{test}->{path_seven} += 1;
  196 + }
  197 + else {
  198 + $heap->{test}->{path_seven} += 1000;
  199 + }
  200 +}
  201 +
  202 +sub test_path_eight {
  203 + my ($heap, $test_id) = @_[HEAP, ARG0];
  204 +
  205 + if (($test_id == 8.1) and ($heap->{test}->{path_eight} == 0)) {
  206 + $heap->{test}->{path_eight} += 1;
  207 + }
  208 + elsif (($test_id == 8.2) and ($heap->{test}->{path_eight} == 1)) {
  209 + $heap->{test}->{path_eight} += 10;
  210 + }
  211 + else {
  212 + $heap->{test}->{path_eight} += 1000;
  213 + }
  214 +}
  215 +
  216 +sub test_path_nine {
  217 + my ($heap, $test_id) = @_[HEAP, ARG0];
  218 +
  219 + if (($test_id == 9.3) and ($heap->{test}->{path_nine} == 0)) {
  220 + $heap->{test}->{path_nine} += 1;
  221 + }
  222 + elsif (($test_id == 9.4) and ($heap->{test}->{path_nine} == 1)) {
  223 + $heap->{test}->{path_nine} += 10;
  224 + }
  225 + else {
  226 + $heap->{test}->{path_nine} += 1000;
  227 + }
  228 +}
  229 +
  230 +sub test_path_ten {
  231 + my ($heap, $test_id) = @_[HEAP, ARG0];
  232 +
  233 + $heap->{test}->{path_ten} += 1;
  234 +}
  235 +
  236 +### Main loop.
  237 +
  238 +print "ok 1\n";
  239 +
  240 +# Spawn a state machine.
  241 +
  242 +POE::Session->create
  243 + ( inline_states =>
  244 + { _start => \&test_start,
  245 + _stop => \&test_stop,
  246 + path_one => \&test_path_one,
  247 + path_two => \&test_path_two,
  248 + path_three => \&test_path_three,
  249 + path_four => \&test_path_four,
  250 + path_five => \&test_path_five,
  251 + path_six => \&test_path_six,
  252 + path_seven => \&test_path_seven,
  253 + path_eight => \&test_path_eight,
  254 + path_nine => \&test_path_nine,
  255 + path_ten => \&test_path_ten,
  256 + }
  257 + );
  258 +
  259 +# Now run it 'til it stops.
  260 +$poe_kernel->run();
  261 +
  262 +# Now make sure they've run.
  263 +
  264 +print "ok 13\n";
  265 +
  266 +exit;

0 comments on commit 1d16713

Please sign in to comment.
Something went wrong with that request. Please try again.