perl5db: extract a function.

[perl5.git] / pp_sys.c

diff --git a/pp_sys.c b/pp_sys.c
index 85fa251..938aafe 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -387,7 +387,7 @@ PP(pp_glob)
     ENTER_with_name("glob");
 
 #ifndef VMS
-    if (PL_tainting) {
+    if (TAINTING_get) {
        /*
         * The external globbing program may use things we can't control,
         * so for security reasons we must assume the worst.
@@ -669,8 +669,8 @@ PP(pp_pipe_op)
 #ifdef HAS_PIPE
     dVAR;
     dSP;
-    register IO *rstio;
-    register IO *wstio;
+    IO *rstio;
+    IO *wstio;
     int fd[2];
 
     GV * const wgv = MUTABLE_GV(POPs);
@@ -861,9 +861,16 @@ PP(pp_tie)
 
     switch(SvTYPE(varsv)) {
        case SVt_PVHV:
+       {
+           HE *entry;
            methname = "TIEHASH";
+           if (HvLAZYDEL(varsv) && (entry = HvEITER((HV *)varsv))) {
+               HvLAZYDEL_off(varsv);
+               hv_free_ent((HV *)varsv, entry);
+           }
            HvEITER_set(MUTABLE_HV(varsv), 0);
            break;
+       }
        case SVt_PVAV:
            methname = "TIEARRAY";
            if (!AvREAL(varsv)) {
@@ -1059,10 +1066,10 @@ PP(pp_sselect)
 {
 #ifdef HAS_SELECT
     dVAR; dSP; dTARGET;
-    register I32 i;
-    register I32 j;
-    register char *s;
-    register SV *sv;
+    I32 i;
+    I32 j;
+    char *s;
+    SV *sv;
     NV value;
     I32 maxlen = 0;
     I32 nfound;
@@ -1093,7 +1100,7 @@ PP(pp_sselect)
            if (SvIsCOW(sv))
                sv_force_normal_flags(sv, 0);
            if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
-               Perl_croak_no_modify(aTHX);
+               Perl_croak_no_modify();
        }
        if (!SvPOK(sv)) {
            if (!SvPOKp(sv))
@@ -1322,7 +1329,7 @@ STATIC OP *
 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
 {
     dVAR;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
     const I32 gimme = GIMME_V;
 
     PERL_ARGS_ASSERT_DOFORM;
@@ -1350,8 +1357,8 @@ PP(pp_enterwrite)
 {
     dVAR;
     dSP;
-    register GV *gv;
-    register IO *io;
+    GV *gv;
+    IO *io;
     GV *fgv;
     CV *cv = NULL;
     SV *tmpsv = NULL;
@@ -1390,12 +1397,12 @@ PP(pp_leavewrite)
 {
     dVAR; dSP;
     GV * const gv = cxstack[cxstack_ix].blk_format.gv;
-    register IO * const io = GvIOp(gv);
+    IO * const io = GvIOp(gv);
     PerlIO *ofp;
     PerlIO *fp;
     SV **newsp;
     I32 gimme;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
     OP *retop;
 
     if (!io || !(ofp = IoOFP(io)))
@@ -1453,7 +1460,7 @@ PP(pp_leavewrite)
            }
        }
        if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
-           do_print(PL_formfeed, ofp);
+           do_print(GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV)), ofp);
        IoLINES_LEFT(io) = IoPAGE_LEN(io);
        IoPAGE(io)++;
        PL_formtarget = PL_toptarget;
@@ -1508,12 +1515,14 @@ PP(pp_prtf)
 {
     dVAR; dSP; dMARK; dORIGMARK;
     PerlIO *fp;
-    SV *sv;
 
     GV * const gv
        = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
     IO *const io = GvIO(gv);
 
+    /* Treat empty list as "" */
+    if (MARK == SP) XPUSHs(&PL_sv_no);
+
     if (io) {
        const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
        if (mg) {
@@ -1530,7 +1539,6 @@ PP(pp_prtf)
        }
     }
 
-    sv = newSV(0);
     if (!io) {
        report_evil_fh(gv);
        SETERRNO(EBADF,RMS_IFI);
@@ -1545,6 +1553,7 @@ PP(pp_prtf)
        goto just_say_no;
     }
     else {
+       SV *sv = sv_newmortal();
        do_sprintf(sv, SP - MARK, MARK + 1);
        if (!do_print(sv, fp))
            goto just_say_no;
@@ -1553,13 +1562,11 @@ PP(pp_prtf)
            if (PerlIO_flush(fp) == EOF)
                goto just_say_no;
     }
-    SvREFCNT_dec(sv);
     SP = ORIGMARK;
     PUSHs(&PL_sv_yes);
     RETURN;
 
   just_say_no:
-    SvREFCNT_dec(sv);
     SP = ORIGMARK;
     PUSHs(&PL_sv_undef);
     RETURN;
@@ -1650,12 +1657,7 @@ PP(pp_sysread)
        buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
     }
     if (DO_UTF8(bufsv)) {
-       /* offset adjust in characters not bytes */
-        /* SV's length cache is only safe for non-magical values */
-        if (SvGMAGICAL(bufsv))
-            blen = utf8_length((const U8 *)buffer, (const U8 *)buffer + blen);
-        else
-            blen = sv_len_utf8(bufsv);
+       blen = sv_len_utf8_nomg(bufsv);
     }
 
     charstart = TRUE;
@@ -1667,7 +1669,7 @@ PP(pp_sysread)
     if (PL_op->op_type == OP_RECV) {
        Sock_size_t bufsize;
        char namebuf[MAXPATHLEN];
-#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
+#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
        bufsize = sizeof (struct sockaddr_in);
 #else
        bufsize = sizeof namebuf;
@@ -1936,15 +1938,9 @@ PP(pp_syswrite)
                blen_chars = orig_blen_bytes;
            } else {
                /* The SV really is UTF-8.  */
-               if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
-                   /* Don't call sv_len_utf8 again because it will call magic
-                      or overloading a second time, and we might get back a
-                      different result.  */
-                   blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
-               } else {
-                   /* It's safe, and it may well be cached.  */
-                   blen_chars = sv_len_utf8(bufsv);
-               }
+               /* Don't call sv_len_utf8 on a magical or overloaded
+                  scalar, as we might get back a different result.  */
+               blen_chars = sv_or_pv_len_utf8(bufsv, buffer, blen);
            }
        } else {
            blen_chars = blen;
@@ -2380,7 +2376,7 @@ PP(pp_socket)
     const int type = POPi;
     const int domain = POPi;
     GV * const gv = MUTABLE_GV(POPs);
-    register IO * const io = gv ? GvIOn(gv) : NULL;
+    IO * const io = gv ? GvIOn(gv) : NULL;
     int fd;
 
     if (!io) {
@@ -2428,8 +2424,8 @@ PP(pp_sockpair)
     const int domain = POPi;
     GV * const gv2 = MUTABLE_GV(POPs);
     GV * const gv1 = MUTABLE_GV(POPs);
-    register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
-    register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
+    IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
+    IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
     int fd[2];
 
     if (!io1)
@@ -2483,7 +2479,7 @@ PP(pp_bind)
     /* OK, so on what platform does bind modify addr?  */
     const char *addr;
     GV * const gv = MUTABLE_GV(POPs);
-    register IO * const io = GvIOn(gv);
+    IO * const io = GvIOn(gv);
     STRLEN len;
     const int op_type = PL_op->op_type;
 
@@ -2511,7 +2507,7 @@ PP(pp_listen)
     dVAR; dSP;
     const int backlog = POPi;
     GV * const gv = MUTABLE_GV(POPs);
-    register IO * const io = gv ? GvIOn(gv) : NULL;
+    IO * const io = gv ? GvIOn(gv) : NULL;
 
     if (!io || !IoIFP(io))
        goto nuts;
@@ -2530,10 +2526,10 @@ nuts:
 PP(pp_accept)
 {
     dVAR; dSP; dTARGET;
-    register IO *nstio;
-    register IO *gstio;
+    IO *nstio;
+    IO *gstio;
     char namebuf[MAXPATHLEN];
-#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
+#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
     Sock_size_t len = sizeof (struct sockaddr_in);
 #else
     Sock_size_t len = sizeof namebuf;
@@ -2606,7 +2602,7 @@ PP(pp_shutdown)
     dVAR; dSP; dTARGET;
     const int how = POPi;
     GV * const gv = MUTABLE_GV(POPs);
-    register IO * const io = GvIOn(gv);
+    IO * const io = GvIOn(gv);
 
     if (!io || !IoIFP(io))
        goto nuts;
@@ -2628,7 +2624,7 @@ PP(pp_ssockopt)
     const unsigned int optname = (unsigned int) POPi;
     const unsigned int lvl = (unsigned int) POPi;
     GV * const gv = MUTABLE_GV(POPs);
-    register IO * const io = GvIOn(gv);
+    IO * const io = GvIOn(gv);
     int fd;
     Sock_size_t len;
 
@@ -2697,7 +2693,7 @@ PP(pp_getpeername)
     dVAR; dSP;
     const int optype = PL_op->op_type;
     GV * const gv = MUTABLE_GV(POPs);
-    register IO * const io = GvIOn(gv);
+    IO * const io = GvIOn(gv);
     Sock_size_t len;
     SV *sv;
     int fd;
@@ -3307,9 +3303,9 @@ PP(pp_fttext)
     I32 len;
     I32 odd = 0;
     STDCHAR tbuf[512];
-    register STDCHAR *s;
-    register IO *io;
-    register SV *sv = NULL;
+    STDCHAR *s;
+    IO *io;
+    SV *sv = NULL;
     GV *gv;
     PerlIO *fp;
 
@@ -3820,7 +3816,7 @@ PP(pp_open_dir)
     dVAR; dSP;
     const char * const dirname = POPpconstx;
     GV * const gv = MUTABLE_GV(POPs);
-    register IO * const io = GvIOn(gv);
+    IO * const io = GvIOn(gv);
 
     if (!io)
        goto nope;
@@ -3858,8 +3854,8 @@ PP(pp_readdir)
     SV *sv;
     const I32 gimme = GIMME;
     GV * const gv = MUTABLE_GV(POPs);
-    register const Direntry_t *dp;
-    register IO * const io = GvIOn(gv);
+    const Direntry_t *dp;
+    IO * const io = GvIOn(gv);
 
     if (!io || !IoDIRP(io)) {
        Perl_ck_warner(aTHX_ packWARN(WARN_IO),
@@ -3911,7 +3907,7 @@ PP(pp_telldir)
     long telldir (DIR *);
 # endif
     GV * const gv = MUTABLE_GV(POPs);
-    register IO * const io = GvIOn(gv);
+    IO * const io = GvIOn(gv);
 
     if (!io || !IoDIRP(io)) {
        Perl_ck_warner(aTHX_ packWARN(WARN_IO),
@@ -3937,7 +3933,7 @@ PP(pp_seekdir)
     dVAR; dSP;
     const long along = POPl;
     GV * const gv = MUTABLE_GV(POPs);
-    register IO * const io = GvIOn(gv);
+    IO * const io = GvIOn(gv);
 
     if (!io || !IoDIRP(io)) {
        Perl_ck_warner(aTHX_ packWARN(WARN_IO),
@@ -3962,7 +3958,7 @@ PP(pp_rewinddir)
 #if defined(HAS_REWINDDIR) || defined(rewinddir)
     dVAR; dSP;
     GV * const gv = MUTABLE_GV(POPs);
-    register IO * const io = GvIOn(gv);
+    IO * const io = GvIOn(gv);
 
     if (!io || !IoDIRP(io)) {
        Perl_ck_warner(aTHX_ packWARN(WARN_IO),
@@ -3986,7 +3982,7 @@ PP(pp_closedir)
 #if defined(Direntry_t) && defined(HAS_READDIR)
     dVAR; dSP;
     GV * const gv = MUTABLE_GV(POPs);
-    register IO * const io = GvIOn(gv);
+    IO * const io = GvIOn(gv);
 
     if (!io || !IoDIRP(io)) {
        Perl_ck_warner(aTHX_ packWARN(WARN_IO),
@@ -4047,7 +4043,7 @@ PP(pp_fork)
     }
 #endif
     if (childpid < 0)
-       RETSETUNDEF;
+       RETPUSHUNDEF;
     if (!childpid) {
 #ifdef PERL_USES_PL_PIDSTATUS
        hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
@@ -4064,7 +4060,7 @@ PP(pp_fork)
     PERL_FLUSHALL_FOR_CHILD;
     childpid = PerlProc_fork();
     if (childpid == -1)
-       RETSETUNDEF;
+       RETPUSHUNDEF;
     PUSHi(childpid);
     RETURN;
 #  else
@@ -4142,11 +4138,11 @@ PP(pp_system)
     I32 value;
     int result;
 
-    if (PL_tainting) {
+    if (TAINTING_get) {
        TAINT_ENV();
        while (++MARK <= SP) {
            (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
-           if (PL_tainted)
+           if (TAINT_get)
                break;
        }
        MARK = ORIGMARK;
@@ -4289,11 +4285,11 @@ PP(pp_exec)
     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
     I32 value;
 
-    if (PL_tainting) {
+    if (TAINTING_get) {
        TAINT_ENV();
        while (++MARK <= SP) {
            (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
-           if (PL_tainted)
+           if (TAINT_get)
                break;
        }
        MARK = ORIGMARK;
@@ -4308,25 +4304,13 @@ PP(pp_exec)
 #ifdef VMS
        value = (I32)vms_do_aexec(NULL, MARK, SP);
 #else
-#  ifdef __OPEN_VM
-       {
-          (void ) do_aspawn(NULL, MARK, SP);
-          value = 0;
-       }
-#  else
        value = (I32)do_aexec(NULL, MARK, SP);
-#  endif
 #endif
     else {
 #ifdef VMS
        value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
 #else
-#  ifdef __OPEN_VM
-       (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
-       value = 0;
-#  else
        value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
-#  endif
 #endif
     }
 
@@ -4722,8 +4706,8 @@ PP(pp_ghostent)
 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
     dVAR; dSP;
     I32 which = PL_op->op_type;
-    register char **elem;
-    register SV *sv;
+    char **elem;
+    SV *sv;
 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
     struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
     struct hostent *gethostbyname(Netdb_name_t);
@@ -4812,7 +4796,7 @@ PP(pp_gnetent)
 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
     dVAR; dSP;
     I32 which = PL_op->op_type;
-    register SV *sv;
+    SV *sv;
 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
     struct netent *getnetbyaddr(Netdb_net_t, int);
     struct netent *getnetbyname(Netdb_name_t);
@@ -4885,7 +4869,7 @@ PP(pp_gprotoent)
 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
     dVAR; dSP;
     I32 which = PL_op->op_type;
-    register SV *sv;
+    SV *sv;
 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
     struct protoent *getprotobyname(Netdb_name_t);
     struct protoent *getprotobynumber(int);
@@ -4945,7 +4929,7 @@ PP(pp_gservent)
 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
     dVAR; dSP;
     I32 which = PL_op->op_type;
-    register SV *sv;
+    SV *sv;
 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
     struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
     struct servent *getservbyport(int, Netdb_name_t);
@@ -5122,7 +5106,7 @@ PP(pp_gpwent)
 #ifdef HAS_PASSWD
     dVAR; dSP;
     I32 which = PL_op->op_type;
-    register SV *sv;
+    SV *sv;
     struct passwd *pwent  = NULL;
     /*
      * We currently support only the SysV getsp* shadow password interface.
@@ -5446,12 +5430,12 @@ PP(pp_syscall)
 {
 #ifdef HAS_SYSCALL
     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
-    register I32 items = SP - MARK;
+    I32 items = SP - MARK;
     unsigned long a[20];
-    register I32 i = 0;
+    I32 i = 0;
     IV retval = -1;
 
-    if (PL_tainting) {
+    if (TAINTING_get) {
        while (++MARK <= SP) {
            if (SvTAINTED(*MARK)) {
                TAINT;