This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
add my_[l]stat_flags(); make my_[l]stat() mathoms
authorDavid Mitchell <davem@iabyn.com>
Sat, 3 Jul 2010 13:24:11 +0000 (14:24 +0100)
committerDavid Mitchell <davem@iabyn.com>
Sat, 3 Jul 2010 15:25:59 +0000 (16:25 +0100)
my_stat() and my_lstat() call get magic on the stack arg, so create _flags()
variants that allow us to control this. (I can't just change the signature
or the mg_get() behaviour since my_[l]stat() are listed as being in the
public API, even though they're undocumented.)

doio.c
embed.fnc
embed.h
global.sym
mathoms.c
perl.h
pp_sys.c
proto.h

diff --git a/doio.c b/doio.c
index 06f2d3d..5f57b38 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -1258,7 +1258,7 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp)
 }
 
 I32
-Perl_my_stat(pTHX)
+Perl_my_stat_flags(pTHX_ const U32 flags)
 {
     dVAR;
     dSP;
@@ -1314,7 +1314,7 @@ Perl_my_stat(pTHX)
             goto do_fstat_have_io;
         }
 
-       s = SvPV_const(sv, len);
+       s = SvPV_flags_const(sv, len, flags);
        PL_statgv = NULL;
        sv_setpvn(PL_statname, s, len);
        s = SvPVX_const(PL_statname);           /* s now NUL-terminated */
@@ -1328,7 +1328,7 @@ Perl_my_stat(pTHX)
 
 
 I32
-Perl_my_lstat(pTHX)
+Perl_my_lstat_flags(pTHX_ const U32 flags)
 {
     dVAR;
     static const char no_prev_lstat[] = "The stat preceding -l _ wasn't an lstat";
@@ -1361,7 +1361,7 @@ Perl_my_lstat(pTHX)
                GvENAME((const GV *)SvRV(sv)));
        return (PL_laststatval = -1);
     }
-    file = SvPV_nolen_const(sv);
+    file = SvPV_flags_const_nolen(sv, flags);
     sv_setpv(PL_statname,file);
     PL_laststatval = PerlLIO_lstat(file,&PL_statcache);
     if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(file, '\n'))
index 81427fd..0992216 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -738,7 +738,8 @@ Ap  |I32    |my_fflush_all
 Anp    |Pid_t  |my_fork
 Anp    |void   |atfork_lock
 Anp    |void   |atfork_unlock
-Ap     |I32    |my_lstat
+Apmb   |I32    |my_lstat
+pX     |I32    |my_lstat_flags |NULLOK const U32 flags
 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
 AnpP   |I32    |my_memcmp      |NN const char* s1|NN const char* s2|I32 len
 #endif
@@ -749,7 +750,8 @@ Ap  |I32    |my_pclose      |NULLOK PerlIO* ptr
 Ap     |PerlIO*|my_popen       |NN const char* cmd|NN const char* mode
 Ap     |PerlIO*|my_popen_list  |NN const char* mode|int n|NN SV ** args
 Ap     |void   |my_setenv      |NULLOK const char* nam|NULLOK const char* val
-Ap     |I32    |my_stat
+Apmb   |I32    |my_stat
+pX     |I32    |my_stat_flags  |NULLOK const U32 flags
 Ap     |char * |my_strftime    |NN const char *fmt|int sec|int min|int hour|int mday|int mon|int year|int wday|int yday|int isdst
 #if defined(MYSWAP)
 ApPa   |short  |my_swap        |short s
diff --git a/embed.h b/embed.h
index 56ac2cf..82b83e2 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define my_fork                        Perl_my_fork
 #define atfork_lock            Perl_atfork_lock
 #define atfork_unlock          Perl_atfork_unlock
-#define my_lstat               Perl_my_lstat
+#ifdef PERL_CORE
+#define my_lstat_flags         Perl_my_lstat_flags
+#endif
 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
 #define my_memcmp              Perl_my_memcmp
 #endif
 #define my_popen               Perl_my_popen
 #define my_popen_list          Perl_my_popen_list
 #define my_setenv              Perl_my_setenv
-#define my_stat                        Perl_my_stat
+#ifdef PERL_CORE
+#define my_stat_flags          Perl_my_stat_flags
+#endif
 #define my_strftime            Perl_my_strftime
 #if defined(MYSWAP)
 #define my_swap                        Perl_my_swap
 #define my_fork                        Perl_my_fork
 #define atfork_lock            Perl_atfork_lock
 #define atfork_unlock          Perl_atfork_unlock
-#define my_lstat()             Perl_my_lstat(aTHX)
+#ifdef PERL_CORE
+#define my_lstat_flags(a)      Perl_my_lstat_flags(aTHX_ a)
+#endif
 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
 #define my_memcmp              Perl_my_memcmp
 #endif
 #define my_popen(a,b)          Perl_my_popen(aTHX_ a,b)
 #define my_popen_list(a,b,c)   Perl_my_popen_list(aTHX_ a,b,c)
 #define my_setenv(a,b)         Perl_my_setenv(aTHX_ a,b)
