Band-aid to handle long API symbol on VMS.

[perl5.git] / pp_sys.c

diff --git a/pp_sys.c b/pp_sys.c
index 94ac3a4..ed4ec13 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -487,8 +487,7 @@ PP(pp_die)
     else {
        exsv = newSVpvs_flags("Died", SVs_TEMP);
     }
-    die_sv(exsv);
-    RETURN;
+    return die_sv(exsv);
 }
 
 /* I/O. */
@@ -506,7 +505,7 @@ PP(pp_open)
 
     GV * const gv = MUTABLE_GV(*++MARK);
 
-    if (!isGV(gv))
+    if (!isGV(gv) && !(SvTYPE(gv) == SVt_PVLV && isGV_with_GP(gv)))
        DIE(aTHX_ PL_no_usym, "filehandle");
 
     if ((io = GvIOp(gv))) {
@@ -552,26 +551,30 @@ PP(pp_open)
     RETURN;
 }
 
-/* This is private to this function, which is private to this file.
+/* These are private to this function, which is private to this file.
    Use 0x04 rather than the next available bit, to help the compiler if the
    architecture can generate more efficient instructions.  */
 #define MORTALIZE_NOT_NEEDED   0x04
+#define TIED_HANDLE_ARGC_SHIFT 3
 
 static OP *
 S_tied_handle_method(pTHX_ const char *const methname, SV **sp,
-                    IO *const io, MAGIC *const mg, const U32 flags,
-                    unsigned int argc, ...)
+                    IO *const io, MAGIC *const mg, const U32 flags, ...)
 {
+    U32 argc = flags >> TIED_HANDLE_ARGC_SHIFT;
+
     PERL_ARGS_ASSERT_TIED_HANDLE_METHOD;
 
+    /* Ensure that our flag bits do not overlap.  */
     assert((MORTALIZE_NOT_NEEDED & G_WANT) == 0);
+    assert((G_WANT >> TIED_HANDLE_ARGC_SHIFT) == 0);
 
     PUSHMARK(sp);
     PUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
     if (argc) {
        const U32 mortalize_not_needed = flags & MORTALIZE_NOT_NEEDED;
        va_list args;
-       va_start(args, argc);
+       va_start(args, flags);
        do {
            SV *const arg = va_arg(args, SV *);
            if(mortalize_not_needed)
@@ -590,11 +593,11 @@ S_tied_handle_method(pTHX_ const char *const methname, SV **sp,
 }
 
 #define tied_handle_method(a,b,c,d)            \
-    S_tied_handle_method(aTHX_ a,b,c,d,G_SCALAR,0)
+    S_tied_handle_method(aTHX_ a,b,c,d,G_SCALAR)
 #define tied_handle_method1(a,b,c,d,e) \
-    S_tied_handle_method(aTHX_ a,b,c,d,G_SCALAR,1,e)
+    S_tied_handle_method(aTHX_ a,b,c,d,G_SCALAR | (1 << TIED_HANDLE_ARGC_SHIFT),e)
 #define tied_handle_method2(a,b,c,d,e,f)       \
-    S_tied_handle_method(aTHX_ a,b,c,d,G_SCALAR,2,e,f)
+    S_tied_handle_method(aTHX_ a,b,c,d,G_SCALAR | (2 << TIED_HANDLE_ARGC_SHIFT), e,f)
 
 PP(pp_close)
 {
@@ -673,7 +676,6 @@ badexit:
     RETPUSHUNDEF;
 #else
     DIE(aTHX_ PL_no_func, "pipe");
-    return NORMAL;
 #endif
 }
 
@@ -763,8 +765,10 @@ PP(pp_binmode)
               figure out. Although, as it's a static function, in theory it
               could.  */
            return S_tied_handle_method(aTHX_ "BINMODE", SP, io, mg,
-                                       G_SCALAR|MORTALIZE_NOT_NEEDED,
-                                       discp ? 1 : 0, discp);
+                                       G_SCALAR|MORTALIZE_NOT_NEEDED
+                                       | (discp
+                                          ? (1 << TIED_HANDLE_ARGC_SHIFT) : 0),
+                                       discp);
        }
     }
 
@@ -821,6 +825,7 @@ PP(pp_tie)
            methname = "TIEARRAY";
            break;
        case SVt_PVGV:
