summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--README.mpeix8
-rwxr-xr-xext/IO/t/io_sock.t38
-rw-r--r--mpeix/mpeix.c53
-rw-r--r--mpeix/mpeixish.h2
4 files changed, 71 insertions, 30 deletions
diff --git a/README.mpeix b/README.mpeix
index 8203741d2f..6fc853fc44 100644
--- a/README.mpeix
+++ b/README.mpeix
@@ -11,7 +11,7 @@ README.mpeix - Perl/iX for HP e3000 MPE
http://www.bixby.org/mark/perlix.html
http://jazz.external.hp.com/src/hp_freeware/perl/
Perl language for MPE
- Last updated June 2, 2000 @ 0400 UTC
+ Last updated July 29, 2003 @ 2100 UTC
=head1 NOTE
@@ -433,12 +433,6 @@ a zero.
=item *
-If you use Perl/iX fcntl() against a socket it will fail, because MPE
-requires that you use sfcntl() instead. Perl/iX does not presently
-support sfcntl().
-
-=item *
-
MPE requires GETPRIVMODE() in order to setuid(). There are too many
calls to setuid() within Perl/iX, so I have not attempted an automatic
GETPRIVMODE() solution similar to bind().
diff --git a/ext/IO/t/io_sock.t b/ext/IO/t/io_sock.t
index 52ddae788e..c278850d07 100755
--- a/ext/IO/t/io_sock.t
+++ b/ext/IO/t/io_sock.t
@@ -181,26 +181,22 @@ $server = IO::Socket->new(Domain => AF_INET,
LocalAddr => '127.0.0.1');
$port = $server->sockport;
-if ($^O eq 'mpeix') {
- print("ok 12 # skipped\n")
+if ($pid = fork()) {
+ my $buf;
+ $server->recv($buf, 100);
+ print $buf;
+} elsif (defined($pid)) {
+ #child
+ $sock = IO::Socket::INET->new(Proto => 'udp',
+ PeerAddr => "localhost:$port")
+ || IO::Socket::INET->new(Proto => 'udp',
+ PeerAddr => "127.0.0.1:$port");
+ $sock->send("ok 12\n");
+ sleep(1);
+ $sock->send("ok 12\n"); # send another one to be sure
+ exit;
} else {
- if ($pid = fork()) {
- my $buf;
- $server->recv($buf, 100);
- print $buf;
- } elsif (defined($pid)) {
- #child
- $sock = IO::Socket::INET->new(Proto => 'udp',
- PeerAddr => "localhost:$port")
- || IO::Socket::INET->new(Proto => 'udp',
- PeerAddr => "127.0.0.1:$port");
- $sock->send("ok 12\n");
- sleep(1);
- $sock->send("ok 12\n"); # send another one to be sure
- exit;
- } else {
- die;
- }
+ die;
}
print "not " unless $server->blocking;
@@ -279,9 +275,6 @@ if( $server_pid) {
### TESTS 19,20,21,22
### Try to ping-pong some Unicode.
#
- if ($^O eq 'mpeix') {
- print "ok 19 # skipped: broken on MPE/iX\n";
- } else {
$sock = IO::Socket::INET->new("localhost:$serverport")
|| IO::Socket::INET->new("127.0.0.1:$serverport");
@@ -330,7 +323,6 @@ if( $server_pid) {
print "not ";
}
print "ok 23\n";
- }
### TEST 24
### Stop the server
diff --git a/mpeix/mpeix.c b/mpeix/mpeix.c
index b230c50ac2..4805426a9e 100644
--- a/mpeix/mpeix.c
+++ b/mpeix/mpeix.c
@@ -451,3 +451,56 @@ struct timezone *tpz;
return 0;
} /* gettimeofday() */
+
+/*
+** MPE_FCNTL -- shadow function for fcntl()
+**
+** MPE requires sfcntl() for sockets, and fcntl() for everything
+** else. This shadow routine determines the descriptor type and
+** makes the appropriate call.
+**
+** Parameters:
+** same as fcntl().
+**
+** Returns:
+** same as fcntl().
+*/
+
+#include <stdarg.h>
+#include <sys/socket.h>
+
+int
+mpe_fcntl(int fildes, int cmd, ...)
+{
+ int len, result;
+ struct sockaddr sa;
+
+ void *arg;
+ va_list ap;
+
+ va_start(ap, cmd);
+ arg = va_arg(ap, void *);
+ va_end(ap);
+
+ len = sizeof sa;
+ if (getsockname(fildes, &sa, &len) == -1)
+ {
+ if (errno == EAFNOSUPPORT)
+ /* AF_UNIX socket */
+ return sfcntl(fildes, cmd, arg);
+
+ if (errno == ENOTSOCK)
+ /* file or pipe */
+ return fcntl(fildes, cmd, arg);
+
+ /* unknown getsockname() failure */
+ return (-1);
+ }
+ else
+ {
+ /* AF_INET socket */
+ if ((result = sfcntl(fildes, cmd, arg)) != -1 && cmd == F_GETFL)
+ result |= O_RDWR; /* fill in some missing flags */
+ return result;
+ }
+}
diff --git a/mpeix/mpeixish.h b/mpeix/mpeixish.h
index 8fc055a9a1..658e72ef87 100644
--- a/mpeix/mpeixish.h
+++ b/mpeix/mpeixish.h
@@ -153,3 +153,5 @@ extern void srand48(long int seedval);
extern int ftruncate(int fd, long wantsize);
extern int gettimeofday( struct timeval *tp, struct timezone *tpz );
extern int truncate(const char *pathname, off_t length);
+
+#define fcntl mpe_fcntl