Extract doio.c's open(2) mode to string conversion as PerlIO_intmod2str()

Use for non-PERLIO fdupopen().

p4raw-id: //depot/perlio@12532

diff --git a/doio.c b/doio.c
index ebcd071..462c884 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -158,45 +158,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
        rawmode |= O_LARGEFILE; /* Transparently largefiley. */
 #endif
 
-#ifndef O_ACCMODE
-#define O_ACCMODE 3            /* Assume traditional implementation */
-#endif
-
-       switch (result = rawmode & O_ACCMODE) {
-       case O_RDONLY:
-            IoTYPE(io) = IoTYPE_RDONLY;
-            break;
-       case O_WRONLY:
-            IoTYPE(io) = IoTYPE_WRONLY;
-            break;
-       case O_RDWR:
-       default:
-            IoTYPE(io) = IoTYPE_RDWR;
-            break;
-       }
-       writing = (result != O_RDONLY);
-
-       if (result == O_RDONLY) {
-           mode[ix++] = 'r';
-       }
-#ifdef O_APPEND
-       else if (rawmode & O_APPEND) {
-           mode[ix++] = 'a';
-           if (result != O_WRONLY)
-               mode[ix++] = '+';
-       }
-#endif
-       else {
-           if (result == O_WRONLY)
-               mode[ix++] = 'w';
-           else {
-               mode[ix++] = 'r';
-               mode[ix++] = '+';
-           }
-       }
-       if (rawmode & O_BINARY)
-           mode[ix++] = 'b';
-       mode[ix] = '\0';
+        IoTYPE(io) = PerlIO_intmode2str(rawmode, &mode[ix], &writing);
 
        namesv = sv_2mortal(newSVpvn(name,strlen(name)));
        num_svs = 1;
@@ -1693,7 +1655,7 @@ nothing in the core.
 
            if ( accessed == &PL_sv_undef && modified == &PL_sv_undef )
              utbufp = NULL;
-           
+
            Zero(&utbuf, sizeof utbuf, char);
 #ifdef BIG_TIME
            utbuf.actime = (Time_t)SvNVx(accessed);     /* time accessed */

diff --git a/lib/Net/Domain.pm b/lib/Net/Domain.pm
index 229bc16..03c24da 100644 (file)
--- a/lib/Net/Domain.pm
+++ b/lib/Net/Domain.pm
@@ -36,8 +36,8 @@ sub _hostname {
           my $a = shift(@addr);
           $host = gethostbyaddr($a,Socket::AF_INET());
           last if defined $host;
-         } 
-        if (index($host,'.') > 0) {
+         }
+        if (defined($host) && index($host,'.') > 0) {
            $fqdn = $host;
            ($host,$domain) = $fqdn =~ /^([^\.]+)\.(.*)$/;
          }
@@ -102,7 +102,7 @@ sub _hostname {
        };
     }
 
-    # remove garbage 
+    # remove garbage
     $host =~ s/[\0\r\n]+//go;
     $host =~ s/(\A\.+|\.+\Z)//go;
     $host =~ s/\.\.+/\./go;
@@ -147,7 +147,7 @@ sub _hostdomain {
 
     @hosts = ($host,"localhost");
 
-    unless($host =~ /\./) {
+    unless (defined($host) && $host =~ /\./) {
        my $dom = undef;
         eval {
            my $tmp = "\0" x 256; ## preload scalar
@@ -179,19 +179,19 @@ sub _hostdomain {
 
     # Attempt to locate FQDN
 
-    foreach (@hosts) {
+    foreach (grep {defined $_} @hosts) {
        my @info = gethostbyname($_);
 
        next unless @info;
 
        # look at real name & aliases
        my $site;
-       foreach $site ($info[0], split(/ /,$info[1])) { 
+       foreach $site ($info[0], split(/ /,$info[1])) {
            if(rindex($site,".") > 0) {
 
                # Extract domain from FQDN
 
-               ($domain = $site) =~ s/\A[^\.]+\.//; 
+               ($domain = $site) =~ s/\A[^\.]+\.//;
                return $domain;
            }
        }

diff --git a/perlio.c b/perlio.c
index 963601a..96ecdd8 100644 (file)
--- a/perlio.c
+++ b/perlio.c
@@ -99,6 +99,55 @@ perlsio_binmode(FILE *fp, int iotype, int mode)
 #endif
 }
 
+#ifndef O_ACCMODE
+#define O_ACCMODE 3            /* Assume traditional implementation */
+#endif
+
+int
+PerlIO_intmode2str(int rawmode, char *mode, int *writing)
+{
+    int result = rawmode & O_ACCMODE;
+    int ix = 0;
+    int ptype;
+    switch (result) {
+    case O_RDONLY:
+       ptype = IoTYPE_RDONLY;
+       break;
+    case O_WRONLY:
+       ptype = IoTYPE_WRONLY;
+       break;
+    case O_RDWR:
+    default:
+       ptype = IoTYPE_RDWR;
+       break;
+    }
+    if (writing)
+       *writing = (result != O_RDONLY);
+
+    if (result == O_RDONLY) {
+       mode[ix++] = 'r';
+    }
+#ifdef O_APPEND
+    else if (rawmode & O_APPEND) {
+       mode[ix++] = 'a';
+       if (result != O_WRONLY)
+           mode[ix++] = '+';
+    }
+#endif
+    else {
+       if (result == O_WRONLY)
+           mode[ix++] = 'w';
+       else {
+           mode[ix++] = 'r';
+           mode[ix++] = '+';
+       }
+    }
+    if (rawmode & O_BINARY)
+       mode[ix++] = 'b';
+    mode[ix] = '\0';
+    return ptype;
+}
+
 #ifndef PERLIO_LAYERS
 int
 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
@@ -134,8 +183,11 @@ PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param)
     if (f) {
        int fd = PerlLIO_dup(PerlIO_fileno(f));
        if (fd >= 0) {
+           char mode[8];
+           int omode = fcntl(fd, F_GETFL);
+           PerlIO_intmode2str(omode,mode,NULL);
            /* the r+ is a hack */
-           return PerlIO_fdopen(fd, "r+");
+           return PerlIO_fdopen(fd, mode);
        }
        return NULL;
     }

diff --git a/perlio.h b/perlio.h
index 1921a52..c5a25f3 100644 (file)
--- a/perlio.h
+++ b/perlio.h
@@ -346,6 +346,8 @@ extern char *PerlIO_getname(PerlIO *, char *);
 
 extern void PerlIO_destruct(pTHX);
 
+extern int PerlIO_intmode2str(int rawmode, char *mode, int *writing);
+
 #ifndef PERLIO_IS_STDIO
 
 extern void PerlIO_cleanup(void);