+       case SVt_PVLV:
            if (isGV_with_GP(varsv)) {
                methname = "TIEHANDLE";
                how = PERL_MAGIC_tiedscalar;
@@ -849,8 +854,10 @@ PP(pp_tie)
        call_method(methname, G_SCALAR);
     }
     else {
-       /* Not clear why we don't call call_method here too.
-        * perhaps to get different error message ?
+       /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO"
+        * will attempt to invoke IO::File::TIEARRAY, with (best case) the
+        * wrong error message, and worse case, supreme action at a distance.
+        * (Sorry obfuscation writers. You're not going to be given this one.)
         */
        STRLEN len;
        const char *name = SvPV_nomg_const(*MARK, len);
@@ -1037,7 +1044,7 @@ PP(pp_sselect)
            if (SvIsCOW(sv))
                sv_force_normal_flags(sv, 0);
            if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
-               DIE(aTHX_ "%s", PL_no_modify);
+               Perl_croak_no_modify(aTHX);
        }
        if (!SvPOK(sv)) {
            Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
@@ -1160,7 +1167,6 @@ PP(pp_sselect)
     RETURN;
 #else
     DIE(aTHX_ "select not implemented");
-    return NORMAL;
 #endif
 }
 
@@ -1229,7 +1235,7 @@ PP(pp_getc)
        MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
        if (mg) {
            const U32 gimme = GIMME_V;
-           S_tied_handle_method(aTHX_ "GETC", SP, io, mg, gimme, 0);
+           S_tied_handle_method(aTHX_ "GETC", SP, io, mg, gimme);
            if (gimme == G_SCALAR) {
                SPAGAIN;
                SvSetMagicSV_nosteal(TARG, TOPs);
@@ -1270,6 +1276,9 @@ S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
 
     PERL_ARGS_ASSERT_DOFORM;
 
+    if (cv && CvCLONE(cv))
+       cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
+
     ENTER;
     SAVETMPS;
 
@@ -1325,9 +1334,6 @@ PP(pp_enterwrite)
        not_a_format_reference:
        DIE(aTHX_ "Not a format reference");
     }
-    if (CvCLONE(cv))
-       cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
-
     IoFLAGS(io) &= ~IOf_DIDTOP;
     return doform(cv,gv,PL_op->op_next);
 }
@@ -1416,8 +1422,6 @@ PP(pp_leavewrite)
            else
                DIE(aTHX_ "Undefined top format called");
        }
-       if (cv && CvCLONE(cv))
-           cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
        return doform(cv, gv, PL_op);
     }
 
@@ -2370,7 +2374,6 @@ PP(pp_flock)
     RETURN;
 #else
     DIE(aTHX_ PL_no_func, "flock()");
-    return NORMAL;
 #endif
 }
 
@@ -2423,7 +2426,6 @@ PP(pp_socket)
     RETPUSHYES;
 #else
     DIE(aTHX_ PL_no_sock_func, "socket");
-    return NORMAL;
 #endif
 }
 
@@ -2485,7 +2487,6 @@ PP(pp_sockpair)
     RETPUSHYES;
 #else
     DIE(aTHX_ PL_no_sock_func, "socketpair");
-    return NORMAL;
 #endif
 }
 
@@ -2517,7 +2518,6 @@ nuts:
     RETPUSHUNDEF;
 #else
     DIE(aTHX_ PL_no_sock_func, "bind");
-    return NORMAL;
 #endif
 }
 
@@ -2548,7 +2548,6 @@ nuts:
     RETPUSHUNDEF;
 #else
     DIE(aTHX_ PL_no_sock_func, "connect");
-    return NORMAL;
 #endif
 }
 
@@ -2575,7 +2574,6 @@ nuts:
     RETPUSHUNDEF;
 #else
     DIE(aTHX_ PL_no_sock_func, "listen");
-    return NORMAL;
 #endif
 }
 
@@ -2655,7 +2653,6 @@ badexit:
 
 #else
     DIE(aTHX_ PL_no_sock_func, "accept");
-    return NORMAL;
 #endif
 }
 
@@ -2680,7 +2677,6 @@ nuts:
     RETPUSHUNDEF;
 #else
     DIE(aTHX_ PL_no_sock_func, "shutdown");
-    return NORMAL;
 #endif
 }
 
@@ -2758,7 +2754,6 @@ nuts2:
 
 #else
     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
-    return NORMAL;
 #endif
 }
 
@@ -2823,7 +2818,6 @@ nuts2:
 
 #else
     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
