Re: Why *not* use UNIVERSAL qw( isa can ) ; ??

[p5sagit/p5-mst-13.2.git] / doio.c

diff --git a/doio.c b/doio.c
index e8ee679..98ff640 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 > 0);
-
-       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;
@@ -214,9 +176,13 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
        type = savepvn(name, len);
        tend = type+len;
        SAVEFREEPV(type);
-       /* Loose trailing white space */
-       while (tend > type && isSPACE(tend[-1]))
-           *tend-- = '\0';
+
+        /* Lose leading and trailing white space */
+        /*SUPPRESS 530*/
+        for (; isSPACE(*type); type++) ;
+        while (tend > type && isSPACE(tend[-1]))
+           *--tend = '\0';
+
        if (num_svs) {
            /* New style explict name, type is just mode and discipline/layer info */
            STRLEN l = 0;
@@ -224,8 +190,6 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
            len = (I32)l;
            name = savepvn(name, len);
            SAVEFREEPV(name);
-           /*SUPPRESS 530*/
-           for (; isSPACE(*type); type++) ;
        }
        else {
            name = type;
@@ -533,6 +497,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
            (void)PerlIO_close(fp);
            goto say_false;
        }
+#ifndef PERL_MICRO
        if (S_ISSOCK(PL_statbuf.st_mode))
            IoTYPE(io) = IoTYPE_SOCKET; /* in case a socket was passed in to us */
 #ifdef HAS_SOCKET
@@ -553,6 +518,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
                IoTYPE(io) = IoTYPE_SOCKET; /* some OS's return 0 on fstat()ed socket */
                                /* but some return 0 for streams too, sigh */
        }
+#endif /* !PERL_MICRO */
 #endif
     }
     if (saveifp) {             /* must use old fp? */
@@ -1222,7 +1188,9 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp)
                sv_utf8_upgrade(sv = sv_mortalcopy(sv));
        }
        else if (DO_UTF8(sv)) {
-           if (!sv_utf8_downgrade((sv = sv_mortalcopy(sv)), TRUE)) {
+           if (!sv_utf8_downgrade((sv = sv_mortalcopy(sv)), TRUE)
+               && ckWARN(WARN_UTF8))
+           {
                Perl_warner(aTHX_ WARN_UTF8, "Wide character in print");
            }
        }
@@ -1691,7 +1659,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 */
@@ -2193,6 +2161,8 @@ Perl_start_glob (pTHX_ SV *tmpglob, IO *io)
                ok = ((wilddsc.dsc$a_pointer = tovmspath(SvPVX(tmpglob),vmsspec)) != NULL);
            else ok = ((wilddsc.dsc$a_pointer = tovmsspec(SvPVX(tmpglob),vmsspec)) != NULL);
            if (ok) wilddsc.dsc$w_length = (unsigned short int) strlen(wilddsc.dsc$a_pointer);
+           for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
+               if (*cp == '?') *cp = '%';  /* VMS style single-char wildcard */
            while (ok && ((sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
                                               &dfltdsc,NULL,NULL,NULL))&1)) {
                end = rstr + (unsigned long int) *rslt;