This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Sync with libnet-1.13
[perl5.git] / doio.c
diff --git a/doio.c b/doio.c
index 20f6fb3..5ac3104 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -1,6 +1,6 @@
 /*    doio.c
  *
- *    Copyright (c) 1991-2002, Larry Wall
+ *    Copyright (c) 1991-2003, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -218,7 +218,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
                if (ckWARN(WARN_IO))
                    Perl_warner(aTHX_ packWARN(WARN_IO),
                            "Can't open a reference");
-               SETERRNO(EINVAL, LIB$_INVARG);
+               SETERRNO(EINVAL, LIB_INVARG);
                goto say_false;
            }
 #endif /* USE_STDIO */
@@ -323,12 +323,13 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
                    if (num_svs > 1) {
                        Perl_croak(aTHX_ "More than one argument to '%c&' open",IoTYPE(io));
                    }
+                   /*SUPPRESS 530*/
+                   for (; isSPACE(*type); type++) ;
                    if (num_svs && (SvIOK(*svp) || (SvPOK(*svp) && looks_like_number(*svp)))) {
                        fd = SvUV(*svp);
+                       num_svs = 0;
                    }
                    else if (isDIGIT(*type)) {
-                       /*SUPPRESS 530*/
-                       for (; isSPACE(*type); type++) ;
                        fd = atoi(type);
                    }
                    else {
@@ -338,14 +339,12 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
                        }
                        else {
                            GV *thatgv;
-                           /*SUPPRESS 530*/
-                           for (; isSPACE(*type); type++) ;
                            thatgv = gv_fetchpv(type,FALSE,SVt_PVIO);
                            thatio = GvIO(thatgv);
                        }
                        if (!thatio) {
 #ifdef EINVAL
-                           SETERRNO(EINVAL,SS$_IVCHAN);
+                           SETERRNO(EINVAL,SS_IVCHAN);
 #endif
                            goto say_false;
                        }
@@ -536,18 +535,20 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
        if ((IoTYPE(io) == IoTYPE_RDONLY) &&
            (fp == PerlIO_stdout() || fp == PerlIO_stderr())) {
                Perl_warner(aTHX_ packWARN(WARN_IO),
-                           "Filehandle STD%s opened only for input",
-                           (fp == PerlIO_stdout()) ? "OUT" : "ERR");
+                           "Filehandle STD%s reopened as %s only for input",
+                           ((fp == PerlIO_stdout()) ? "OUT" : "ERR"),
+                           GvENAME(gv));
        }
        else if ((IoTYPE(io) == IoTYPE_WRONLY) && fp == PerlIO_stdin()) {
                Perl_warner(aTHX_ packWARN(WARN_IO),
-                           "Filehandle STDIN opened only for output");
+                           "Filehandle STDIN reopened as %s only for output",
+                           GvENAME(gv));
        }
     }
 
     fd = PerlIO_fileno(fp);
