[poe-commits] poe/POE/Loop TkActiveState.pm,NONE,1.1 TkCommon.pm,NONE,1.1

[<rc...@us...>]

Update of /cvsroot/poe/poe/POE/Loop
In directory sc8-pr-cvs1:/tmp/cvs-serv28903/POE/Loop

Added Files:
	TkActiveState.pm TkCommon.pm 
Log Message:
Of course we can't really begin to support ActivePerl+Tk without the
files themselves.  So.


--- NEW FILE: TkActiveState.pm ---
# $Id: TkActiveState.pm,v 1.1 2003/06/09 17:31:04 rcaputo Exp $

# Tk-Perl event loop bridge for POE::Kernel.

# Empty package to appease perl.
package POE::Loop::Tk;

# Include common things.
use POE::Loop::PerlSignals;
use POE::Loop::TkCommon;

use vars qw($VERSION);
$VERSION = (qw($Revision: 1.1 $ ))[1];

BEGIN {
  die "POE's Tk support requires version Tk 800.021 or higher.\n"
    unless defined($Tk::VERSION) and $Tk::VERSION >= 800.021;
  die "POE's Tk support requires Perl 5.005_03 or later.\n"
    if $] < 5.00503;
};

# Everything plugs into POE::Kernel.
package POE::Kernel;

use strict;

# select() vectors.  They're stored in an array so that the MODE_*
# offsets can refer to them.  This saves some code at the expense of
# clock cycles.
#
# [ $select_read_bit_vector,    (MODE_RD)
#   $select_write_bit_vector,   (MODE_WR)
#   $select_expedite_bit_vector (MODE_EX)
# ];
my @loop_vectors = ("", "", "");

# A record of the file descriptors we are actively watching.
my %loop_filenos;
my @_fileno_refcount;
my $_handle_poller;

#------------------------------------------------------------------------------
# Loop construction and destruction.

sub loop_initialize {
  my $self = shift;

  $poe_main_window = Tk::MainWindow->new();
  die "could not create a main Tk window" unless defined $poe_main_window;
  $self->signal_ui_destroy($poe_main_window);

  # Initialize the vectors as vectors.
  @loop_vectors = ( '', '', '' );
  vec($loop_vectors[MODE_RD], 0, 1) = 0;
  vec($loop_vectors[MODE_WR], 0, 1) = 0;
  vec($loop_vectors[MODE_EX], 0, 1) = 0;

  $_handle_poller = $poe_main_window->after(100, [\&_poll_for_io]);
}

sub loop_finalize {
  my $self = shift;

  # This is "clever" in that it relies on each symbol on the left to
  # be stringified by the => operator.
  my %kernel_modes =
    ( MODE_RD => MODE_RD,
      MODE_WR => MODE_WR,
      MODE_EX => MODE_EX,
    );

  while (my ($mode_name, $mode_offset) = each(%kernel_modes)) {
    my $bits = unpack('b*', $loop_vectors[$mode_offset]);
    if (index($bits, '1') >= 0) {
      warn "<rc> LOOP VECTOR LEAK: $mode_name = $bits\a\n";
    }
  }
}

#------------------------------------------------------------------------------
# Maintain filehandle watchers.

sub loop_watch_filehandle {
  my ($self, $handle, $mode) = @_;
  my $fileno = fileno($handle);

  vec($loop_vectors[$mode], $fileno, 1) = 1;
  $loop_filenos{$fileno} |= (1<<$mode);
}

sub loop_ignore_filehandle {
  my ($self, $handle, $mode) = @_;
  my $fileno = fileno($handle);

  vec($loop_vectors[$mode], $fileno, 1) = 0;
  $loop_filenos{$fileno} &= ~(1<<$mode);
}

sub loop_pause_filehandle {
  my ($self, $handle, $mode) = @_;
  my $fileno = fileno($handle);

  vec($loop_vectors[$mode], $fileno, 1) = 0;
  $loop_filenos{$fileno} &= ~(1<<$mode);
}

sub loop_resume_filehandle {
  my ($self, $handle, $mode) = @_;
  my $fileno = fileno($handle);

  vec($loop_vectors[$mode], $fileno, 1) = 1;
  $loop_filenos{$fileno} |= (1<<$mode);
}

# This is the select loop itself.  We do a Bad Thing here by polling
# for socket activity, but it's necessary with ActiveState's Tk.
#
# -><- We should really stop the poller when there are no handles to
# watch and resume it as needed.

