File Coverage

blib/lib/Stem/Event/Tk.pm

Criterion	Covered	Total	%
statement	4	6	66.6
branch			n/a
condition			n/a
subroutine	2	2	100.0
pod			n/a
total	6	8	75.0

#  File: Stem/Event/Tk.pm

#  This file is part of Stem.
#  Copyright (C) 1999, 2000, 2001 Stem Systems, Inc.

#  Stem is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.

#  Stem is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.

#  You should have received a copy of the GNU General Public License
#  along with Stem; if not, write to the Free Software
#  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

#  For a license to use the Stem under conditions other than those
#  described here, to purchase support for this software, or to purchase a
#  commercial warranty contract, please contact Stem Systems at:

#       Stem Systems, Inc.		781-643-7504
#  	79 Everett St.			[e-mail]
#  	Arlington, MA 02474
#  	USA

=head1 Stem::Event::Tk

This module wraps the CPAN module Event.pm for use by the rest of
Stem. It provides the common API for the standard Stem::Event classes:

=over 4

=item Stem::Event
=item Stem::Event::Plain
=item Stem::Event::Timer
=item Stem::Event::Signal
=item Stem::Event::Read
=item Stem::Event::Write

=back

=cut

package Stem::Event::Tk ;

use strict ;
use Tk ;

use Stem::Event::Signal ;

my $tk_main_window ;

# basic wrappers for top level Tk.pm calls.

sub _init_loop {

	$tk_main_window ||= MainWindow->new() ;
	$tk_main_window->withdraw() ;
}

sub _start_loop {
	_init_loop() ;
	MainLoop() ;
}

sub _stop_loop {

#print "STOP INFO ", $tk_main_window->afterInfo(), "\n" ;

	$tk_main_window->destroy() ;
	$tk_main_window = undef ;
}

############################################################################

package Stem::Event::Plain ;

sub _build {

	my( $self ) = @_ ;

# create the plain event watcher

	$self->{'idle_event'} = Event->idle(
		'cb'		=> [ $self, 'idle_triggered' ],
		'repeat'	=> 0
	) ;

	return $self ;
}

sub idle_triggered {

	my( $self ) = @_ ;

	$self->trigger() ;
	my $idle_event = delete $self->{'idle_event'} ;
	$idle_event->cancel() ;
}

############################################################################

package Stem::Event::Timer ;

sub _build {

	my( $self ) = @_ ;

Stem::Event::Tk::_init_loop() ;

# tk times in milliseconds and stem times in floating seconds so
# we convert to integer ms.

	my $delay_ms = int( $self->{'delay'} * 1000 ) ;

#	$self->{interval_ms} = int( ( $self->{'interval'} || 0 ) * 1000 ) ;

	my $timer_method = $self->{'interval'} ? 'repeat' : 'after' ;

	return $tk_main_window->$timer_method(
				$delay_ms,
				[$self => 'timer_triggered']
	) ;
}

sub _reset {

	my( $self, $timer_event, $delay ) = @_ ;
	my $delay_ms = int( $delay * 1000 ) ;
	$timer_event->time( $delay_ms ) ;
}

sub _cancel {
	my( $self, $timer_event ) = @_ ;
	$timer_event->cancel() ;
	return ;
}

############################################################################

package Stem::Event::Read ;

sub _build {

	my( $self ) = @_ ;
	goto &_start if $self->{active} ;
	return ;
}

sub _start {

	my( $self ) = @_ ;

	return $tk_main_window->fileevent(
		$self->{'fh'},
		'readable',
		[$self => 'trigger']
	) ;
}

sub _cancel { goto &_stop }

sub _stop {
	my( $self ) = @_ ;

	$tk_main_window->fileevent(
		$self->{'fh'},
		'readable',
		''
	) ;
}

############################################################################

package Stem::Event::Write ;

sub _build {
	my( $self ) = @_ ;
	goto &_start if $self->{active} ;
	return ;
}

sub _start {

	my( $self ) = @_ ;

	return $tk_main_window->fileevent(
		$self->{'fh'},
		'writable',
		[$self => 'trigger']
	) ;
}

sub _cancel { goto &_stop }

sub _stop {

	my( $self ) = @_ ;

	$tk_main_window->fileevent(
		$self->{'fh'},
		'writable',
		''
	) ;
}

1 ;