r40224 - in /branches/upstream/libio-async-loop-glib-perl: ./ current/ current/lib/ current/lib/IO/ current/lib/IO/Async/ current/lib/IO/Async/Loop/ current/t/
jawnsy-guest at users.alioth.debian.org
jawnsy-guest at users.alioth.debian.org
Mon Jul 20 02:38:56 UTC 2009
Author: jawnsy-guest
Date: Mon Jul 20 02:38:30 2009
New Revision: 40224
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=40224
Log:
[svn-inject] Installing original source of libio-async-loop-glib-perl
Added:
branches/upstream/libio-async-loop-glib-perl/
branches/upstream/libio-async-loop-glib-perl/current/
branches/upstream/libio-async-loop-glib-perl/current/Build.PL
branches/upstream/libio-async-loop-glib-perl/current/Changes
branches/upstream/libio-async-loop-glib-perl/current/MANIFEST
branches/upstream/libio-async-loop-glib-perl/current/META.yml
branches/upstream/libio-async-loop-glib-perl/current/Makefile.PL
branches/upstream/libio-async-loop-glib-perl/current/lib/
branches/upstream/libio-async-loop-glib-perl/current/lib/IO/
branches/upstream/libio-async-loop-glib-perl/current/lib/IO/Async/
branches/upstream/libio-async-loop-glib-perl/current/lib/IO/Async/Loop/
branches/upstream/libio-async-loop-glib-perl/current/lib/IO/Async/Loop/Glib.pm
branches/upstream/libio-async-loop-glib-perl/current/t/
branches/upstream/libio-async-loop-glib-perl/current/t/00use.t
branches/upstream/libio-async-loop-glib-perl/current/t/01loop.t
branches/upstream/libio-async-loop-glib-perl/current/t/02timing.t
Added: branches/upstream/libio-async-loop-glib-perl/current/Build.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libio-async-loop-glib-perl/current/Build.PL?rev=40224&op=file
==============================================================================
--- branches/upstream/libio-async-loop-glib-perl/current/Build.PL (added)
+++ branches/upstream/libio-async-loop-glib-perl/current/Build.PL Mon Jul 20 02:38:30 2009
@@ -1,0 +1,22 @@
+use strict;
+use warnings;
+
+use Module::Build;
+
+my $build = Module::Build->new
+ (
+ module_name => 'IO::Async::Loop::Glib',
+ requires => {
+ 'IO::Async::Loop' => 0.20,
+ 'Glib' => 0,
+ },
+ build_requires => {
+ 'Test::More' => 0,
+ 'Test::Exception' => 0,
+ 'Time::HiRes' => 0,
+ },
+ license => 'perl',
+ create_makefile_pl => 'traditional',
+ );
+
+$build->create_build_script;
Added: branches/upstream/libio-async-loop-glib-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libio-async-loop-glib-perl/current/Changes?rev=40224&op=file
==============================================================================
--- branches/upstream/libio-async-loop-glib-perl/current/Changes (added)
+++ branches/upstream/libio-async-loop-glib-perl/current/Changes Mon Jul 20 02:38:30 2009
@@ -1,0 +1,21 @@
+Revision history for IO-Async-Loop-Glib
+
+0.15 CHANGES:
+ * Added 'use warnings'
+
+ BUGFIXES:
+ * Account for timing inaccuracies and race condition in timing tests
+
+0.14 CHANGES:
+ * Updated for IO-Async 0.20
+
+0.13: CHANGES:
+ * Implement interfaces required for IO::Async 0.17
+ * Deprecated class IO::Async::Set::GMainLoop now dies instantly
+
+ BUGFIXES:
+ * Be sure to watch for error conditions in Notifiers as well as
+ normal IO
+
+0.12 First version split out from IO-Async dist
+
Added: branches/upstream/libio-async-loop-glib-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libio-async-loop-glib-perl/current/MANIFEST?rev=40224&op=file
==============================================================================
--- branches/upstream/libio-async-loop-glib-perl/current/MANIFEST (added)
+++ branches/upstream/libio-async-loop-glib-perl/current/MANIFEST Mon Jul 20 02:38:30 2009
@@ -1,0 +1,9 @@
+Build.PL
+Changes
+lib/IO/Async/Loop/Glib.pm
+Makefile.PL
+MANIFEST This list of files
+META.yml
+t/00use.t
+t/01loop.t
+t/02timing.t
Added: branches/upstream/libio-async-loop-glib-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libio-async-loop-glib-perl/current/META.yml?rev=40224&op=file
==============================================================================
--- branches/upstream/libio-async-loop-glib-perl/current/META.yml (added)
+++ branches/upstream/libio-async-loop-glib-perl/current/META.yml Mon Jul 20 02:38:30 2009
@@ -1,0 +1,24 @@
+---
+name: IO-Async-Loop-Glib
+version: 0.15
+author:
+ - 'Paul Evans E<lt>leonerd at leonerd.org.ukE<gt>'
+abstract: a Loop using the C<Glib::MainLoop> object
+license: perl
+resources:
+ license: http://dev.perl.org/licenses/
+requires:
+ Glib: 0
+ IO::Async::Loop: 0.2
+build_requires:
+ Test::Exception: 0
+ Test::More: 0
+ Time::HiRes: 0
+provides:
+ IO::Async::Loop::Glib:
+ file: lib/IO/Async/Loop/Glib.pm
+ version: 0.15
+generated_by: Module::Build version 0.33
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
Added: branches/upstream/libio-async-loop-glib-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libio-async-loop-glib-perl/current/Makefile.PL?rev=40224&op=file
==============================================================================
--- branches/upstream/libio-async-loop-glib-perl/current/Makefile.PL (added)
+++ branches/upstream/libio-async-loop-glib-perl/current/Makefile.PL Mon Jul 20 02:38:30 2009
@@ -1,0 +1,18 @@
+# Note: this file was auto-generated by Module::Build::Compat version 0.33
+use ExtUtils::MakeMaker;
+WriteMakefile
+(
+ 'NAME' => 'IO::Async::Loop::Glib',
+ 'VERSION_FROM' => 'lib/IO/Async/Loop/Glib.pm',
+ 'PREREQ_PM' => {
+ 'Glib' => 0,
+ 'IO::Async::Loop' => '0.2',
+ 'Test::Exception' => 0,
+ 'Test::More' => 0,
+ 'Time::HiRes' => 0
+ },
+ 'INSTALLDIRS' => 'site',
+ 'EXE_FILES' => [],
+ 'PL_FILES' => {}
+ )
+;
Added: branches/upstream/libio-async-loop-glib-perl/current/lib/IO/Async/Loop/Glib.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libio-async-loop-glib-perl/current/lib/IO/Async/Loop/Glib.pm?rev=40224&op=file
==============================================================================
--- branches/upstream/libio-async-loop-glib-perl/current/lib/IO/Async/Loop/Glib.pm (added)
+++ branches/upstream/libio-async-loop-glib-perl/current/lib/IO/Async/Loop/Glib.pm Mon Jul 20 02:38:30 2009
@@ -1,0 +1,307 @@
+# You may distribute under the terms of either the GNU General Public License
+# or the Artistic License (the same terms as Perl itself)
+#
+# (C) Paul Evans, 2007-2009 -- leonerd at leonerd.org.uk
+
+package IO::Async::Loop::Glib;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.15';
+
+use base qw( IO::Async::Loop );
+
+use Carp;
+
+use Glib;
+
+=head1 NAME
+
+C<IO::Async::Loop::Glib> - a Loop using the C<Glib::MainLoop> object
+
+=head1 SYNOPSIS
+
+ use IO::Async::Loop::Glib;
+
+ my $loop = IO::Async::Loop::Glib->new();
+
+ $loop->add( ... );
+
+ ...
+ # Rest of GLib/Gtk program that uses GLib
+
+ Glib::MainLoop->new->run();
+
+Or
+
+ $loop->loop_forever();
+
+Or
+
+ while(1) {
+ $loop->loop_once();
+ }
+
+=head1 DESCRIPTION
+
+This subclass of C<IO::Async::Loop> uses the C<Glib::MainLoop> to perform
+read-ready and write-ready tests.
+
+The appropriate C<Glib::IO> sources are added or removed from the
+C<Glib::MainLoop> when notifiers are added or removed from the set, or when
+they change their C<want_writeready> status. The callbacks are called
+automatically by Glib itself; no special methods on this loop object are
+required.
+
+=cut
+
+=head1 CONSTRUCTOR
+
+=cut
+
+=head2 $loop = IO::Async::Loop::Glib->new()
+
+This function returns a new instance of a C<IO::Async::Loop::Glib> object. It
+takes no special arguments.
+
+=cut
+
+sub new
+{
+ my $class = shift;
+ my ( %args ) = @_;
+
+ my $self = $class->__new( %args );
+
+ $self->{sourceid} = {}; # {$fd} -> [ $readid, $writeid ]
+
+ $self->{timercallbacks} = {}; # {$timer_id} -> $code
+
+ return $self;
+}
+
+sub __new_feature
+{
+ my $self = shift;
+ my ( $classname ) = @_;
+
+ # veto IO::Async::TimeQueue since we implement its methods locally
+ die __PACKAGE__." implements $classname internally"
+ if grep { $_ eq $classname } qw( IO::Async::TimeQueue );
+
+ return $self->SUPER::__new_feature( $classname );
+}
+
+=head1 METHODS
+
+There are no special methods in this subclass, other than those provided by
+the C<IO::Async::Loop> base class.
+
+=cut
+
+# override
+sub watch_io
+{
+ my $self = shift;
+ my %params = @_;
+
+ my $handle = $params{handle} or croak "Expected 'handle'";
+ my $fd = $handle->fileno;
+
+ my $sourceids = ( $self->{sourceid}->{$fd} ||= [] );
+
+ if( my $on_read_ready = $params{on_read_ready} ) {
+ Glib::Source->remove( $sourceids->[0] ) if defined $sourceids->[0];
+
+ $sourceids->[0] = Glib::IO->add_watch( $fd,
+ ['in', 'hup', 'err'],
+ sub {
+ $on_read_ready->();
+ # Must yield true value or else GLib will remove this IO source
+ return 1;
+ }
+ );
+ }
+
+ if( my $on_write_ready = $params{on_write_ready} ) {
+ Glib::Source->remove( $sourceids->[1] ) if defined $sourceids->[1];
+
+ $sourceids->[1] = Glib::IO->add_watch( $fd,
+ ['out', 'hup', 'err'],
+ sub {
+ $on_write_ready->();
+ # Must yield true value or else GLib will remove this IO source
+ return 1;
+ }
+ );
+ }
+}
+
+# override
+sub unwatch_io
+{
+ my $self = shift;
+ my %params = @_;
+
+ my $handle = $params{handle} or croak "Expected 'handle'";
+ my $fd = $handle->fileno;
+
+ my $sourceids = $self->{sourceid}->{$fd} or return;
+
+ if( $params{on_read_ready} ) {
+ Glib::Source->remove( $sourceids->[0] ) if defined $sourceids->[0];
+ undef $sourceids->[0];
+ }
+
+ if( $params{on_write_ready} ) {
+ Glib::Source->remove( $sourceids->[1] ) if defined $sourceids->[1];
+ undef $sourceids->[1];
+ }
+
+ delete $self->{sourceids}->{$fd} if not $sourceids->[0] and not $sourceids->[1];
+}
+
+# override
+sub enqueue_timer
+{
+ my $self = shift;
+ my ( %params ) = @_;
+
+ # Just let GLib handle all these timer events
+ my $delay;
+ if( exists $params{time} ) {
+ my $now = exists $params{now} ? $params{now} : time();
+
+ $delay = delete($params{time}) - $now;
+ }
+ elsif( exists $params{delay} ) {
+ $delay = delete $params{delay};
+ }
+ else {
+ croak "Expected either 'time' or 'delay' keys";
+ }
+
+ my $interval = $delay * 1000; # miliseconds
+
+ my $code = delete $params{code};
+ ref $code eq "CODE" or croak "Expected 'code' to be a CODE reference";
+
+ my $id;
+
+ my $callback = sub {
+ $code->();
+ delete $self->{timercallbacks}->{$id};
+ return 0;
+ };
+
+ $id = Glib::Timeout->add( $interval, $callback );
+
+ $self->{timercallbacks}->{$id} = $code;
+
+ return $id;
+}
+
+# override
+sub cancel_timer
+{
+ my $self = shift;
+ my ( $id ) = @_;
+
+ Glib::Source->remove( $id );
+
+ delete $self->{timercallbacks}->{$id};
+
+ return;
+}
+
+# override
+sub requeue_timer
+{
+ my $self = shift;
+ my ( $id, %params ) = @_;
+
+ my $callback = $self->{timercallbacks}->{$id};
+ defined $callback or croak "No such enqueued timer";
+
+ $self->cancel_timer( $id );
+
+ return $self->enqueue_timer( %params, code => $callback );
+}
+
+=head2 $count = $loop->loop_once( $timeout )
+
+This method calls the C<iteration()> method on the underlying
+C<Glib::MainContext>. If a timeout value is supplied, then a Glib timeout
+will be installed, to interrupt the loop at that time. If Glib indicates that
+any callbacks were fired, then this method will return 1 (however, it does not
+mean that any C<IO::Async> callbacks were invoked, as there may be other parts
+of code sharing the Glib main context. Otherwise, it will return 0.
+
+=cut
+
+# override
+sub loop_once
+{
+ my $self = shift;
+ my ( $timeout ) = @_;
+
+ $self->_adjust_timeout( \$timeout, no_sigwait => 1 );
+
+ my $timed_out = 0;
+
+ my $timerid;
+ if( defined $timeout ) {
+ my $interval = $timeout * 1000; # miliseconds
+ $timerid = Glib::Timeout->add( $interval, sub { $timed_out = 1; return 0; } );
+ }
+
+ my $context = Glib::MainContext->default;
+ my $ret = $context->iteration( 1 );
+
+ Glib::Source->remove( $timerid ) unless $timed_out;
+
+ return $ret and not $timed_out ? 1 : 0;
+}
+
+# override
+sub loop_forever
+{
+ my $self = shift;
+
+ my $mainloop = $self->{mainloop} = Glib::MainLoop->new();
+ $mainloop->run;
+
+ undef $self->{mainloop};
+}
+
+# override
+sub loop_stop
+{
+ my $self = shift;
+
+ $self->{mainloop}->quit;
+}
+
+# Keep perl happy; keep Britain tidy
+1;
+
+__END__
+
+=head1 SEE ALSO
+
+=over 4
+
+=item *
+
+L<Glib> - Perl wrappers for the GLib utility and Object libraries
+
+=item *
+
+L<Gtk2> - Perl interface to the 2.x series of the Gimp Toolkit library
+
+=back
+
+=head1 AUTHOR
+
+Paul Evans E<lt>leonerd at leonerd.org.ukE<gt>
Added: branches/upstream/libio-async-loop-glib-perl/current/t/00use.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libio-async-loop-glib-perl/current/t/00use.t?rev=40224&op=file
==============================================================================
--- branches/upstream/libio-async-loop-glib-perl/current/t/00use.t (added)
+++ branches/upstream/libio-async-loop-glib-perl/current/t/00use.t Mon Jul 20 02:38:30 2009
@@ -1,0 +1,6 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More tests => 1;
+
+use_ok( "IO::Async::Loop::Glib" );
Added: branches/upstream/libio-async-loop-glib-perl/current/t/01loop.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libio-async-loop-glib-perl/current/t/01loop.t?rev=40224&op=file
==============================================================================
--- branches/upstream/libio-async-loop-glib-perl/current/t/01loop.t (added)
+++ branches/upstream/libio-async-loop-glib-perl/current/t/01loop.t Mon Jul 20 02:38:30 2009
@@ -1,0 +1,158 @@
+#!/usr/bin/perl -w
+
+use strict;
+
+use Test::More tests => 17;
+use Test::Exception;
+
+use IO::Async::Notifier;
+
+use IO::Async::Loop::Glib;
+
+my $loop = IO::Async::Loop::Glib->new();
+
+ok( defined $loop, '$loop defined' );
+isa_ok( $loop, "IO::Async::Loop::Glib", '$loop isa IO::Async::Loop::Glib' );
+
+my ( $S1, $S2 ) = $loop->socketpair() or die "Cannot create socket pair - $!";
+
+# Need sockets in nonblocking mode
+$S1->blocking( 0 );
+$S2->blocking( 0 );
+
+my $readready = 0;
+my $writeready = 0;
+
+my $notifier = IO::Async::Notifier->new( handle => $S1,
+ on_read_ready => sub { $readready = 1; return 0 },
+ on_write_ready => sub { $writeready = 1; return 0 },
+);
+
+my $context = Glib::MainContext->default;
+
+# Idle
+
+$loop->add( $notifier );
+
+is( $notifier->get_loop, $loop, '$notifier->__memberof_loop == $loop' );
+
+dies_ok( sub { $loop->add( $notifier ) }, 'adding again produces error' );
+
+$context->iteration( 0 );
+
+# Read-ready
+
+$S2->syswrite( "data\n" );
+
+is( $readready, 0, '$readready before iteration' );
+
+$context->iteration( 0 );
+
+# Ready $S1 to clear the data
+$S1->getline(); # ignore return
+
+is( $readready, 1, '$readready after iteration' );
+
+# Write-ready
+$notifier->want_writeready( 1 );
+
+is( $writeready, 0, '$writeready before iteration' );
+
+$context->iteration( 0 );
+$notifier->want_writeready( 0 );
+
+is( $writeready, 1, '$writeready after iteration' );
+
+# loop_once
+
+$writeready = 0;
+$notifier->want_writeready( 1 );
+
+my $ready;
+$ready = $loop->loop_once( 0.1 );
+
+is( $ready, 1, '$ready after loop_once' );
+is( $writeready, 1, '$writeready after loop_once' );
+
+# HUP
+
+$readready = 0;
+$context->iteration( 0 );
+
+is( $readready, 0, '$readready before HUP' );
+
+close( $S2 );
+
+$readready = 0;
+$context->iteration( 0 );
+
+is( $readready, 1, '$readready after HUP' );
+
+# loop_forever
+
+my $stdout_notifier = IO::Async::Notifier->new( handle => \*STDOUT,
+ on_read_ready => sub { },
+ on_write_ready => sub { $loop->loop_stop() },
+ want_writeready => 1,
+);
+$loop->add( $stdout_notifier );
+
+$writeready = 0;
+
+$SIG{ALRM} = sub { die "Test timed out"; };
+alarm( 1 );
+
+$loop->loop_forever();
+
+alarm( 0 );
+
+is( $writeready, 1, '$writeready after loop_forever' );
+
+$loop->remove( $stdout_notifier );
+
+# Removal
+
+$loop->remove( $notifier );
+
+is( $notifier->get_loop, undef, '$notifier->__memberof_loop is undef' );
+
+# Write-only
+
+my $write_only_notifier = IO::Async::Notifier->new(
+ write_handle => $S1,
+ want_writeready => 1,
+ on_write_ready => sub { $writeready = 1 },
+);
+
+$loop->add( $write_only_notifier );
+
+$writeready = 0;
+$context->iteration( 0 );
+
+is( $writeready, 1, '$writeready after writeonly notifier' );
+
+$loop->remove( $write_only_notifier );
+
+# HUP of pipe
+
+my ( $P1, $P2 ) = $loop->pipepair() or die "Cannot pipepair - $!";
+my $pipe_io = IO::Handle->new_from_fd( fileno( $P1 ), 'r' );
+my $pipe_notifier = IO::Async::Notifier->new(
+ read_handle => $pipe_io,
+ on_read_ready => sub { $readready = 1 },
+);
+$loop->add( $pipe_notifier );
+
+$readready = 0;
+$context->iteration( 0 );
+
+is( $readready, 0, '$readready before pipe HUP' );
+
+close( $P2 );
+
+$readready = 0;
+$context->iteration( 0 );
+
+is( $readready, 1, '$readready after pipe HUP' );
+
+$loop->remove( $pipe_notifier );
Added: branches/upstream/libio-async-loop-glib-perl/current/t/02timing.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libio-async-loop-glib-perl/current/t/02timing.t?rev=40224&op=file
==============================================================================
--- branches/upstream/libio-async-loop-glib-perl/current/t/02timing.t (added)
+++ branches/upstream/libio-async-loop-glib-perl/current/t/02timing.t Mon Jul 20 02:38:30 2009
@@ -1,0 +1,63 @@
+#!/usr/bin/perl -w
+
+use strict;
+
+use Test::More tests => 5;
+
+use Time::HiRes qw( time );
+
+use IO::Socket::UNIX;
+
+use IO::Async::Loop::Glib;
+
+my $loop = IO::Async::Loop::Glib->new();
+
+my $done = 0;
+
+$loop->enqueue_timer( delay => 2, code => sub { $done = 1; } );
+
+my $id = $loop->enqueue_timer( delay => 3, code => sub { die "This timer should have been cancelled" } );
+$loop->cancel_timer( $id );
+
+undef $id;
+
+my ( $now, $took );
+
+$SIG{ALRM} = sub { die "Test timed out" };
+alarm 4;
+
+$now = time;
+# GLib might return just a little early, such that the TimerQueue
+# doesn't think anything is ready yet. We need to handle that case.
+$loop->loop_once( 0.1 ) while !$done;
+$took = time - $now;
+
+alarm 0;
+
+is( $done, 1, '$done after iteration while waiting for timer' );
+
+cmp_ok( $took, '>', 1.9, 'iteration while waiting for timer takes at least 1.9 seconds' );
+cmp_ok( $took, '<', 10, 'iteration while waiting for timer no more than 10 seconds' );
+if( $took > 2.5 ) {
+ diag( "iteration while waiting for timer took more than 2.5 seconds.\n" .
+ "This is not itself a bug, and may just be an indication of a busy testing machine" );
+}
+
+$id = $loop->enqueue_timer( delay => 1, code => sub { $done = 2; } );
+$id = $loop->requeue_timer( $id, delay => 2 );
+
+$done = 0;
+
+alarm 3;
+
+$loop->loop_once( 1 );
+
+is( $done, 0, '$done still 0 so far' );
+
+$loop->loop_once( 5 );
+
+# GLib might return just a little early, such that the TimerQueue
+# doesn't think anything is ready yet. We need to handle that case.
+$loop->loop_once( 0.1 ) while !$done;
+
+is( $done, 2, '$done is 2 after requeued timer' );
More information about the Pkg-perl-cvs-commits
mailing list