sub _poll_for_io {
warn;
  if (defined $_handle_poller) {
    $_handle_poller->cancel();
    undef $_handle_poller;
  }

  # Determine which files are being watched.
  my @filenos = ();
  while (my ($fd, $mask) = each(%loop_filenos)) {
    push(@filenos, $fd) if $mask;
  }

  if (TRACE_FILES) {
    warn( "<fh> ,----- SELECT BITS IN -----\n",
          "<fh> | READ    : ", unpack('b*', $loop_vectors[MODE_RD]), "\n",
          "<fh> | WRITE   : ", unpack('b*', $loop_vectors[MODE_WR]), "\n",
          "<fh> | EXPEDITE: ", unpack('b*', $loop_vectors[MODE_EX]), "\n",
          "<fh> `--------------------------\n"
        );
  }

  # Avoid looking at filehandles if we don't need to.  -><- The added
  # code to make this sleep is non-optimal.  There is a way to do this
  # in fewer tests.

  if (@filenos) {

    # There are filehandles to poll, so do so.

    if (@filenos) {
      # Check filehandles, or wait for a period of time to elapse.
      my $hits = select( my $rout = $loop_vectors[MODE_RD],
                         my $wout = $loop_vectors[MODE_WR],
                         my $eout = $loop_vectors[MODE_EX],
                         0,
                       );

      if (ASSERT_FILES) {
        if ($hits < 0) {
          confess "<fh> select error: $!"
            unless ( ($! == EINPROGRESS) or
                     ($! == EWOULDBLOCK) or
                     ($! == EINTR)
                   );
        }
      }

      if (TRACE_FILES) {
        if ($hits > 0) {
          warn "<fh> select hits = $hits\n";
        }
        elsif ($hits == 0) {
          warn "<fh> select timed out...\n";
        }
        warn( "<fh> ,----- SELECT BITS OUT -----\n",
              "<fh> | READ    : ", unpack('b*', $rout), "\n",
              "<fh> | WRITE   : ", unpack('b*', $wout), "\n",
              "<fh> | EXPEDITE: ", unpack('b*', $eout), "\n",
              "<fh> `---------------------------\n"
            );
      }

      # If select has seen filehandle activity, then gather up the
      # active filehandles and synchronously dispatch events to the
      # appropriate handlers.

      if ($hits > 0) {

        # This is where they're gathered.  It's a variant on a neat
        # hack Silmaril came up with.

        my (@rd_selects, @wr_selects, @ex_selects);
        foreach (@filenos) {
          push(@rd_selects, $_) if vec($rout, $_, 1);
          push(@wr_selects, $_) if vec($wout, $_, 1);
          push(@ex_selects, $_) if vec($eout, $_, 1);
        }

        if (TRACE_FILES) {
          if (@rd_selects) {
            warn( "<fh> found pending rd selects: ",
                  join( ', ', sort { $a <=> $b } @rd_selects ),
                  "\n"
                );
          }
          if (@wr_selects) {
            warn( "<sl> found pending wr selects: ",
                  join( ', ', sort { $a <=> $b } @wr_selects ),
                  "\n"
                );
          }
          if (@ex_selects) {
            warn( "<sl> found pending ex selects: ",
                  join( ', ', sort { $a <=> $b } @ex_selects ),
                  "\n"
                );
          }
        }

        if (ASSERT_FILES) {
          unless (@rd_selects or @wr_selects or @ex_selects) {
            confess "<fh> found no selects, with $hits hits from select???\n";
          }
        }

        # Enqueue the gathered selects, and flag them as temporarily
        # paused.  They'll resume after dispatch.

        @rd_selects and
          $poe_kernel->_data_handle_enqueue_ready(MODE_RD, @rd_selects);
        @wr_selects and
          $poe_kernel->_data_handle_enqueue_ready(MODE_WR, @wr_selects);
        @ex_selects and
          $poe_kernel->_data_handle_enqueue_ready(MODE_EX, @ex_selects);
      }
    }
  }

  # Dispatch whatever events are due.
  $poe_kernel->_data_ev_dispatch_due();

  # Reset the poller.
  $_handle_poller = $poe_main_window->afterIdle(
    [ sub {
        $_handle_poller->cancel();
        undef $_handle_poller;
        $_handle_poller = $poe_main_window->after(100, [\&_poll_for_io]);
      }
    ]
  );
}

1;

__END__

=head1 NAME

POE::Loop::Tk - a bridge that supports Tk's event loop from POE

=head1 SYNOPSIS

See L<POE::Loop>.

=head1 DESCRIPTION

This class is an implementation of the abstract POE::Loop interface.
It follows POE::Loop's public interface exactly.  Therefore, please
see L<POE::Loop> for its documentation.

=head1 SEE ALSO

L<POE>, L<POE::Loop>, L<Tk>

=head1 AUTHORS & LICENSING

Please see L<POE> for more information about authors, contributors,
and POE's licensing.

=cut

--- NEW FILE: TkCommon.pm ---
# $Id: TkCommon.pm,v 1.1 2003/06/09 17:31:05 rcaputo Exp $

# The common bits of our system-specific Tk event loops.  This is
# everything but file handling.

# Empty package to appease perl.
package POE::Loop::TkCommon;

# Include common signal handling.
use POE::Loop::PerlSignals;

use vars qw($VERSION);
$VERSION = (qw($Revision: 1.1 $ ))[1];

BEGIN {
  die "POE's Tk support requires version Tk 800.021 or higher.\n"
    unless defined($Tk::VERSION) and $Tk::VERSION >= 800.021;
  die "POE's Tk support requires Perl 5.005_03 or later.\n"
    if $] < 5.00503;
};

# Everything plugs into POE::Kernel.
package POE::Kernel;

