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