-#define my_stat()              Perl_my_stat(aTHX)
+#ifdef PERL_CORE
+#define my_stat_flags(a)       Perl_my_stat_flags(aTHX_ a)
+#endif
 #define my_strftime(a,b,c,d,e,f,g,h,i,j)       Perl_my_strftime(aTHX_ a,b,c,d,e,f,g,h,i,j)
 #if defined(MYSWAP)
 #define my_swap(a)             Perl_my_swap(aTHX_ a)
index 30d89f7..f7fb28d 100644 (file)
@@ -314,6 +314,7 @@ Perl_my_fork
 Perl_atfork_lock
 Perl_atfork_unlock
 Perl_my_lstat
+Perl_my_lstat_flags
 Perl_my_memcmp
 Perl_my_memset
 Perl_my_pclose
@@ -321,6 +322,7 @@ Perl_my_popen
 Perl_my_popen_list
 Perl_my_setenv
 Perl_my_stat
+Perl_my_stat_flags
 Perl_my_strftime
 Perl_my_swap
 Perl_my_htonl
index 058d76d..1bb33d3 100644 (file)
--- a/mathoms.c
+++ b/mathoms.c
@@ -78,6 +78,8 @@ PERL_CALLCONV int Perl_magic_setglob(pTHX_ SV* sv, MAGIC* mg);
 PERL_CALLCONV AV * Perl_newAV(pTHX);
 PERL_CALLCONV HV * Perl_newHV(pTHX);
 PERL_CALLCONV IO * Perl_newIO(pTHX);
+PERL_CALLCONV I32 Perl_my_stat(pTHX);
+PERL_CALLCONV I32 Perl_my_lstat(pTHX);
 
 /* ref() is now a macro using Perl_doref;
  * this version provided for binary compatibility only.
@@ -1519,6 +1521,18 @@ Perl_newIO(pTHX)
     return MUTABLE_IO(newSV_type(SVt_PVIO));
 }
 
+I32
+Perl_my_stat(pTHX)
+{
+    return my_stat_flags(SV_GMAGIC);
+}
+
+I32
+Perl_my_lstat(pTHX)
+{
+    return my_lstat_flags(SV_GMAGIC);
+}
+
 #endif /* NO_MATHOMS */
 
 /*
diff --git a/perl.h b/perl.h
index b551f4b..3d60a33 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -3425,6 +3425,10 @@ struct nexttoken {
 #include "warnings.h"
 #include "utf8.h"
 
+/* these would be in doio.h if there was such a file */
+#define my_stat()  my_stat_flags(SV_GMAGIC)
+#define my_lstat() my_lstat_flags(SV_GMAGIC)
+
 /* defined in sv.c, but also used in [ach]v.c */
 #undef _XPV_HEAD
 #undef _XPVMG_HEAD
index d0b0423..8af9799 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -3133,7 +3133,7 @@ PP(pp_ftrread)
 #endif
     }
 
-    result = my_stat();
+    result = my_stat_flags(SV_GMAGIC);
     SPAGAIN;
     if (result < 0)
        RETPUSHUNDEF;
@@ -3161,7 +3161,7 @@ PP(pp_ftis)
 
     STACKED_FTEST_CHECK;
 
-    result = my_stat();
+    result = my_stat_flags(SV_GMAGIC);
     SPAGAIN;
     if (result < 0)
        RETPUSHUNDEF;
@@ -3233,7 +3233,7 @@ PP(pp_ftrowned)
 
     STACKED_FTEST_CHECK;
 
-    result = my_stat();
+    result = my_stat_flags(SV_GMAGIC);
     SPAGAIN;
     if (result < 0)
        RETPUSHUNDEF;
@@ -3303,7 +3303,7 @@ PP(pp_ftlink)
     I32 result;
 
     tryAMAGICftest_MG('l');
-    result = my_lstat();
+    result = my_lstat_flags(SV_GMAGIC);
     SPAGAIN;
 
     if (result < 0)
diff --git a/proto.h b/proto.h
index 03148fa..b1239b8 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -2082,7 +2082,8 @@ PERL_CALLCONV I32 Perl_my_fflush_all(pTHX);
 PERL_CALLCONV Pid_t    Perl_my_fork(void);
 PERL_CALLCONV void     Perl_atfork_lock(void);
 PERL_CALLCONV void     Perl_atfork_unlock(void);
-PERL_CALLCONV I32      Perl_my_lstat(pTHX);
+/* PERL_CALLCONV I32   Perl_my_lstat(pTHX); */
+PERL_CALLCONV I32      Perl_my_lstat_flags(pTHX_ const U32 flags);
 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
 PERL_CALLCONV I32      Perl_my_memcmp(const char* s1, const char* s2, I32 len)
                        __attribute__pure__
@@ -2113,7 +2114,8 @@ PERL_CALLCONV PerlIO*     Perl_my_popen_list(pTHX_ const char* mode, int n, SV ** ar
        assert(mode); assert(args)
 
 PERL_CALLCONV void     Perl_my_setenv(pTHX_ const char* nam, const char* val);
-PERL_CALLCONV I32      Perl_my_stat(pTHX);
+/* PERL_CALLCONV I32   Perl_my_stat(pTHX); */
+PERL_CALLCONV I32      Perl_my_stat_flags(pTHX_ const U32 flags);
 PERL_CALLCONV char *   Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst)
                        __attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_MY_STRFTIME   \