This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perlapi: Document isALNUMC and variants
[perl5.git] / util.c
diff --git a/util.c b/util.c
index 7276fd9..165d13a 100644 (file)
--- a/util.c
+++ b/util.c
@@ -132,6 +132,7 @@ Perl_safesysmalloc(MEM_SIZE size)
     dTHX;
 #endif
     Malloc_t ptr;
+    dSAVEDERRNO;
 
 #ifdef USE_MDH
     if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size)
@@ -143,6 +144,7 @@ Perl_safesysmalloc(MEM_SIZE size)
        Perl_croak_nocontext("panic: malloc, size=%" UVuf, (UV) size);
 #endif
     if (!size) size = 1;       /* malloc(0) is NASTY on our system */
+    SAVE_ERRNO;
 #ifdef PERL_DEBUG_READONLY_COW
     if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE,
                    MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
@@ -182,6 +184,11 @@ Perl_safesysmalloc(MEM_SIZE size)
        ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
        DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
 
+        /* malloc() can modify errno() even on success, but since someone
+          writing perl code doesn't have any control over when perl calls
+          malloc() we need to hide that.
+       */
+        RESTORE_ERRNO;
     }
     else {
 #ifdef USE_MDH
@@ -223,6 +230,7 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
        ptr = safesysmalloc(size);
     }
     else {
+        dSAVE_ERRNO;
 #ifdef USE_MDH
        where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
         if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size)
@@ -296,6 +304,12 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
            maybe_protect_ro(header->prev);
 #endif
            ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
+
+           /* realloc() can modify errno() even on success, but since someone
+              writing perl code doesn't have any control over when perl calls
+              realloc() we need to hide that.
+           */
+           RESTORE_ERRNO;
        }
 
     /* In particular, must do that fixup above before logging anything via
@@ -577,7 +591,7 @@ Perl_delimcpy_no_escape(char *to, const char *toend, const char *from,
 /*
 =head1 Miscellaneous Functions
 
-=for apidoc Am|char *|ninstr|char * big|char * bigend|char * little|char * little_end
+=for apidoc ninstr
 
 Find the first (leftmost) occurrence of a sequence of bytes within another
 sequence.  This is the Perl version of C<strstr()>, extended to handle
@@ -638,7 +652,7 @@ Perl_ninstr(const char *big, const char *bigend, const char *little, const char
 /*
 =head1 Miscellaneous Functions
 
-=for apidoc Am|char *|rninstr|char * big|char * bigend|char * little|char * little_end
+=for apidoc rninstr
 
 Like C<L</ninstr>>, but instead finds the final (rightmost) occurrence of a
 sequence of bytes within another sequence, returning C<NULL> if there is no
@@ -1273,7 +1287,7 @@ Perl_vform(pTHX_ const char *pat, va_list *args)
 }
 
 /*
-=for apidoc Am|SV *|mess|const char *pat|...
+=for apidoc mess
 
 Take a sprintf-style format pattern and argument list.  These are used to
 generate a string message.  If the message does not end with a newline,
@@ -1354,7 +1368,7 @@ Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop,
 }
 
 /*
-=for apidoc Am|SV *|mess_sv|SV *basemsg|bool consume
+=for apidoc mess_sv
 
 Expands a message, intended for the user, to include an indication of
 the current location in the code, if the message does not already appear
@@ -1458,7 +1472,7 @@ Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
 }
 
 /*
-=for apidoc Am|SV *|vmess|const char *pat|va_list *args
+=for apidoc vmess
 
 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
 argument list, respectively.  These are used to generate a string message.  If
@@ -1570,7 +1584,7 @@ S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
 }
 
 /*
-=for apidoc Am|OP *|die_sv|SV *baseex
+=for apidoc die_sv
 
 Behaves the same as L</croak_sv>, except for the return type.
 It should be used only where the C<OP *> return type is required.
@@ -1592,7 +1606,7 @@ Perl_die_sv(pTHX_ SV *baseex)
 MSVC_DIAG_RESTORE
 
 /*
-=for apidoc Am|OP *|die|const char *pat|...
+=for apidoc die
 
 Behaves the same as L</croak>, except for the return type.
 It should be used only where the C<OP *> return type is required.
@@ -1635,7 +1649,7 @@ Perl_die(pTHX_ const char* pat, ...)
 MSVC_DIAG_RESTORE
 
 /*
-=for apidoc Am|void|croak_sv|SV *baseex
+=for apidoc croak_sv
 
 This is an XS interface to Perl's C<die> function.
 
@@ -1665,7 +1679,7 @@ Perl_croak_sv(pTHX_ SV *baseex)
 }
 
 /*
-=for apidoc Am|void|vcroak|const char *pat|va_list *args
+=for apidoc vcroak
 
 This is an XS interface to Perl's C<die> function.
 
@@ -1698,7 +1712,7 @@ Perl_vcroak(pTHX_ const char* pat, va_list *args)
 }
 
 /*
-=for apidoc Am|void|croak|const char *pat|...
+=for apidoc croak
 
 This is an XS interface to Perl's C<die> function.
 
@@ -1745,7 +1759,7 @@ Perl_croak(pTHX_ const char *pat, ...)
 }
 
 /*
-=for apidoc Am|void|croak_no_modify
+=for apidoc croak_no_modify
 
 Exactly equivalent to C<Perl_croak(aTHX_ "%s", PL_no_modify)>, but generates
 terser object code than using C<Perl_croak>.  Less code used on exception code
@@ -1788,7 +1802,7 @@ Perl_croak_popstack(void)
 }
 
 /*
-=for apidoc Am|void|warn_sv|SV *baseex
+=for apidoc warn_sv
 
 This is an XS interface to Perl's C<warn> function.
 
@@ -1816,7 +1830,7 @@ Perl_warn_sv(pTHX_ SV *baseex)
 }
 
 /*
-=for apidoc Am|void|vwarn|const char *pat|va_list *args
+=for apidoc vwarn
 
 This is an XS interface to Perl's C<warn> function.
 
@@ -1844,7 +1858,7 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args)
 }
 
 /*
-=for apidoc Am|void|warn|const char *pat|...
+=for apidoc warn
 
 This is an XS interface to Perl's C<warn> function.
 
@@ -5698,6 +5712,11 @@ S_my_mkostemp(char *templte, int flags) {
     STRLEN len = strlen(templte);
     int fd;
     int attempts = 0;
+#ifdef VMS
+    int delete_on_close = flags & O_VMS_DELETEONCLOSE;
+
+    flags &= ~O_VMS_DELETEONCLOSE;
+#endif
 
     if (len < 6 ||
         templte[len-1] != 'X' || templte[len-2] != 'X' || templte[len-3] != 'X' ||
@@ -5711,7 +5730,15 @@ S_my_mkostemp(char *templte, int flags) {
         for (i = 1; i <= 6; ++i) {
             templte[len-i] = TEMP_FILE_CH[(int)(Perl_internal_drand48() * TEMP_FILE_CH_COUNT)];
         }
-        fd = PerlLIO_open3(templte, O_RDWR | O_CREAT | O_EXCL | flags, 0600);
+#ifdef VMS
+        if (delete_on_close) {
+            fd = open(templte, O_RDWR | O_CREAT | O_EXCL | flags, 0600, "fop=dlt");
+        }
+        else
+#endif
+        {
+            fd = PerlLIO_open3(templte, O_RDWR | O_CREAT | O_EXCL | flags, 0600);
+        }
     } while (fd == -1 && errno == EEXIST && ++attempts <= 100);
 
     return fd;