-    /* If there is no fd (e.g. PerlIO::Scalar) assume it isn't a
-     * socket - this covers PerlIO::Scalar - otherwise unless we "know" the
+    /* If there is no fd (e.g. PerlIO::scalar) assume it isn't a
+     * socket - this covers PerlIO::scalar - otherwise unless we "know" the
      * type probe for socket-ness.
      */
     if (IoTYPE(io) && IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD && fd >= 0) {
@@ -596,7 +597,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
            }
        }
        if (savefd != fd) {
-           /* Still a small can-of-worms here if (say) PerlIO::Scalar
+           /* Still a small can-of-worms here if (say) PerlIO::scalar
               is assigned to (say) STDOUT - for now let dup2() fail
               and provide the error
             */
@@ -667,7 +668,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
            if (*s == 'I' || *s == '#')
             s++;
            *s = 'w';
-           if (!(IoOFP(io) = PerlIO_openn(aTHX_ type,mode,fd,0,0,NULL,0,svp))) {
+           if (!(IoOFP(io) = PerlIO_openn(aTHX_ type,s,fd,0,0,NULL,0,svp))) {
                PerlIO_close(fp);
                IoIFP(io) = Nullfp;
                goto say_false;
@@ -772,8 +773,8 @@ Perl_nextargv(pTHX_ register GV *gv)
                    {
                        if (ckWARN_d(WARN_INPLACE))     
                            Perl_warner(aTHX_ packWARN(WARN_INPLACE),
-                             "Can't do inplace edit: %s would not be unique",
-                             SvPVX(sv));
+                             "Can't do inplace edit: %"SVf" would not be unique",
+                             sv);
                        do_close(gv,FALSE);
                        continue;
                    }
@@ -783,8 +784,8 @@ Perl_nextargv(pTHX_ register GV *gv)
                    if (PerlLIO_rename(PL_oldname,SvPVX(sv)) < 0) {
                        if (ckWARN_d(WARN_INPLACE))     
                            Perl_warner(aTHX_ packWARN(WARN_INPLACE),
-                             "Can't rename %s to %s: %s, skipping file",
-                             PL_oldname, SvPVX(sv), Strerror(errno) );
+                             "Can't rename %s to %"SVf": %s, skipping file",
+                             PL_oldname, sv, Strerror(errno) );
                        do_close(gv,FALSE);
                        continue;
                    }
@@ -799,8 +800,8 @@ Perl_nextargv(pTHX_ register GV *gv)
                    if (link(PL_oldname,SvPVX(sv)) < 0) {
                        if (ckWARN_d(WARN_INPLACE))     
                            Perl_warner(aTHX_ packWARN(WARN_INPLACE),
-                             "Can't rename %s to %s: %s, skipping file",
-                             PL_oldname, SvPVX(sv), Strerror(errno) );
+                             "Can't rename %s to %"SVf": %s, skipping file",
+                             PL_oldname, sv, Strerror(errno) );
                        do_close(gv,FALSE);
                        continue;
                    }
@@ -920,8 +921,8 @@ Perl_do_pipe(pTHX_ SV *sv, GV *rgv, GV *wgv)
 
     if (PerlProc_pipe(fd) < 0)
        goto badexit;
-    IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
-    IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
+    IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPESOCK_MODE);
+    IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPESOCK_MODE);
     IoOFP(rstio) = IoIFP(rstio);
     IoIFP(wstio) = IoOFP(wstio);
     IoTYPE(rstio) = IoTYPE_RDONLY;
@@ -954,7 +955,7 @@ Perl_do_close(pTHX_ GV *gv, bool not_implicit)
        gv = PL_argvgv;
     if (!gv || SvTYPE(gv) != SVt_PVGV) {
        if (not_implicit)
-           SETERRNO(EBADF,SS$_IVCHAN);
+           SETERRNO(EBADF,SS_IVCHAN);
        return FALSE;
     }
     io = GvIO(gv);
@@ -962,7 +963,7 @@ Perl_do_close(pTHX_ GV *gv, bool not_implicit)
        if (not_implicit) {
            if (ckWARN(WARN_UNOPENED)) /* no check for closed here */
                report_evil_fh(gv, io, PL_op->op_type);
-           SETERRNO(EBADF,SS$_IVCHAN);
+           SETERRNO(EBADF,SS_IVCHAN);
        }
        return FALSE;
     }
@@ -1006,7 +1007,7 @@ Perl_io_close(pTHX_ IO *io, bool not_implicit)
        IoOFP(io) = IoIFP(io) = Nullfp;
     }
     else if (not_implicit) {
-       SETERRNO(EBADF,SS$_IVCHAN);
+       SETERRNO(EBADF,SS_IVCHAN);
     }
 
     return retval;
@@ -1067,7 +1068,7 @@ Perl_do_tell(pTHX_ GV *gv)
     }
     if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
        report_evil_fh(gv, io, PL_op->op_type);
-    SETERRNO(EBADF,RMS$_IFI);
+    SETERRNO(EBADF,RMS_IFI);
     return (Off_t)-1;
 }
 
@@ -1086,7 +1087,7 @@ Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence)
     }
     if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
        report_evil_fh(gv, io, PL_op->op_type);