-    return NORMAL;
 #endif
 }
 
@@ -3138,7 +3132,7 @@ PP(pp_ftrread)
 #endif
     }
 
-    result = my_stat();
+    result = my_stat_flags(0);
     SPAGAIN;
     if (result < 0)
        RETPUSHUNDEF;
@@ -3166,7 +3160,7 @@ PP(pp_ftis)
 
     STACKED_FTEST_CHECK;
 
-    result = my_stat();
+    result = my_stat_flags(0);
     SPAGAIN;
     if (result < 0)
        RETPUSHUNDEF;
@@ -3221,24 +3215,33 @@ PP(pp_ftrowned)
     }
     tryAMAGICftest_MG(opchar);
 
+    STACKED_FTEST_CHECK;
+
     /* I believe that all these three are likely to be defined on most every
        system these days.  */
 #ifndef S_ISUID
-    if(PL_op->op_type == OP_FTSUID)
+    if(PL_op->op_type == OP_FTSUID) {
+       if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
+           (void) POPs;
        RETPUSHNO;
+    }
 #endif
 #ifndef S_ISGID
-    if(PL_op->op_type == OP_FTSGID)
+    if(PL_op->op_type == OP_FTSGID) {
+       if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
+           (void) POPs;
        RETPUSHNO;
+    }
 #endif
 #ifndef S_ISVTX
-    if(PL_op->op_type == OP_FTSVTX)
+    if(PL_op->op_type == OP_FTSVTX) {
+       if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
+           (void) POPs;
        RETPUSHNO;
+    }
 #endif
 
-    STACKED_FTEST_CHECK;
-
-    result = my_stat();
+    result = my_stat_flags(0);
     SPAGAIN;
     if (result < 0)
        RETPUSHUNDEF;
@@ -3308,7 +3311,7 @@ PP(pp_ftlink)
     I32 result;
 
     tryAMAGICftest_MG('l');
-    result = my_lstat();
+    result = my_lstat_flags(0);
     SPAGAIN;
 
     if (result < 0)
@@ -3325,6 +3328,8 @@ PP(pp_fttty)
     int fd;
     GV *gv;
     SV *tmpsv = NULL;
+    char *name = NULL;
+    STRLEN namelen;
 
     tryAMAGICftest_MG('t');
 
@@ -3332,19 +3337,21 @@ PP(pp_fttty)
 
     if (PL_op->op_flags & OPf_REF)
        gv = cGVOP_gv;
-    else if (isGV(TOPs))
+    else if (isGV_with_GP(TOPs))
        gv = MUTABLE_GV(POPs);
     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
        gv = MUTABLE_GV(SvRV(POPs));
-    else
-       gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO);
+    else {
+       tmpsv = POPs;
+       name = SvPV_nomg(tmpsv, namelen);
+       gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
+    }
 
     if (GvIO(gv) && IoIFP(GvIOp(gv)))
        fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
     else if (tmpsv && SvOK(tmpsv)) {
-       const char *tmps = SvPV_nolen_const(tmpsv);
-       if (isDIGIT(*tmps))
-           fd = atoi(tmps);
+       if (isDIGIT(*name))
+           fd = atoi(name);
        else 
            RETPUSHUNDEF;
     }
@@ -3383,7 +3390,7 @@ PP(pp_fttext)
 
     if (PL_op->op_flags & OPf_REF)
        gv = cGVOP_gv;
-    else if (isGV(TOPs))
+    else if (isGV_with_GP(TOPs))
        gv = MUTABLE_GV(POPs);
     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
        gv = MUTABLE_GV(SvRV(POPs));
@@ -3445,7 +3452,7 @@ PP(pp_fttext)
       really_filename:
        PL_statgv = NULL;
        PL_laststype = OP_STAT;
-       sv_setpv(PL_statname, SvPV_nolen_const(sv));
+       sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
        if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
            if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
                                               '\n'))
@@ -3625,7 +3632,6 @@ PP(pp_chroot)
     RETURN;
 #else
     DIE(aTHX_ PL_no_func, "chroot");
-    return NORMAL;
 #endif
 }
 
@@ -3700,7 +3706,6 @@ PP(pp_link)
 {
     /* Have neither.  */
     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
-    return NORMAL;
 }
 #endif
 
@@ -3915,7 +3920,6 @@ nope:
     RETPUSHUNDEF;
 #else
     DIE(aTHX_ PL_no_dir_func, "opendir");