use strict;

# Delcare which event loop bridge is being used, but first ensure that
# no other bridge has been loaded.

BEGIN {
  die( "POE can't use Tk and " . &POE_LOOP_NAME . "\n" )
    if defined &POE_LOOP;
};

sub POE_LOOP () { LOOP_TK }

my $_watcher_timer;

#------------------------------------------------------------------------------
# Signal handler maintenance functions.

sub loop_attach_uidestroy {
  my ($self, $window) = @_;

  $window->OnDestroy
    ( sub {
        if ($self->_data_ses_count()) {
          $self->_dispatch_event
            ( $self, $self,
              EN_SIGNAL, ET_SIGNAL, [ 'UIDESTROY' ],
              __FILE__, __LINE__, time(), -__LINE__
            );
        }
      }
    );
}

#------------------------------------------------------------------------------
# Maintain time watchers.

sub loop_resume_time_watcher {
  my ($self, $next_time) = @_;
  $next_time -= time();

  if (defined $_watcher_timer) {
    $_watcher_timer->cancel();
    undef $_watcher_timer;
  }

  $next_time = 0 if $next_time < 0;
  $_watcher_timer =
    $poe_main_window->after($next_time * 1000, [\&_loop_event_callback]);
}

sub loop_reset_time_watcher {
  my ($self, $next_time) = @_;
  $self->loop_resume_time_watcher($next_time);
}

sub loop_pause_time_watcher {
  my $self = shift;
  $_watcher_timer->stop() if defined $_watcher_timer;
}

# Tk's alarm callbacks seem to have the highest priority.  That is, if
# $widget->after is constantly scheduled for a period smaller than the
# overhead of dispatching it, then no other events are processed.
# That includes afterIdle and even internal Tk events.

# Tk timer callback to dispatch events.
sub _loop_event_callback {
  $poe_kernel->_data_ev_dispatch_due();

  # As was mentioned before, $widget->after() events can dominate a
  # program's event loop, starving it of other events, including Tk's
  # internal widget events.  To avoid this, we'll reset the event
  # callback from an idle event.

  # Register the next timed callback if there are events left.

  if ($poe_kernel->get_event_count()) {

    # Cancel the Tk alarm that handles alarms.

    if (defined $_watcher_timer) {
      $_watcher_timer->cancel();
      undef $_watcher_timer;
    }

    # Replace it with an idle event that will reset the alarm.

    $_watcher_timer =
      $poe_main_window->afterIdle
        ( [ sub {
              $_watcher_timer->cancel();
              undef $_watcher_timer;

              my $next_time = $poe_kernel->get_next_event_time();
              if (defined $next_time) {
                $next_time -= time();
                $next_time = 0 if $next_time < 0;

                $_watcher_timer =
                  $poe_main_window->after( $next_time * 1000,
                                           [\&_loop_event_callback]
                                         );
              }
            }
          ],
        );

    # POE::Kernel's signal polling loop always keeps one event in the
    # queue.  We test for an idle kernel if the queue holds only one
    # event.  A more generic method would be to keep counts of user
    # vs. kernel events, and GC the kernel when the user events drop
    # to 0.

    if ($poe_kernel->get_event_count() == 1) {
      $poe_kernel->_test_if_kernel_is_idle();
    }
  }

  # Make sure the kernel can still run.
  else {
    $poe_kernel->_test_if_kernel_is_idle();
  }
}

#------------------------------------------------------------------------------
# Tk traps errors in an effort to survive them.  However, since POE
# does not, this leaves us in a strange, inconsistent state.  Here we
# re-trap the errors and rethrow them as UIDESTROY.

sub Tk::Error {
  my $window = shift;
  my $error  = shift;

  if (Tk::Exists($window)) {
    my $grab = $window->grab('current');
    $grab->Unbusy if defined $grab;
  }
  chomp($error);
  warn "Tk::Error: $error\n " . join("\n ",@_)."\n";

  if ($poe_kernel->_data_ses_count()) {
    $poe_kernel->_dispatch_event
      ( $poe_kernel, $poe_kernel,
        EN_SIGNAL, ET_SIGNAL, [ 'UIDESTROY' ],
        __FILE__, __LINE__, time(), -__LINE__
      );
  }
}

#------------------------------------------------------------------------------
# The event loop itself.

sub loop_do_timeslice {
  die "doing timeslices currently not supported in the Tk loop";
}

sub loop_run {
  Tk::MainLoop();
}

sub loop_halt {
  undef $_watcher_timer;
  $poe_main_window->destroy();
}

1;

__END__

=head1 NAME

POE::Loop::TkCommon - common features of POE's Tk event loop bridges

=head1 SYNOPSIS

See L<POE::Loop>.

=head1 DESCRIPTION

This class is an implementation of the abstract POE::Loop interface.
It follows POE::Loop's public interface exactly.  Therefore, please
see L<POE::Loop> for its documentation.

=head1 SEE ALSO

L<POE>, L<POE::Loop>, L<Tk>

=head1 AUTHORS & LICENSING

Please see L<POE> for more information about authors, contributors,
and POE's licensing.

=cut