-    SETERRNO(EBADF,RMS$_IFI);
+    SETERRNO(EBADF,RMS_IFI);
     return FALSE;
 }
 
@@ -1100,7 +1101,7 @@ Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence)
        return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence);
     if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
        report_evil_fh(gv, io, PL_op->op_type);
-    SETERRNO(EBADF,RMS$_IFI);
+    SETERRNO(EBADF,RMS_IFI);
     return (Off_t)-1;
 }
 
@@ -1265,7 +1266,8 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp)
     default:
        if (PerlIO_isutf8(fp)) {
            if (!SvUTF8(sv))
-               sv_utf8_upgrade(sv = sv_mortalcopy(sv));
+               sv_utf8_upgrade_flags(sv = sv_mortalcopy(sv),
+                                     SV_GMAGIC|SV_UTF8_NO_ENCODING);
        }
        else if (DO_UTF8(sv)) {
            if (!sv_utf8_downgrade((sv = sv_mortalcopy(sv)), TRUE)
@@ -1742,22 +1744,23 @@ nothing in the core.
            SV* modified = *++mark;
            void * utbufp = &utbuf;
 
-           /* be like C, and if both times are undefined, let the C
-              library figure out what to do.  This usually means
-              "current time" */
+           /* Be like C, and if both times are undefined, let the C
+            * library figure out what to do.  This usually means
+            * "current time". */
 
            if ( accessed == &PL_sv_undef && modified == &PL_sv_undef )
-             utbufp = NULL;
-
-           Zero(&utbuf, sizeof utbuf, char);
+                utbufp = NULL;
+           else {
+                Zero(&utbuf, sizeof utbuf, char);
 #ifdef BIG_TIME
-           utbuf.actime = (Time_t)SvNVx(accessed);     /* time accessed */
-           utbuf.modtime = (Time_t)SvNVx(modified);    /* time modified */
+                utbuf.actime = (Time_t)SvNVx(accessed);  /* time accessed */
+                utbuf.modtime = (Time_t)SvNVx(modified); /* time modified */
 #else
-           utbuf.actime = (Time_t)SvIVx(accessed);     /* time accessed */
-           utbuf.modtime = (Time_t)SvIVx(modified);    /* time modified */
+                utbuf.actime = (Time_t)SvIVx(accessed);  /* time accessed */
+                utbuf.modtime = (Time_t)SvIVx(modified); /* time modified */
 #endif
-           APPLY_TAINT_PROPER();
+            }
+            APPLY_TAINT_PROPER();
            tot = sp - mark;
            while (++mark <= sp) {
                char *name = SvPVx(*mark, n_a);
@@ -2089,7 +2092,7 @@ Perl_do_semop(pTHX_ SV **mark, SV **sp)
     opbuf = SvPV(opstr, opsize);
     if (opsize < 3 * SHORTSIZE
        || (opsize % (3 * SHORTSIZE))) {
-       SETERRNO(EINVAL,LIB$_INVARG);
+       SETERRNO(EINVAL,LIB_INVARG);
        return -1;
     }
     SETERRNO(0,0);
@@ -2146,7 +2149,7 @@ Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp)
     if (shmctl(id, IPC_STAT, &shmds) == -1)
        return -1;
     if (mpos < 0 || msize < 0 || mpos + msize > shmds.shm_segsz) {
-       SETERRNO(EFAULT,SS$_ACCVIO);            /* can't do as caller requested */
+       SETERRNO(EFAULT,SS_ACCVIO);             /* can't do as caller requested */
        return -1;
     }
     shm = (char *)shmat(id, (char*)NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0);
@@ -2273,7 +2276,7 @@ Perl_start_glob (pTHX_ SV *tmpglob, IO *io)
            }
            if (cxt) (void)lib$find_file_end(&cxt);
            if (ok && sts != RMS$_NMF &&
-               sts != RMS$_DNF && sts != RMS$_FNF) ok = 0;
+               sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
            if (!ok) {
                if (!(sts & 1)) {
                    SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
Unnamed repository; edit this file 'description' to name the repository.