-    return NORMAL;
 #endif
 }
 
@@ -3923,7 +3927,6 @@ PP(pp_readdir)
 {
 #if !defined(Direntry_t) || !defined(HAS_READDIR)
     DIE(aTHX_ PL_no_dir_func, "readdir");
-    return NORMAL;
 #else
 #if !defined(I_DIRENT) && !defined(VMS)
     Direntry_t *readdir (DIR *);
@@ -4002,7 +4005,6 @@ nope:
     RETPUSHUNDEF;
 #else
     DIE(aTHX_ PL_no_dir_func, "telldir");
-    return NORMAL;
 #endif
 }
 
@@ -4028,7 +4030,6 @@ nope:
     RETPUSHUNDEF;
 #else
     DIE(aTHX_ PL_no_dir_func, "seekdir");
-    return NORMAL;
 #endif
 }
 
@@ -4052,7 +4053,6 @@ nope:
     RETPUSHUNDEF;
 #else
     DIE(aTHX_ PL_no_dir_func, "rewinddir");
-    return NORMAL;
 #endif
 }
 
@@ -4085,7 +4085,6 @@ nope:
     RETPUSHUNDEF;
 #else
     DIE(aTHX_ PL_no_dir_func, "closedir");
-    return NORMAL;
 #endif
 }
 
@@ -4132,7 +4131,6 @@ PP(pp_fork)
     RETURN;
 #  else
     DIE(aTHX_ PL_no_func, "fork");
-    return NORMAL;
 #  endif
 #endif
 }
@@ -4162,7 +4160,6 @@ PP(pp_wait)
     RETURN;
 #else
     DIE(aTHX_ PL_no_func, "wait");
-    return NORMAL;
 #endif
 }
 
@@ -4193,7 +4190,6 @@ PP(pp_waitpid)
     RETURN;
 #else
     DIE(aTHX_ PL_no_func, "waitpid");
-    return NORMAL;
 #endif
 }
 
@@ -4399,7 +4395,6 @@ PP(pp_getppid)
     RETURN;
 #else
     DIE(aTHX_ PL_no_func, "getppid");
-    return NORMAL;
 #endif
 }
 
@@ -4421,7 +4416,6 @@ PP(pp_getpgrp)
     RETURN;
 #else
     DIE(aTHX_ PL_no_func, "getpgrp()");
-    return NORMAL;
 #endif
 }
 
@@ -4455,21 +4449,25 @@ PP(pp_setpgrp)
     RETURN;
 #else
     DIE(aTHX_ PL_no_func, "setpgrp()");
-    return NORMAL;
 #endif
 }
 
+#ifdef __GLIBC__
+#  define PRIORITY_WHICH_T(which) (__priority_which_t)which
+#else
+#  define PRIORITY_WHICH_T(which) which
+#endif
+
 PP(pp_getpriority)
 {
 #ifdef HAS_GETPRIORITY
     dVAR; dSP; dTARGET;
     const int who = POPi;
     const int which = TOPi;
-    SETi( getpriority(which, who) );
+    SETi( getpriority(PRIORITY_WHICH_T(which), who) );
     RETURN;
 #else
     DIE(aTHX_ PL_no_func, "getpriority()");
-    return NORMAL;
 #endif
 }
 
@@ -4481,14 +4479,15 @@ PP(pp_setpriority)
     const int who = POPi;
     const int which = TOPi;
     TAINT_PROPER("setpriority");
-    SETi( setpriority(which, who, niceval) >= 0 );
+    SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
     RETURN;
 #else
     DIE(aTHX_ PL_no_func, "setpriority()");
-    return NORMAL;
 #endif
 }
 
+#undef PRIORITY_WHICH_T
+
 /* Time calls. */
 
 PP(pp_time)
@@ -4536,7 +4535,6 @@ PP(pp_tms)
     RETURN;
 #   else
     DIE(aTHX_ "times not implemented");
-    return NORMAL;
 #   endif
 #endif /* HAS_TIMES */
 }
@@ -4653,7 +4651,6 @@ PP(pp_alarm)
     RETURN;
 #else
     DIE(aTHX_ PL_no_func, "alarm");
-    return NORMAL;
 #endif
 }
 
@@ -4723,7 +4720,6 @@ PP(pp_semget)
     RETURN;
 #else
     DIE(aTHX_ "System V IPC is not implemented on this machine");
-    return NORMAL;
 #endif
 }
 
