Revert "t/porting/checkcase.t should skip directories"

[perl5.git] / doio.c

diff --git a/doio.c b/doio.c
index b0c5a69..a430361 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -149,7 +149,8 @@ Perl_do_openn(pTHX_ GV *gv, register const char *oname, I32 len, int as_raw,
        int ismodifying;
 
        if (num_svs != 0) {
-            Perl_croak(aTHX_ "panic: sysopen with multiple args");
+           Perl_croak(aTHX_ "panic: sysopen with multiple args, num_svs=%ld",
+                      (long) num_svs);
        }
        /* It's not always
 
@@ -1218,26 +1219,31 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp)
        U8 *tmpbuf = NULL;
        bool happy = TRUE;
 
-       if (PerlIO_isutf8(fp)) {
-           if (!SvUTF8(sv)) {
+       if (PerlIO_isutf8(fp)) { /* If the stream is utf8 ... */
+           if (!SvUTF8(sv)) {  /* Convert to utf8 if necessary */
                /* We don't modify the original scalar.  */
                tmpbuf = bytes_to_utf8((const U8*) tmps, &len);
                tmps = (char *) tmpbuf;
            }
-           else if (ckWARN_d(WARN_UTF8)) {
+           else if (ckWARN4_d(WARN_UTF8, WARN_SURROGATE, WARN_NON_UNICODE, WARN_NONCHAR)) {
                (void) check_utf8_print((const U8*) tmps, len);
            }
-       }
-       else if (DO_UTF8(sv)) {
+       } /* else stream isn't utf8 */
+       else if (DO_UTF8(sv)) { /* But if is utf8 internally, attempt to
+                                  convert to bytes */
            STRLEN tmplen = len;
            bool utf8 = TRUE;
            U8 * const result = bytes_from_utf8((const U8*) tmps, &tmplen, &utf8);
            if (!utf8) {
+
+               /* Here, succeeded in downgrading from utf8.  Set up to below
+                * output the converted value */
                tmpbuf = result;
                tmps = (char *) tmpbuf;
                len = tmplen;
            }
-           else {
+           else {  /* Non-utf8 output stream, but string only representable in
+                      utf8 */
                assert((char *)result == tmps);
                Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
                                 "Wide character in %s",
@@ -1270,7 +1276,6 @@ Perl_my_stat_flags(pTHX_ const U32 flags)
     GV* gv;
 
     if (PL_op->op_flags & OPf_REF) {
-       EXTEND(SP,1);
        gv = cGVOP_gv;
       do_fstat:
         if (gv == PL_defgv)
@@ -1291,14 +1296,13 @@ Perl_my_stat_flags(pTHX_ const U32 flags)
        report_evil_fh(gv);
        return -1;
     }
-    else if (PL_op->op_private & OPpFT_STACKED) {
+    else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
+            == OPpFT_STACKED)
        return PL_laststatval;
-    }
     else {
-       SV* const sv = POPs;
+       SV* const sv = TOPs;
        const char *s;
        STRLEN len;
-       PUTBACK;
        if ((gv = MAYBE_DEREF_GV_flags(sv,flags))) {
            goto do_fstat;
        }
@@ -1327,23 +1331,23 @@ Perl_my_lstat_flags(pTHX_ const U32 flags)
     dVAR;
     static const char no_prev_lstat[] = "The stat preceding -l _ wasn't an lstat";
     dSP;
-    SV *sv;
     const char *file;
     if (PL_op->op_flags & OPf_REF) {
-       EXTEND(SP,1);
        if (cGVOP_gv == PL_defgv) {
            if (PL_laststype != OP_LSTAT)
                Perl_croak(aTHX_ no_prev_lstat);
            return PL_laststatval;
        }
+       PL_laststatval = -1;
        if (ckWARN(WARN_IO)) {
            Perl_warner(aTHX_ packWARN(WARN_IO),
                             "Use of -l on filehandle %"HEKf,
                              HEKfARG(GvENAME_HEK(cGVOP_gv)));
        }
-       return (PL_laststatval = -1);
+       return -1;
     }
-    else if (PL_op->op_private & OPpFT_STACKED) {
+    if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
+            == OPpFT_STACKED) {
       if (PL_laststype != OP_LSTAT)
        Perl_croak(aTHX_ no_prev_lstat);
       return PL_laststatval;
@@ -1351,9 +1355,7 @@ Perl_my_lstat_flags(pTHX_ const U32 flags)
 
     PL_laststype = OP_LSTAT;
     PL_statgv = NULL;
-    sv = POPs;
-    PUTBACK;
-    file = SvPV_flags_const_nolen(sv, flags);
+    file = SvPV_flags_const_nolen(TOPs, flags);
     sv_setpv(PL_statname,file);
     PL_laststatval = PerlLIO_lstat(file,&PL_statcache);
     if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(file, '\n'))
@@ -1560,6 +1562,10 @@ Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report)
 
 #endif /* OS2 || WIN32 */
 
+#ifdef VMS
+#include <starlet.h> /* for sys$delprc */
+#endif
+
 I32
 Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp)
 {
@@ -1696,7 +1702,6 @@ nothing in the core.
        /* kill() doesn't do process groups (job trees?) under VMS */
        if (val < 0) val = -val;
        if (val == SIGKILL) {
-#          include <starlet.h>
            /* Use native sys$delprc() to insure that target process is
             * deleted; supervisor-mode images don't pay attention to
             * CRTL's emulation of Unix-style signals and kill()
@@ -1766,7 +1771,7 @@ nothing in the core.
        while (++mark <= sp) {
            s = SvPV_nolen_const(*mark);
            APPLY_TAINT_PROPER();
-           if (PL_euid || PL_unsafe) {
+           if (PerlProc_geteuid() || PL_unsafe) {
                if (UNLINK(s))
                    tot--;
            }
@@ -1904,7 +1909,7 @@ Perl_cando(pTHX_ Mode_t mode, bool effective, register const Stat_t *statbufp)
 # ifdef __CYGWIN__
     if (ingroup(544,effective)) {     /* member of Administrators */
 # else
-    if ((effective ? PL_euid : PL_uid) == 0) { /* root is special */
+    if ((effective ? PerlProc_geteuid() : PerlProc_getuid()) == 0) {   /* root is special */
 # endif
        if (mode == S_IXUSR) {
            if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
@@ -1914,7 +1919,7 @@ Perl_cando(pTHX_ Mode_t mode, bool effective, register const Stat_t *statbufp)
            return TRUE;                /* root reads and writes anything */
        return FALSE;
     }
-    if (statbufp->st_uid == (effective ? PL_euid : PL_uid) ) {
+    if (statbufp->st_uid == (effective ? PerlProc_geteuid() : PerlProc_getuid()) ) {
        if (statbufp->st_mode & mode)
            return TRUE;        /* ok as "user" */
     }
@@ -1933,7 +1938,7 @@ static bool
 S_ingroup(pTHX_ Gid_t testgid, bool effective)
 {
     dVAR;
-    if (testgid == (effective ? PL_egid : PL_gid))
+    if (testgid == (effective ? PerlProc_getegid() : PerlProc_getgid()))
        return TRUE;
 #ifdef HAS_GETGROUPS
     {