home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / xampp / xampp-perl-addon-1.4.9-installer.exe / TkActiveState.pm < prev    next >
Encoding:
Perl POD Document  |  2003-12-12  |  7.9 KB  |  285 lines
  1. # $Id: TkActiveState.pm,v 1.7 2003/12/12 04:05:06 rcaputo Exp $
  2.  
  3. # Tk-Perl event loop bridge for POE::Kernel.
  4.  
  5. # Empty package to appease perl.
  6. package POE::Loop::Tk;
  7.  
  8. # Include common things.
  9. use POE::Loop::PerlSignals;
  10. use POE::Loop::TkCommon;
  11.  
  12. use vars qw($VERSION);
  13. $VERSION = do {my@r=(q$Revision: 1.7 $=~/\d+/g);sprintf"%d."."%04d"x$#r,@r};
  14.  
  15. use Tk 800.021;
  16. use 5.00503;
  17.  
  18. # Everything plugs into POE::Kernel.
  19. package POE::Kernel;
  20.  
  21. use strict;
  22. use Errno qw(EINPROGRESS EWOULDBLOCK EINTR);
  23.  
  24. # select() vectors.  They're stored in an array so that the MODE_*
  25. # offsets can refer to them.  This saves some code at the expense of
  26. # clock cycles.
  27. #
  28. # [ $select_read_bit_vector,    (MODE_RD)
  29. #   $select_write_bit_vector,   (MODE_WR)
  30. #   $select_expedite_bit_vector (MODE_EX)
  31. # ];
  32. my @loop_vectors = ("", "", "");
  33.  
  34. # A record of the file descriptors we are actively watching.
  35. my %loop_filenos;
  36. my @_fileno_refcount;
  37. my $_handle_poller;
  38.  
  39. #------------------------------------------------------------------------------
  40. # Loop construction and destruction.
  41.  
  42. sub loop_initialize {
  43.   my $self = shift;
  44.  
  45.   $poe_main_window = Tk::MainWindow->new();
  46.   die "could not create a main Tk window" unless defined $poe_main_window;
  47.   $self->signal_ui_destroy($poe_main_window);
  48.  
  49.   # Initialize the vectors as vectors.
  50.   @loop_vectors = ( '', '', '' );
  51.   vec($loop_vectors[MODE_RD], 0, 1) = 0;
  52.   vec($loop_vectors[MODE_WR], 0, 1) = 0;
  53.   vec($loop_vectors[MODE_EX], 0, 1) = 0;
  54.  
  55.   $_handle_poller = $poe_main_window->after(100, [\&_poll_for_io]);
  56. }
  57.  
  58. sub loop_finalize {
  59.   my $self = shift;
  60.  
  61.   # This is "clever" in that it relies on each symbol on the left to
  62.   # be stringified by the => operator.
  63.   my %kernel_modes =
  64.     ( MODE_RD => MODE_RD,
  65.       MODE_WR => MODE_WR,
  66.       MODE_EX => MODE_EX,
  67.     );
  68.  
  69.   while (my ($mode_name, $mode_offset) = each(%kernel_modes)) {
  70.     my $bits = unpack('b*', $loop_vectors[$mode_offset]);
  71.     if (index($bits, '1') >= 0) {
  72.       POE::Kernel::_warn "<rc> LOOP VECTOR LEAK: $mode_name = $bits\a\n";
  73.     }
  74.   }
  75. }
  76.  
  77. #------------------------------------------------------------------------------
  78. # Maintain filehandle watchers.
  79.  
  80. sub loop_watch_filehandle {
  81.   my ($self, $handle, $mode) = @_;
  82.   my $fileno = fileno($handle);
  83.  
  84.   vec($loop_vectors[$mode], $fileno, 1) = 1;
  85.   $loop_filenos{$fileno} |= (1<<$mode);
  86. }
  87.  
  88. sub loop_ignore_filehandle {
  89.   my ($self, $handle, $mode) = @_;
  90.   my $fileno = fileno($handle);
  91.  
  92.   vec($loop_vectors[$mode], $fileno, 1) = 0;
  93.   $loop_filenos{$fileno} &= ~(1<<$mode);
  94. }
  95.  
  96. sub loop_pause_filehandle {
  97.   my ($self, $handle, $mode) = @_;
  98.   my $fileno = fileno($handle);
  99.  
  100.   vec($loop_vectors[$mode], $fileno, 1) = 0;
  101.   $loop_filenos{$fileno} &= ~(1<<$mode);
  102. }
  103.  
  104. sub loop_resume_filehandle {
  105.   my ($self, $handle, $mode) = @_;
  106.   my $fileno = fileno($handle);
  107.  
  108.   vec($loop_vectors[$mode], $fileno, 1) = 1;
  109.   $loop_filenos{$fileno} |= (1<<$mode);
  110. }
  111.  
  112. # This is the select loop itself.  We do a Bad Thing here by polling
  113. # for socket activity, but it's necessary with ActiveState's Tk.
  114. #
  115. # -><- We should really stop the poller when there are no handles to
  116. # watch and resume it as needed.
  117.  
  118. sub _poll_for_io {
  119.   if (defined $_handle_poller) {
  120.     $_handle_poller->cancel();
  121.     undef $_handle_poller;
  122.   }
  123.  
  124.   # Determine which files are being watched.
  125.   my @filenos = ();
  126.   while (my ($fd, $mask) = each(%loop_filenos)) {
  127.     push(@filenos, $fd) if $mask;
  128.   }
  129.  
  130.   if (TRACE_FILES) {
  131.     POE::Kernel::_warn(
  132.       "<fh> ,----- SELECT BITS IN -----\n",
  133.       "<fh> | READ    : ", unpack('b*', $loop_vectors[MODE_RD]), "\n",
  134.       "<fh> | WRITE   : ", unpack('b*', $loop_vectors[MODE_WR]), "\n",
  135.       "<fh> | EXPEDITE: ", unpack('b*', $loop_vectors[MODE_EX]), "\n",
  136.       "<fh> `--------------------------\n"
  137.     );
  138.   }
  139.  
  140.   # Avoid looking at filehandles if we don't need to.  -><- The added
  141.   # code to make this sleep is non-optimal.  There is a way to do this
  142.   # in fewer tests.
  143.  
  144.   if (@filenos) {
  145.  
  146.     # There are filehandles to poll, so do so.
  147.  
  148.     if (@filenos) {
  149.       # Check filehandles, or wait for a period of time to elapse.
  150.       my $hits = select( my $rout = $loop_vectors[MODE_RD],
  151.                          my $wout = $loop_vectors[MODE_WR],
  152.                          my $eout = $loop_vectors[MODE_EX],
  153.                          0,
  154.                        );
  155.  
  156.       if (ASSERT_FILES) {
  157.         if ($hits < 0) {
  158.           POE::Kernel::_trap("<fh> select error: $!")
  159.             unless ( ($! == EINPROGRESS) or
  160.                      ($! == EWOULDBLOCK) or
  161.                      ($! == EINTR)
  162.                    );
  163.         }
  164.       }
  165.  
  166.       if (TRACE_FILES) {
  167.         if ($hits > 0) {
  168.           POE::Kernel::_warn "<fh> select hits = $hits\n";
  169.         }
  170.         elsif ($hits == 0) {
  171.           POE::Kernel::_warn "<fh> select timed out...\n";
  172.         }
  173.         POE::Kernel::_warn(
  174.           "<fh> ,----- SELECT BITS OUT -----\n",
  175.           "<fh> | READ    : ", unpack('b*', $rout), "\n",
  176.           "<fh> | WRITE   : ", unpack('b*', $wout), "\n",
  177.           "<fh> | EXPEDITE: ", unpack('b*', $eout), "\n",
  178.           "<fh> `---------------------------\n"
  179.         );
  180.       }
  181.  
  182.       # If select has seen filehandle activity, then gather up the
  183.       # active filehandles and synchronously dispatch events to the
  184.       # appropriate handlers.
  185.  
  186.       if ($hits > 0) {
  187.  
  188.         # This is where they're gathered.  It's a variant on a neat
  189.         # hack Silmaril came up with.
  190.  
  191.         my (@rd_selects, @wr_selects, @ex_selects);
  192.         foreach (@filenos) {
  193.           push(@rd_selects, $_) if vec($rout, $_, 1);
  194.           push(@wr_selects, $_) if vec($wout, $_, 1);
  195.           push(@ex_selects, $_) if vec($eout, $_, 1);
  196.         }
  197.  
  198.         if (TRACE_FILES) {
  199.           if (@rd_selects) {
  200.             POE::Kernel::_warn(
  201.               "<fh> found pending rd selects: ",
  202.               join( ', ', sort { $a <=> $b } @rd_selects ),
  203.               "\n"
  204.             );
  205.           }
  206.           if (@wr_selects) {
  207.             POE::Kernel::_warn(
  208.               "<sl> found pending wr selects: ",
  209.               join( ', ', sort { $a <=> $b } @wr_selects ),
  210.               "\n"
  211.             );
  212.           }
  213.           if (@ex_selects) {
  214.             POE::Kernel::_warn(
  215.               "<sl> found pending ex selects: ",
  216.               join( ', ', sort { $a <=> $b } @ex_selects ),
  217.               "\n"
  218.             );
  219.           }
  220.         }
  221.  
  222.         if (ASSERT_FILES) {
  223.           unless (@rd_selects or @wr_selects or @ex_selects) {
  224.             POE::Kernel::_trap(
  225.               "<fh> found no selects, with $hits hits from select???\n"
  226.             );
  227.           }
  228.         }
  229.  
  230.         # Enqueue the gathered selects, and flag them as temporarily
  231.         # paused.  They'll resume after dispatch.
  232.  
  233.         @rd_selects and
  234.           $poe_kernel->_data_handle_enqueue_ready(MODE_RD, @rd_selects);
  235.         @wr_selects and
  236.           $poe_kernel->_data_handle_enqueue_ready(MODE_WR, @wr_selects);
  237.         @ex_selects and
  238.           $poe_kernel->_data_handle_enqueue_ready(MODE_EX, @ex_selects);
  239.       }
  240.     }
  241.   }
  242.  
  243.   # Dispatch whatever events are due.
  244.   $poe_kernel->_data_ev_dispatch_due();
  245.  
  246.   # Reset the poller.
  247.   $_handle_poller = $poe_main_window->afterIdle(
  248.     [ sub {
  249.         $_handle_poller->cancel();
  250.         undef $_handle_poller;
  251.         $_handle_poller = $poe_main_window->after(100, [\&_poll_for_io]);
  252.       }
  253.     ]
  254.   );
  255. }
  256.  
  257. 1;
  258.  
  259. __END__
  260.  
  261. =head1 NAME
  262.  
  263. POE::Loop::Tk - a bridge that supports Tk's event loop from POE
  264.  
  265. =head1 SYNOPSIS
  266.  
  267. See L<POE::Loop>.
  268.  
  269. =head1 DESCRIPTION
  270.  
  271. This class is an implementation of the abstract POE::Loop interface.
  272. It follows POE::Loop's public interface exactly.  Therefore, please
  273. see L<POE::Loop> for its documentation.
  274.  
  275. =head1 SEE ALSO
  276.  
  277. L<POE>, L<POE::Loop>, L<Tk>
  278.  
  279. =head1 AUTHORS & LICENSING
  280.  
  281. Please see L<POE> for more information about authors, contributors,
  282. and POE's licensing.
  283.  
  284. =cut
  285.