Tweak corelist.pl's heuristics to cope with the renamed directoriess in ext/

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

diff --git a/pp_sys.c b/pp_sys.c
index 0d2c970..0179323 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -29,7 +29,7 @@
 #include "EXTERN.h"
 #define PERL_IN_PP_SYS_C
 #include "perl.h"
-#ifndef PERL_MICRO
+#if !defined(PERL_MICRO) && defined(Quad_t)
 #  include "time64.h"
 #  include "time64.c"
 #endif
@@ -804,11 +804,6 @@ PP(pp_tie)
            break;
        case SVt_PVGV:
            if (isGV_with_GP(varsv)) {
-#ifdef GV_UNIQUE_CHECK
-               if (GvUNIQUE((const GV *)varsv)) {
-                   Perl_croak(aTHX_ "Attempt to tie unique GV");
-               }
-#endif
                methname = "TIEHANDLE";
                how = PERL_MAGIC_tiedscalar;
                /* For tied filehandles, we apply tiedscalar magic to the IO
@@ -1818,9 +1813,8 @@ PP(pp_send)
            SV *sv;
 
            if (MARK == SP - 1) {
-               EXTEND(SP, 1000);
-               sv = sv_2mortal(newSViv(sv_len(*SP)));
-               PUSHs(sv);
+               sv = *SP;
+               mXPUSHi(sv_len(sv));
                PUTBACK;
            }
 
@@ -2984,8 +2978,19 @@ PP(pp_ftrread)
     int stat_mode = S_IRUSR;
 
     bool effective = FALSE;
+    char opchar = '?';
     dSP;
 
+    switch (PL_op->op_type) {
+    case OP_FTRREAD:   opchar = 'R'; break;
+    case OP_FTRWRITE:  opchar = 'W'; break;
+    case OP_FTREXEC:   opchar = 'X'; break;
+    case OP_FTEREAD:   opchar = 'r'; break;
+    case OP_FTEWRITE:  opchar = 'w'; break;
+    case OP_FTEEXEC:   opchar = 'x'; break;
+    }
+    tryAMAGICftest(opchar);
+
     STACKED_FTEST_CHECK;
 
     switch (PL_op->op_type) {
@@ -3018,7 +3023,7 @@ PP(pp_ftrread)
        access_mode = W_OK;
 #endif
        stat_mode = S_IWUSR;
-       /* Fall through  */
+       /* fall through */
 
     case OP_FTEREAD:
 #ifndef PERL_EFF_ACCESS
@@ -3078,8 +3083,20 @@ PP(pp_ftis)
     dVAR;
     I32 result;
     const int op_type = PL_op->op_type;
+    char opchar = '?';
     dSP;
+
+    switch (op_type) {
+    case OP_FTIS:      opchar = 'e'; break;
+    case OP_FTSIZE:    opchar = 's'; break;
+    case OP_FTMTIME:   opchar = 'M'; break;
+    case OP_FTCTIME:   opchar = 'C'; break;
+    case OP_FTATIME:   opchar = 'A'; break;
+    }
+    tryAMAGICftest(opchar);
+
     STACKED_FTEST_CHECK;
+
     result = my_stat();
     SPAGAIN;
     if (result < 0)
@@ -3116,8 +3133,25 @@ PP(pp_ftrowned)
 {
     dVAR;
     I32 result;
+    char opchar = '?';
     dSP;
 
+    switch (PL_op->op_type) {
+    case OP_FTROWNED:  opchar = 'O'; break;
+    case OP_FTEOWNED:  opchar = 'o'; break;
+    case OP_FTZERO:    opchar = 'z'; break;
+    case OP_FTSOCK:    opchar = 'S'; break;
+    case OP_FTCHR:     opchar = 'c'; break;
+    case OP_FTBLK:     opchar = 'b'; break;
+    case OP_FTFILE:    opchar = 'f'; break;
+    case OP_FTDIR:     opchar = 'd'; break;
+    case OP_FTPIPE:    opchar = 'p'; break;
+    case OP_FTSUID:    opchar = 'u'; break;
+    case OP_FTSGID:    opchar = 'g'; break;
+    case OP_FTSVTX:    opchar = 'k'; break;
+    }
+    tryAMAGICftest(opchar);
+
     /* I believe that all these three are likely to be defined on most every
        system these days.  */
 #ifndef S_ISUID
@@ -3134,6 +3168,7 @@ PP(pp_ftrowned)
 #endif
 
     STACKED_FTEST_CHECK;
+
     result = my_stat();
     SPAGAIN;
     if (result < 0)
@@ -3200,8 +3235,13 @@ PP(pp_ftrowned)
 PP(pp_ftlink)
 {
     dVAR;
-    I32 result = my_lstat();
     dSP;
+    I32 result;
+
+    tryAMAGICftest('l');
+    result = my_lstat();
+    SPAGAIN;
+
     if (result < 0)
        RETPUSHUNDEF;
     if (S_ISLNK(PL_statcache.st_mode))
@@ -3217,6 +3257,8 @@ PP(pp_fttty)
     GV *gv;
     SV *tmpsv = NULL;
 
+    tryAMAGICftest('t');
+
     STACKED_FTEST_CHECK;
 
     if (PL_op->op_flags & OPf_REF)
@@ -3266,6 +3308,8 @@ PP(pp_fttext)
     GV *gv;
     PerlIO *fp;
 
+    tryAMAGICftest(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
+
     STACKED_FTEST_CHECK;
 
     if (PL_op->op_flags & OPf_REF)
@@ -4425,7 +4469,7 @@ PP(pp_gmtime)
 {
     dVAR;
     dSP;
-#ifdef PERL_MICRO
+#if defined(PERL_MICRO) || !defined(Quad_t)
     Time_t when;
     const struct tm *err;
     struct tm tmbuf;
@@ -4441,7 +4485,7 @@ PP(pp_gmtime)
        {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
         "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
 
-#ifdef PERL_MICRO
+#if defined(PERL_MICRO) || !defined(Quad_t)
     if (MAXARG < 1)
        (void)time(&when);
     else
@@ -4465,21 +4509,21 @@ PP(pp_gmtime)
           using a double causes an unfortunate loss of accuracy on high numbers.
           What we really need is an SvQV.
        */
-       double input = POPn;
+       double input = Perl_floor(POPn);
        when = (Time64_T)input;
-       if( when != input ) {
+       if (when != input && ckWARN(WARN_OVERFLOW)) {
            Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
                        "%s(%.0f) too large", opname, input);
        }
     }
 
     if (PL_op->op_type == OP_LOCALTIME)
-        err = localtime64_r(&when, &tmbuf);
+        err = S_localtime64_r(&when, &tmbuf);
     else
-       err = gmtime64_r(&when, &tmbuf);
+       err = S_gmtime64_r(&when, &tmbuf);
 #endif
 
-    if( err == NULL ) {
+    if (err == NULL && ckWARN(WARN_OVERFLOW)) {
        /* XXX %lld broken for quads */
        Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
                    "%s(%.0f) failed", opname, (double)when);
@@ -5329,7 +5373,11 @@ PP(pp_ggrent)
        PUSHs(sv);
        if (grent) {
            if (which == OP_GGRNAM)
+#if Gid_t_sign <= 0
                sv_setiv(sv, (IV)grent->gr_gid);
+#else
+               sv_setuv(sv, (UV)grent->gr_gid);
+#endif
            else
                sv_setpv(sv, grent->gr_name);
        }
@@ -5345,7 +5393,11 @@ PP(pp_ggrent)
        PUSHs(sv_mortalcopy(&PL_sv_no));
 #endif
 
+#if Gid_t_sign <= 0
        mPUSHi(grent->gr_gid);
+#else
+       mPUSHu(grent->gr_gid);
+#endif
 
 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
        /* In UNICOS/mk (_CRAYMPP) the multithreading