@@ -4859,7 +4855,6 @@ PP(pp_ghostent)
     RETURN;
 #else
     DIE(aTHX_ PL_no_sock_func, "gethostent");
-    return NORMAL;
 #endif
 }
 
@@ -4933,7 +4928,6 @@ PP(pp_gnetent)
     RETURN;
 #else
     DIE(aTHX_ PL_no_sock_func, "getnetent");
-    return NORMAL;
 #endif
 }
 
@@ -4994,7 +4988,6 @@ PP(pp_gprotoent)
     RETURN;
 #else
     DIE(aTHX_ PL_no_sock_func, "getprotoent");
-    return NORMAL;
 #endif
 }
 
@@ -5070,7 +5063,6 @@ PP(pp_gservent)
     RETURN;
 #else
     DIE(aTHX_ PL_no_sock_func, "getservent");
-    return NORMAL;
 #endif
 }
 
@@ -5082,7 +5074,6 @@ PP(pp_shostent)
     RETSETYES;
 #else
     DIE(aTHX_ PL_no_sock_func, "sethostent");
-    return NORMAL;
 #endif
 }
 
@@ -5094,7 +5085,6 @@ PP(pp_snetent)
     RETSETYES;
 #else
     DIE(aTHX_ PL_no_sock_func, "setnetent");
-    return NORMAL;
 #endif
 }
 
@@ -5106,7 +5096,6 @@ PP(pp_sprotoent)
     RETSETYES;
 #else
     DIE(aTHX_ PL_no_sock_func, "setprotoent");
-    return NORMAL;
 #endif
 }
 
@@ -5118,7 +5107,6 @@ PP(pp_sservent)
     RETSETYES;
 #else
     DIE(aTHX_ PL_no_sock_func, "setservent");
-    return NORMAL;
 #endif
 }
 
@@ -5131,7 +5119,6 @@ PP(pp_ehostent)
     RETPUSHYES;
 #else
     DIE(aTHX_ PL_no_sock_func, "endhostent");
-    return NORMAL;
 #endif
 }
 
@@ -5144,7 +5131,6 @@ PP(pp_enetent)
     RETPUSHYES;
 #else
     DIE(aTHX_ PL_no_sock_func, "endnetent");
-    return NORMAL;
 #endif
 }
 
@@ -5157,7 +5143,6 @@ PP(pp_eprotoent)
     RETPUSHYES;
 #else
     DIE(aTHX_ PL_no_sock_func, "endprotoent");
-    return NORMAL;
 #endif
 }
 
@@ -5170,7 +5155,6 @@ PP(pp_eservent)
     RETPUSHYES;
 #else
     DIE(aTHX_ PL_no_sock_func, "endservent");
-    return NORMAL;
 #endif
 }
 
@@ -5404,7 +5388,6 @@ PP(pp_gpwent)
     RETURN;
 #else
     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
-    return NORMAL;
 #endif
 }
 
@@ -5416,7 +5399,6 @@ PP(pp_spwent)
     RETPUSHYES;
 #else
     DIE(aTHX_ PL_no_func, "setpwent");
-    return NORMAL;
 #endif
 }
 
@@ -5428,7 +5410,6 @@ PP(pp_epwent)
     RETPUSHYES;
 #else
     DIE(aTHX_ PL_no_func, "endpwent");
-    return NORMAL;
 #endif
 }
 
@@ -5503,7 +5484,6 @@ PP(pp_ggrent)
     RETURN;
 #else
     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
-    return NORMAL;
 #endif
 }
 
@@ -5515,7 +5495,6 @@ PP(pp_sgrent)
     RETPUSHYES;
 #else
     DIE(aTHX_ PL_no_func, "setgrent");
-    return NORMAL;
 #endif
 }
 
@@ -5527,7 +5506,6 @@ PP(pp_egrent)
     RETPUSHYES;
 #else
     DIE(aTHX_ PL_no_func, "endgrent");
-    return NORMAL;
 #endif
 }
 
@@ -5543,7 +5521,6 @@ PP(pp_getlogin)
     RETURN;
 #else
     DIE(aTHX_ PL_no_func, "getlogin");
-    return NORMAL;
 #endif
 }
 
@@ -5642,7 +5619,6 @@ PP(pp_syscall)
     RETURN;
 #else
     DIE(aTHX_ PL_no_func, "syscall");
-    return NORMAL;
 #endif
 }