Browse files

Add the SysctlPoll backend. Nearly as fast as ptrace, much more porta…

…ble.
  • Loading branch information...
1 parent 061b6a0 commit 844c96c9573c0248420501c5baf3fbbb96e64508 Stefan O'Rear committed Jun 16, 2009
Showing with 112 additions and 1 deletion.
  1. +111 −0 lib/IO/Pty/HalfDuplex/SysctlPoll.pm
  2. +1 −1 sysctl.xsf
View
111 lib/IO/Pty/HalfDuplex/SysctlPoll.pm
@@ -0,0 +1,111 @@
+#!/usr/bin/env perl
+# vim: fdm=marker sw=4 et
+# Documentation head {{{
+
+=head1 NAME
+
+IO::Pty::HalfDuplex::SysctlPoll - wait for blocking reads using sysctl
+
+=head1 SYNOPSIS
+
+ IO::Pty::HalfDuplex->new(backend => 'SysctlPoll')
+
+=head1 CAVEATS
+
+C<IO::Pty::HalfDuplex::SyctlPoll> needs to poll, and will waste a certain
+amount of CPU time while the child runs.
+
+Otherwise it is probably the most robust backend.
+
+=head1 BUGS
+
+See L<IO::Pty::HalfDuplex>.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2008-2009 Stefan O'Rear.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+# }}}
+# header {{{
+package IO::Pty::HalfDuplex::SysctlPoll;
+
+use strict;
+use warnings;
+use POSIX '_exit', ':sys_wait_h', 'tcsetpgrp', 'setpgid';
+
+use base 'IO::Pty::HalfDuplex::Ptyish';
+
+BEGIN {
+ die "XS code for IO::Pty::HalfDuplex::SysctlPoll not built."
+ unless __PACKAGE__->can('_is_waiting');
+}
+
+# }}}
+# control loop and startup {{{
+# Wait for, and process, commands
+sub _shell_loop {
+ my $self = shift;
+
+ while(1) {
+ my $buf = '';
+ sysread($self->{ctl_pipe}, $buf, 1) > 0 or die "read(ctl): $!";
+
+ my $lag = 0.05;
+
+ while (!_is_waiting($self->{slave_pid})) {
+ if (waitpid($self->{slave_pid}, &POSIX::WNOHANG) > 0) {
+ syswrite $self->{info_pipe}, "d" .
+ chr(WIFSIGNALED($?) ? WTERMSIG($?) : 0) .
+ chr(WIFEXITED($?) ? WEXITSTATUS($?) : 0);
+
+ _exit 0;
+ }
+
+ select undef, undef, undef, ($lag *= 1.1);
+ }
+
+ syswrite($self->{info_pipe}, "r");
+ }
+}
+
+# This routine is responsible for creating the proper environment for the
+# slave to run in.
+sub _shell_spawn {
+ my $self = shift;
+
+ $self->{slave_pid} = fork;
+
+ die "fork: $!" unless defined $self->{slave_pid};
+
+ unless ($self->{slave_pid}) {
+ my $pid = $$;
+ $SIG{TTOU} = 'IGNORE';
+ setpgid($pid, $pid);
+ tcsetpgrp(0, $pid);
+ $SIG{TTOU} = 'DEFAULT';
+
+ exec(@{$self->{command}});
+ die "exec: $!";
+ }
+
+ syswrite($self->{info_pipe}, pack('N', $self->{slave_pid}));
+}
+
+sub _shell {
+ my $self = shift;
+ %$self = (
+ %$self,
+ pid => $$,
+ @_
+ );
+
+ $self->_shell_spawn();
+ $self->_shell_loop();
+}
+1;
+# }}}
View
2 sysctl.xsf
@@ -1,4 +1,4 @@
-MODULE = IO::Pty::HalfDuplex PACKAGE = IO::Pty::HalfDuplex::SysctlProc PREFIX = iphd_sysctl
+MODULE = IO::Pty::HalfDuplex PACKAGE = IO::Pty::HalfDuplex::SysctlPoll PREFIX = iphd_sysctl
int
iphd_sysctl_is_waiting(pid)

0 comments on commit 844c96c

Please sign in to comment.