r4587 - in /packages/libsys-syscall-perl: ./ branches/
branches/upstream/
branches/upstream/current/ branches/upstream/current/lib/
branches/upstream/current/lib/Sys/ branches/upstream/current/t/ tags/
eloy at users.alioth.debian.org
eloy at users.alioth.debian.org
Wed Dec 6 10:19:28 CET 2006
Author: eloy
Date: Wed Dec 6 10:19:28 2006
New Revision: 4587
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=4587
Log:
[svn-inject] Installing original source of libsys-syscall-perl
Added:
packages/libsys-syscall-perl/
packages/libsys-syscall-perl/branches/
packages/libsys-syscall-perl/branches/upstream/
packages/libsys-syscall-perl/branches/upstream/current/
packages/libsys-syscall-perl/branches/upstream/current/CHANGES
packages/libsys-syscall-perl/branches/upstream/current/MANIFEST
packages/libsys-syscall-perl/branches/upstream/current/META.yml
packages/libsys-syscall-perl/branches/upstream/current/Makefile.PL
packages/libsys-syscall-perl/branches/upstream/current/lib/
packages/libsys-syscall-perl/branches/upstream/current/lib/Sys/
packages/libsys-syscall-perl/branches/upstream/current/lib/Sys/Syscall.pm
packages/libsys-syscall-perl/branches/upstream/current/t/
packages/libsys-syscall-perl/branches/upstream/current/t/00-use.t
packages/libsys-syscall-perl/branches/upstream/current/t/01-epoll.t
packages/libsys-syscall-perl/branches/upstream/current/t/02-sendfile.t
packages/libsys-syscall-perl/tags/
Added: packages/libsys-syscall-perl/branches/upstream/current/CHANGES
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libsys-syscall-perl/branches/upstream/current/CHANGES?rev=4587&op=file
==============================================================================
--- packages/libsys-syscall-perl/branches/upstream/current/CHANGES (added)
+++ packages/libsys-syscall-perl/branches/upstream/current/CHANGES Wed Dec 6 10:19:28 2006
@@ -1,0 +1,15 @@
+0.22:
+ - don't modify non-localized $_. whoops. (we don't want to mess
+ with our caller's world)
+
+0.21:
+ - add missing EPOLLRDBAND, from Paul Visscher <paulv at canonical.org>
+
+0.20:
+
+ - on x86_64 detect 32-bit vs 64-bit process and use right syscall
+ numbers. previously worked only with 64-bit userland.
+
+0.1:
+
+ - first release. epoll and sendfile only. Linux only.
Added: packages/libsys-syscall-perl/branches/upstream/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libsys-syscall-perl/branches/upstream/current/MANIFEST?rev=4587&op=file
==============================================================================
--- packages/libsys-syscall-perl/branches/upstream/current/MANIFEST (added)
+++ packages/libsys-syscall-perl/branches/upstream/current/MANIFEST Wed Dec 6 10:19:28 2006
@@ -1,0 +1,8 @@
+Makefile.PL
+CHANGES
+MANIFEST This list of files
+lib/Sys/Syscall.pm
+META.yml
+t/00-use.t
+t/01-epoll.t
+t/02-sendfile.t
Added: packages/libsys-syscall-perl/branches/upstream/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libsys-syscall-perl/branches/upstream/current/META.yml?rev=4587&op=file
==============================================================================
--- packages/libsys-syscall-perl/branches/upstream/current/META.yml (added)
+++ packages/libsys-syscall-perl/branches/upstream/current/META.yml Wed Dec 6 10:19:28 2006
@@ -1,0 +1,12 @@
+# http://module-build.sourceforge.net/META-spec.html
+#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
+name: Sys-Syscall
+version: 0.22
+version_from: lib/Sys/Syscall.pm
+installdirs: site
+requires:
+ POSIX: 0
+ Test::More: 0
+
+distribution_type: module
+generated_by: ExtUtils::MakeMaker version 6.17
Added: packages/libsys-syscall-perl/branches/upstream/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libsys-syscall-perl/branches/upstream/current/Makefile.PL?rev=4587&op=file
==============================================================================
--- packages/libsys-syscall-perl/branches/upstream/current/Makefile.PL (added)
+++ packages/libsys-syscall-perl/branches/upstream/current/Makefile.PL Wed Dec 6 10:19:28 2006
@@ -1,0 +1,33 @@
+#!/usr/bin/perl
+#
+# Perl Makefile for Perlbal
+# $Id: Makefile.PL 4 2005-07-30 04:56:21Z bradfitz $
+#
+# Invoke with 'perl Makefile.PL'
+#
+# See ExtUtils::MakeMaker (3) for more information on how to influence
+# the contents of the Makefile that is written
+#
+
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ NAME => 'Sys::Syscall',
+ VERSION_FROM => 'lib/Sys/Syscall.pm',
+ AUTHOR => 'Brad Fitzpatrick <brad at danga.com>',
+ ABSTRACT => 'Invoke system calls that are otherwise difficult to do from Perl.',
+
+ PREREQ_PM => {
+ 'POSIX' => 0,
+ 'Test::More' => 0,
+ },
+ dist => {
+# CI => "cvs commit",
+# RCS_LABEL => 'cvs tag RELEASE_$(VERSION_SYM)',
+ SUFFIX => ".gz",
+ DIST_DEFAULT => 'all tardist',
+ COMPRESS => "gzip",
+ },
+);
+
+
Added: packages/libsys-syscall-perl/branches/upstream/current/lib/Sys/Syscall.pm
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libsys-syscall-perl/branches/upstream/current/lib/Sys/Syscall.pm?rev=4587&op=file
==============================================================================
--- packages/libsys-syscall-perl/branches/upstream/current/lib/Sys/Syscall.pm (added)
+++ packages/libsys-syscall-perl/branches/upstream/current/lib/Sys/Syscall.pm Wed Dec 6 10:19:28 2006
@@ -1,0 +1,335 @@
+# LICENSE: You're free to distribute this under the same terms as Perl itself.
+
+package Sys::Syscall;
+use strict;
+use POSIX qw(ENOSYS SEEK_CUR);
+use Config;
+
+require Exporter;
+use vars qw(@ISA @EXPORT_OK %EXPORT_TAGS $VERSION);
+
+$VERSION = "0.22";
+ at ISA = qw(Exporter);
+ at EXPORT_OK = qw(sendfile epoll_ctl epoll_create epoll_wait
+ EPOLLIN EPOLLOUT EPOLLERR EPOLLHUP EPOLLRDBAND
+ EPOLL_CTL_ADD EPOLL_CTL_DEL EPOLL_CTL_MOD);
+%EXPORT_TAGS = (epoll => [qw(epoll_ctl epoll_create epoll_wait
+ EPOLLIN EPOLLOUT EPOLLERR EPOLLHUP EPOLLRDBAND
+ EPOLL_CTL_ADD EPOLL_CTL_DEL EPOLL_CTL_MOD)],
+ sendfile => [qw(sendfile)],
+ );
+
+use constant EPOLLIN => 1;
+use constant EPOLLOUT => 4;
+use constant EPOLLERR => 8;
+use constant EPOLLHUP => 16;
+use constant EPOLLRDBAND => 128;
+use constant EPOLL_CTL_ADD => 1;
+use constant EPOLL_CTL_DEL => 2;
+use constant EPOLL_CTL_MOD => 3;
+
+our $loaded_syscall = 0;
+
+sub _load_syscall {
+ # props to Gaal for this!
+ return if $loaded_syscall++;
+ my $clean = sub {
+ delete @INC{qw<syscall.ph asm/unistd.ph bits/syscall.ph
+ _h2ph_pre.ph sys/syscall.ph>};
+ };
+ $clean->(); # don't trust modules before us
+ my $rv = eval { require 'syscall.ph'; 1 } || eval { require 'sys/syscall.ph'; 1 };
+ $clean->(); # don't require modules after us trust us
+ return $rv;
+}
+
+our ($sysname, $nodename, $release, $version, $machine) = POSIX::uname();
+
+our (
+ $SYS_epoll_create,
+ $SYS_epoll_ctl,
+ $SYS_epoll_wait,
+ $SYS_sendfile,
+ $SYS_readahead,
+ );
+
+if ($^O eq "linux") {
+ # whether the machine requires 64-bit numbers to be on 8-byte
+ # boundaries.
+ my $u64_mod_8 = 0;
+
+ # if we're running on an x86_64 kernel, but a 32-bit process,
+ # we need to use the i386 syscall numbers.
+ if ($machine eq "x86_64" && $Config{ptrsize} == 4) {
+ $machine = "i386";
+ }
+
+ if ($machine =~ m/^i[3456]86$/) {
+ $SYS_epoll_create = 254;
+ $SYS_epoll_ctl = 255;
+ $SYS_epoll_wait = 256;
+ $SYS_sendfile = 187; # or 64: 239
+ $SYS_readahead = 225;
+ } elsif ($machine eq "x86_64") {
+ $SYS_epoll_create = 213;
+ $SYS_epoll_ctl = 233;
+ $SYS_epoll_wait = 232;
+ $SYS_sendfile = 40;
+ $SYS_readahead = 187;
+ } elsif ($machine eq "ppc64") {
+ $SYS_epoll_create = 236;
+ $SYS_epoll_ctl = 237;
+ $SYS_epoll_wait = 238;
+ $SYS_sendfile = 186; # (sys32_sendfile). sys32_sendfile64=226 (64 bit processes: sys_sendfile64=186)
+ $SYS_readahead = 191; # both 32-bit and 64-bit vesions
+ $u64_mod_8 = 1;
+ } elsif ($machine eq "ppc") {
+ $SYS_epoll_create = 236;
+ $SYS_epoll_ctl = 237;
+ $SYS_epoll_wait = 238;
+ $SYS_sendfile = 186; # sys_sendfile64=226
+ $SYS_readahead = 191;
+ $u64_mod_8 = 1;
+ } elsif ($machine eq "ia64") {
+ $SYS_epoll_create = 1243;
+ $SYS_epoll_ctl = 1244;
+ $SYS_epoll_wait = 1245;
+ $SYS_sendfile = 1187;
+ $SYS_readahead = 1216;
+ $u64_mod_8 = 1;
+ } elsif ($machine eq "alpha") {
+ # natural alignment, ints are 32-bits
+ $SYS_sendfile = 370; # (sys_sendfile64)
+ $SYS_epoll_create = 407;
+ $SYS_epoll_ctl = 408;
+ $SYS_epoll_wait = 409;
+ $SYS_readahead = 379;
+ $u64_mod_8 = 1;
+ } else {
+ # as a last resort, try using the *.ph files which may not
+ # exist or may be wrong
+ _load_syscall();
+ $SYS_epoll_create = eval { &SYS_epoll_create; } || 0;
+ $SYS_epoll_ctl = eval { &SYS_epoll_ctl; } || 0;
+ $SYS_epoll_wait = eval { &SYS_epoll_wait; } || 0;
+ $SYS_readahead = eval { &SYS_readahead; } || 0;
+ }
+
+ if ($u64_mod_8) {
+ *epoll_wait = \&epoll_wait_mod8;
+ *epoll_ctl = \&epoll_ctl_mod8;
+ } else {
+ *epoll_wait = \&epoll_wait_mod4;
+ *epoll_ctl = \&epoll_ctl_mod4;
+ }
+}
+
+elsif ($^O eq "freebsd") {
+ if ($ENV{FREEBSD_SENDFILE}) {
+ # this is still buggy and in development
+ $SYS_sendfile = 393; # old is 336
+ }
+}
+
+############################################################################
+# sendfile functions
+############################################################################
+
+unless ($SYS_sendfile) {
+ _load_syscall();
+ $SYS_sendfile = eval { &SYS_sendfile; } || 0;
+}
+
+sub sendfile_defined { return $SYS_sendfile ? 1 : 0; }
+
+if ($^O eq "linux" && $SYS_sendfile) {
+ *sendfile = \&sendfile_linux;
+} elsif ($^O eq "freebsd" && $SYS_sendfile) {
+ *sendfile = \&sendfile_freebsd;
+} else {
+ *sendfile = \&sendfile_noimpl;
+}
+
+sub sendfile_noimpl {
+ $! = ENOSYS;
+ return -1;
+}
+
+# C: ssize_t sendfile(int out_fd, int in_fd, off_t *offset, size_t count)
+# Perl: sendfile($write_fd, $read_fd, $max_count) --> $actually_sent
+sub sendfile_linux {
+ return syscall(
+ $SYS_sendfile,
+ $_[0] + 0, # fd
+ $_[1] + 0, # fd
+ 0, # don't keep track of offset. callers can lseek and keep track.
+ $_[2] + 0 # count
+ );
+}
+
+sub sendfile_freebsd {
+ my $offset = POSIX::lseek($_[1]+0, 0, SEEK_CUR) + 0;
+ my $ct = $_[2] + 0;
+ my $sbytes_buf = "\0" x 8;
+ my $rv = syscall(
+ $SYS_sendfile,
+ $_[1] + 0, # fd (from)
+ $_[0] + 0, # socket (to)
+ $offset,
+ $ct,
+ 0, # struct sf_hdtr *hdtr
+ $sbytes_buf, # off_t *sbytes
+ 0); # flags
+ return $rv if $rv < 0;
+
+
+ my $set = unpack("L", $sbytes_buf);
+ POSIX::lseek($_[1]+0, SEEK_CUR, $set);
+ return $set;
+}
+
+
+############################################################################
+# epoll functions
+############################################################################
+
+sub epoll_defined { return $SYS_epoll_create ? 1 : 0; }
+
+# ARGS: (size) -- but in modern Linux 2.6, the
+# size doesn't even matter (radix tree now, not hash)
+sub epoll_create {
+ return -1 unless defined $SYS_epoll_create;
+ my $epfd = eval { syscall($SYS_epoll_create, ($_[0]||100)+0) };
+ return -1 if $@;
+ return $epfd;
+}
+
+# epoll_ctl wrapper
+# ARGS: (epfd, op, fd, events_mask)
+sub epoll_ctl_mod4 {
+ syscall($SYS_epoll_ctl, $_[0]+0, $_[1]+0, $_[2]+0, pack("LLL", $_[3], $_[2], 0));
+}
+sub epoll_ctl_mod8 {
+ syscall($SYS_epoll_ctl, $_[0]+0, $_[1]+0, $_[2]+0, pack("LLLL", $_[3], 0, $_[2], 0));
+}
+
+# epoll_wait wrapper
+# ARGS: (epfd, maxevents, timeout (milliseconds), arrayref)
+# arrayref: values modified to be [$fd, $event]
+our $epoll_wait_events;
+our $epoll_wait_size = 0;
+sub epoll_wait_mod4 {
+ # resize our static buffer if requested size is bigger than we've ever done
+ if ($_[1] > $epoll_wait_size) {
+ $epoll_wait_size = $_[1];
+ $epoll_wait_events = "\0" x 12 x $epoll_wait_size;
+ }
+ my $ct = syscall($SYS_epoll_wait, $_[0]+0, $epoll_wait_events, $_[1]+0, $_[2]+0);
+ for (0..$ct-1) {
+ @{$_[3]->[$_]}[1,0] = unpack("LL", substr($epoll_wait_events, 12*$_, 8));
+ }
+ return $ct;
+}
+
+sub epoll_wait_mod8 {
+ # resize our static buffer if requested size is bigger than we've ever done
+ if ($_[1] > $epoll_wait_size) {
+ $epoll_wait_size = $_[1];
+ $epoll_wait_events = "\0" x 16 x $epoll_wait_size;
+ }
+ my $ct = syscall($SYS_epoll_wait, $_[0]+0, $epoll_wait_events, $_[1]+0, $_[2]+0);
+ for (0..$ct-1) {
+ # 16 byte epoll_event structs, with format:
+ # 4 byte mask [idx 1]
+ # 4 byte padding (we put it into idx 2, useless)
+ # 8 byte data (first 4 bytes are fd, into idx 0)
+ @{$_[3]->[$_]}[1,2,0] = unpack("LLL", substr($epoll_wait_events, 16*$_, 12));
+ }
+ return $ct;
+}
+
+
+1;
+__END__
+
+=head1 NAME
+
+Sys::Syscall - access system calls that Perl doesn't normally provide access to
+
+=head1 SYNOPSIS
+
+ use Sys::Syscall;
+
+=head1 DESCRIPTION
+
+Use epoll, sendfile, from Perl. Mostly Linux-only support now, but
+more syscalls/OSes planned for future.
+
+=head1 Exports
+
+Nothing by default.
+
+May export: sendfile epoll_ctl epoll_create epoll_wait EPOLLIN EPOLLOUT EPOLLERR EPOLLHUP EPOLL_CTL_ADD EPOLL_CTL_DEL EPOLL_CTL_MOD
+
+Export tags: :epoll and :sendfile
+
+=head1 Functions
+
+=head2 epoll support
+
+=over 4
+
+=item $ok = epoll_defined()
+
+Returns true if epoll might be available. (caller must still test with epoll_create)
+
+=item $epfd = epoll_create([ $start_size ])
+
+Create a new epoll filedescriptor. Returns -1 if epoll isn't available.
+
+=item $rv = epoll_ctl($epfd, $op, $fd, $events)
+
+See manpage for epoll_ctl
+
+=item $count = epoll_wait($epfd, $max_events, $timeout, $arrayref)
+
+See manpage for epoll_wait. $arrayref is an arrayref to be modified
+with the items returned. The values put into $arrayref are arrayrefs
+of [$fd, $state].
+
+=back
+
+=head2 sendfile support
+
+=over 4
+
+=item $ok = sendfile_defined()
+
+Returns true if sendfile should work on this operating system.
+
+=item $sent = sendfile($sock_fd, $file_fd, $max_send)
+
+Sends up to $max_send bytes from $file_fd to $sock_fd. Returns bytes
+actually sent, or -1 on error.
+
+=back
+
+=head1 COPYRIGHT
+
+This module is Copyright (c) 2005, 2006 Six Apart, Ltd.
+
+All rights reserved.
+
+You may distribute under the terms of either the GNU General Public
+License or the Artistic License, as specified in the Perl README file.
+If you need more liberal licensing terms, please contact the
+maintainer.
+
+=head1 WARRANTY
+
+This is free software. IT COMES WITHOUT WARRANTY OF ANY KIND.
+
+=head1 AUTHORS
+
+Brad Fitzpatrick <brad at danga.com>
+
Added: packages/libsys-syscall-perl/branches/upstream/current/t/00-use.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libsys-syscall-perl/branches/upstream/current/t/00-use.t?rev=4587&op=file
==============================================================================
--- packages/libsys-syscall-perl/branches/upstream/current/t/00-use.t (added)
+++ packages/libsys-syscall-perl/branches/upstream/current/t/00-use.t Wed Dec 6 10:19:28 2006
@@ -1,0 +1,4 @@
+use Test::More tests => 1;
+use Sys::Syscall;
+
+ok(1);
Added: packages/libsys-syscall-perl/branches/upstream/current/t/01-epoll.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libsys-syscall-perl/branches/upstream/current/t/01-epoll.t?rev=4587&op=file
==============================================================================
--- packages/libsys-syscall-perl/branches/upstream/current/t/01-epoll.t (added)
+++ packages/libsys-syscall-perl/branches/upstream/current/t/01-epoll.t Wed Dec 6 10:19:28 2006
@@ -1,0 +1,90 @@
+use strict;
+use Sys::Syscall ':epoll';
+use Test::More;
+use POSIX;
+use IO::Socket::INET;
+use Socket qw(PF_INET IPPROTO_TCP SOCK_STREAM);
+
+my ($sysname, $nodename, $release, $version, $machine) = POSIX::uname();
+
+if ($^O ne 'linux' || $release =~ /^2\.[01234]\b/) {
+ non_linux_26();
+}
+
+plan tests => 20;
+ok(Sys::Syscall::epoll_defined(), "have epoll");
+
+my $epfd = epoll_create();
+ok($epfd >= 0, "did epoll_create");
+
+ok(EPOLLHUP && EPOLLIN && EPOLLOUT && EPOLLERR, "epoll masks");
+ok(EPOLL_CTL_ADD && EPOLL_CTL_DEL && EPOLL_CTL_MOD, "epoll_ctl constants");
+
+my $udp_sock = IO::Socket::INET->new(PeerPort => 9999,
+ PeerAddr => inet_ntoa(INADDR_BROADCAST),
+ Proto => 'udp',
+ LocalAddr => '127.0.0.1',
+ Broadcast => 1 )
+ or die "Can't bind : $@\n";
+
+my $tempfd = fileno($udp_sock);
+
+is(epoll_ctl($epfd, EPOLL_CTL_ADD, $tempfd, EPOLLOUT), 0, "epoll_ctl udp socket EPOLLOUT");
+
+my $events = [];
+is(epoll_wait($epfd, 1, 500, $events), 1, "epoll_wait");
+my $ev = $events->[0];
+ok(ref $ev eq "ARRAY", "got an array in our event");
+$ev ||= [];
+is($ev->[0], $tempfd, "event is stdout");
+is($ev->[1], EPOLLOUT, "udp socket is writable");
+
+is(epoll_ctl($epfd, EPOLL_CTL_MOD, $tempfd, EPOLLIN), 0, "watch reads on udp socket");
+my ($t1, $t2);
+$t1 = time();
+is(epoll_wait($epfd, 1, 1000, $events), 0, "get no events");
+$t2 = time();
+ok($t2 > $t1 && $t2 < ($t1 + 3), "took a second");
+
+my $port = 60000;
+my $ip = '127.0.0.1';
+my $listen = IO::Socket::INET->new(Listen => 5,
+ LocalAddr => $ip,
+ ReuseAddr => 1,
+ LocalPort => $port,
+ Proto => 'tcp');
+my $listen2 = IO::Socket::INET->new(Listen => 5,
+ LocalAddr => $ip,
+ ReuseAddr => 1,
+ LocalPort => $port+1,
+ Proto => 'tcp');
+ok($listen, "made temp listening socket");
+ok(fileno($listen), "has fileno");
+
+my ($sock, $sock2);
+socket $sock, PF_INET, SOCK_STREAM, IPPROTO_TCP;
+socket $sock2, PF_INET, SOCK_STREAM, IPPROTO_TCP;
+IO::Handle::blocking($sock, 0);
+IO::Handle::blocking($sock2, 0);
+connect $sock, Socket::sockaddr_in($port, Socket::inet_aton($ip));
+connect $sock2, Socket::sockaddr_in($port+1, Socket::inet_aton($ip));
+select undef, undef, undef, 0.25;
+
+my $lifd1 = fileno($listen);
+my $lifd2 = fileno($listen2);
+
+$epfd = epoll_create();
+is(epoll_ctl($epfd, EPOLL_CTL_ADD, fileno($listen), EPOLLIN), 0, "epoll_ctl listen socket writable") or diag "reason: $!";
+is(epoll_ctl($epfd, EPOLL_CTL_ADD, fileno($listen2), EPOLLIN), 0, "epoll_ctl listen2 socket writable") or diag "reason: $!";
+is(epoll_wait($epfd, 2, 500, $events), 2, "epoll_wait") or diag("Got $events->[0][0] (listen=$lifd1, listen2=$lifd2)");
+ok(($events->[0][0] == fileno($listen) && $events->[1][0] == fileno($listen2)) ||
+ ($events->[1][0] == fileno($listen) && $events->[0][0] == fileno($listen2)), "got both");
+
+is(epoll_ctl($epfd, EPOLL_CTL_DEL, fileno($listen), 0), 0, "epoll_ctl del stdout");
+ok(epoll_ctl($epfd, EPOLL_CTL_MOD, 9999, 0), "epoll_ctl on bad fd");
+
+sub non_linux_26 {
+ plan skip_all => "test good only for Linux 2.6+";
+ exit 0;
+}
+
Added: packages/libsys-syscall-perl/branches/upstream/current/t/02-sendfile.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libsys-syscall-perl/branches/upstream/current/t/02-sendfile.t?rev=4587&op=file
==============================================================================
--- packages/libsys-syscall-perl/branches/upstream/current/t/02-sendfile.t (added)
+++ packages/libsys-syscall-perl/branches/upstream/current/t/02-sendfile.t Wed Dec 6 10:19:28 2006
@@ -1,0 +1,94 @@
+#!/usr/bin/perl
+
+use strict;
+use Test::More;
+use Sys::Syscall qw(:sendfile);
+use IO::Socket::INET;
+use File::Temp qw(tempdir);
+
+if (Sys::Syscall::sendfile_defined()) {
+ plan tests => 2;
+} else {
+ plan skip_all => "sendfile not defined";
+ exit 0;
+}
+
+my $ip = "127.0.0.1";
+my $port = 60001;
+my $child;
+
+my $content = "I am a test file!\n" x (5 * 1024);
+my $clen = length($content);
+
+END {
+ kill 9, $child if $child;
+}
+
+# make child to listen and receive
+if ($child = fork()) { parent(); }
+else { child(); }
+
+exit 0;
+
+sub parent {
+ my $sock;
+ my $tries = 0;
+ while (! $sock && $tries++ < 5) {
+ $sock = IO::Socket::INET->new(PeerAddr => "$ip:$port");
+ last if $sock;
+ select undef, undef, undef, 0.25;
+ }
+ die "no socket" unless $sock;
+
+ my $dir = tempdir(CLEANUP => 1) or die "couldn't make tempdir";
+ my $tfile = "$dir/test";
+ open (F, ">$tfile") or die "couldn't write to test file in $dir: $!";
+ print F $content;
+ close F;
+ is(-s $tfile, $clen, "right size test file");
+ open (F, $tfile);
+ my $remain = $clen;
+ while ($remain) {
+ my $rv = sendfile(fileno($sock), fileno(F), 1234);
+ die "got rv = $rv from sendfile" unless $rv > 0;
+ $remain -= $rv;
+ die "remain dropped below zero" if $remain < 0;
+ }
+ close F;
+
+ my $line = <$sock>;
+ like($line, qr/^OK/, "child got all data") or diag "Child said: $line";
+}
+
+sub child {
+ my $listen = IO::Socket::INET->new(Listen => 5,
+ LocalAddr => $ip,
+ LocalPort => $port,
+ ReuseAddr => 1,
+ Proto => 'tcp')
+ or die "couldn't start listening";
+ while (my $sock = $listen->accept) {
+ my $ok = sub {
+ my $send = "OK\n";
+ syswrite($sock, $send);
+ exit 0;
+ };
+ my $bad = sub {
+ my $send = "BAD\n";
+ syswrite($sock, $send);
+ exit 0;
+ };
+
+ my $got;
+ my $gotlen;
+ while (<$sock>) {
+ $got .= $_;
+ $gotlen += length($_);
+ if ($gotlen == $clen) {
+ $ok->() if $got eq $content;
+ $bad->();
+ }
+ }
+ $bad->();
+ }
+}
More information about the Pkg-perl-cvs-commits
mailing list