#define PERL_IN_UTIL_C
#include "perl.h"
+#ifdef USE_PERLIO
+#include "perliol.h" /* For PerlIOUnix_refcnt */
+#endif
+
#ifndef PERL_MICRO
#include <signal.h>
#ifndef SIG_ERR
NORETURN_FUNCTION_END;
}
+#if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL)
+# define ALWAYS_NEED_THX
+#endif
+
/* paranoid version of system's malloc() */
Malloc_t
Perl_safesysmalloc(MEM_SIZE size)
{
+#ifdef ALWAYS_NEED_THX
dTHX;
+#endif
Malloc_t ptr;
#ifdef HAS_64K_LIMIT
if (size > 0xffff) {
#endif
ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
PERL_ALLOC_CHECK(ptr);
- DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
if (ptr != NULL) {
#ifdef PERL_TRACK_MEMPOOL
struct perl_memory_debug_header *const header
# endif
ptr = (Malloc_t)((char*)ptr+sTHX);
#endif
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
return ptr;
}
- else if (PL_nomemok)
- return NULL;
else {
- return write_no_mem();
+#ifndef ALWAYS_NEED_THX
+ dTHX;
+#endif
+ if (PL_nomemok)
+ return NULL;
+ else {
+ return write_no_mem();
+ }
}
/*NOTREACHED*/
}
Malloc_t
Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
{
+#ifdef ALWAYS_NEED_THX
dTHX;
+#endif
Malloc_t ptr;
#if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
Malloc_t PerlMem_realloc();
if (ptr != NULL) {
return ptr;
}
- else if (PL_nomemok)
- return NULL;
else {
- return write_no_mem();
+#ifndef ALWAYS_NEED_THX
+ dTHX;
+#endif
+ if (PL_nomemok)
+ return NULL;
+ else {
+ return write_no_mem();
+ }
}
/*NOTREACHED*/
}
Free_t
Perl_safesysfree(Malloc_t where)
{
-#if defined(PERL_IMPLICIT_SYS) || defined(PERL_TRACK_MEMPOOL)
+#ifdef ALWAYS_NEED_THX
dTHX;
#else
dVAR;
Malloc_t
Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
{
+#ifdef ALWAYS_NEED_THX
dTHX;
+#endif
Malloc_t ptr;
+#if defined(PERL_TRACK_MEMPOOL) || defined(HAS_64K_LIMIT) || defined(DEBUGGING)
MEM_SIZE total_size = 0;
+#endif
/* Even though calloc() for zero bytes is strange, be robust. */
- if (size && (count <= MEM_SIZE_MAX / size))
+ if (size && (count <= MEM_SIZE_MAX / size)) {
+#if defined(PERL_TRACK_MEMPOOL) || defined(HAS_64K_LIMIT) || defined(DEBUGGING)
total_size = size * count;
+#endif
+ }
else
Perl_croak_nocontext("%s", PL_memory_wrap);
#ifdef PERL_TRACK_MEMPOOL
#endif
return ptr;
}
- else if (PL_nomemok)
- return NULL;
- return write_no_mem();
+ else {
+#ifndef ALWAYS_NEED_THX
+ dTHX;
+#endif
+ if (PL_nomemok)
+ return NULL;
+ return write_no_mem();
+ }
}
/* These must be defined when not using Perl's malloc for binary
return NULL;
}
+/*
+=for apidoc foldEQ
+
+Returns true if the leading len bytes of the strings s1 and s2 are the same
+case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes
+match themselves and their opposite case counterparts. Non-cased and non-ASCII
+range bytes match only themselves.
+
+=cut
+*/
+
+
I32
-Perl_ibcmp(const char *s1, const char *s2, register I32 len)
+Perl_foldEQ(const char *s1, const char *s2, register I32 len)
{
register const U8 *a = (const U8 *)s1;
register const U8 *b = (const U8 *)s2;
- PERL_ARGS_ASSERT_IBCMP;
+ PERL_ARGS_ASSERT_FOLDEQ;
while (len--) {
if (*a != *b && *a != PL_fold[*b])
- return 1;
+ return 0;
a++,b++;
}
- return 0;
+ return 1;
}
+I32
+Perl_foldEQ_latin1(const char *s1, const char *s2, register I32 len)
+{
+ /* Compare non-utf8 using Unicode (Latin1) semantics. Does not work on
+ * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
+ * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these. Nor
+ * does it check that the strings each have at least 'len' characters */
+
+ register const U8 *a = (const U8 *)s1;
+ register const U8 *b = (const U8 *)s2;
+
+ PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
+
+ while (len--) {
+ if (*a != *b && *a != PL_fold_latin1[*b]) {
+ return 0;
+ }
+ a++, b++;
+ }
+ return 1;
+}
+
+/*
+=for apidoc foldEQ_locale
+
+Returns true if the leading len bytes of the strings s1 and s2 are the same
+case-insensitively in the current locale; false otherwise.
+
+=cut
+*/
I32
-Perl_ibcmp_locale(const char *s1, const char *s2, register I32 len)
+Perl_foldEQ_locale(const char *s1, const char *s2, register I32 len)
{
dVAR;
register const U8 *a = (const U8 *)s1;
register const U8 *b = (const U8 *)s2;
- PERL_ARGS_ASSERT_IBCMP_LOCALE;
+ PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
while (len--) {
if (*a != *b && *a != PL_fold_locale[*b])
- return 1;
+ return 0;
a++,b++;
}
- return 0;
+ return 1;
}
/* copy a string to a safe spot */
return (char *) CopyD(pv,newaddr,len,char);
}
+/*
+=for apidoc savesharedsvpv
+
+A version of C<savesharedpv()> which allocates the duplicate string in
+memory which is shared between threads.
+
+=cut
+*/
+
+char *
+Perl_savesharedsvpv(pTHX_ SV *sv)
+{
+ STRLEN len;
+ const char * const pv = SvPV_const(sv, len);
+
+ PERL_ARGS_ASSERT_SAVESHAREDSVPV;
+
+ return savesharedpvn(pv, len);
+}
/* the SV for Perl_form() and mess() is not kept in an arena */
SV *sv;
XPVMG *any;
- if (!PL_dirty)
+ if (PL_phase != PERL_PHASE_DESTRUCT)
return newSVpvs_flags("", SVs_TEMP);
if (PL_mess_sv)
return SvPVX(sv);
}
+/*
+=for apidoc Am|SV *|mess|const char *pat|...
+
+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,
+then it will be extended with some indication of the current location
+in the code, as described for L</mess_sv>.
+
+Normally, the resulting message is returned in a new mortal SV.
+During global destruction a single SV may be shared between uses of
+this function.
+
+=cut
+*/
+
#if defined(PERL_IMPLICIT_CONTEXT)
SV *
Perl_mess_nocontext(const char *pat, ...)
return NULL;
}
+/*
+=for apidoc Am|SV *|mess_sv|SV *basemsg|bool consume
+
+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
+to be complete.
+
+C<basemsg> is the initial message or object. If it is a reference, it
+will be used as-is and will be the result of this function. Otherwise it
+is used as a string, and if it already ends with a newline, it is taken
+to be complete, and the result of this function will be the same string.
+If the message does not end with a newline, then a segment such as C<at
+foo.pl line 37> will be appended, and possibly other clauses indicating
+the current state of execution. The resulting message will end with a
+dot and a newline.
+
+Normally, the resulting message is returned in a new mortal SV.
+During global destruction a single SV may be shared between uses of this
+function. If C<consume> is true, then the function is permitted (but not
+required) to modify and return C<basemsg> instead of allocating a new SV.
+
+=cut
+*/
+
SV *
-Perl_vmess(pTHX_ const char *pat, va_list *args)
+Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
{
dVAR;
- SV * const sv = mess_alloc();
+ SV *sv;
- PERL_ARGS_ASSERT_VMESS;
+ PERL_ARGS_ASSERT_MESS_SV;
+
+ if (SvROK(basemsg)) {
+ if (consume) {
+ sv = basemsg;
+ }
+ else {
+ sv = mess_alloc();
+ sv_setsv(sv, basemsg);
+ }
+ return sv;
+ }
+
+ if (SvPOK(basemsg) && consume) {
+ sv = basemsg;
+ }
+ else {
+ sv = mess_alloc();
+ sv_copypv(sv, basemsg);
+ }
- sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
/*
* Try and find the file and line for PL_op. This will usually be
line_mode ? "line" : "chunk",
(IV)IoLINES(GvIOp(PL_last_in_gv)));
}
- if (PL_dirty)
+ if (PL_phase == PERL_PHASE_DESTRUCT)
sv_catpvs(sv, " during global destruction");
sv_catpvs(sv, ".\n");
}
return sv;
}
+/*
+=for apidoc Am|SV *|vmess|const char *pat|va_list *args
+
+C<pat> and C<args> are a sprintf-style format pattern and encapsulated
+argument list. These are used to generate a string message. If the
+message does not end with a newline, then it will be extended with
+some indication of the current location in the code, as described for
+L</mess_sv>.
+
+Normally, the resulting message is returned in a new mortal SV.
+During global destruction a single SV may be shared between uses of
+this function.
+
+=cut
+*/
+
+SV *
+Perl_vmess(pTHX_ const char *pat, va_list *args)
+{
+ dVAR;
+ SV * const sv = mess_alloc();
+
+ PERL_ARGS_ASSERT_VMESS;
+
+ sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
+ return mess_sv(sv, 1);
+}
+
void
-Perl_write_to_stderr(pTHX_ const char* message, int msglen)
+Perl_write_to_stderr(pTHX_ SV* msv)
{
dVAR;
IO *io;
if (PL_stderrgv && SvREFCNT(PL_stderrgv)
&& (io = GvIO(PL_stderrgv))
&& (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
- {
- dSP;
- ENTER;
- SAVETMPS;
-
- save_re_context();
- SAVESPTR(PL_stderrgv);
- PL_stderrgv = NULL;
-
- PUSHSTACKi(PERLSI_MAGIC);
-
- PUSHMARK(SP);
- EXTEND(SP,2);
- PUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
- mPUSHp(message, msglen);
- PUTBACK;
- call_method("PRINT", G_SCALAR);
-
- POPSTACK;
- FREETMPS;
- LEAVE;
- }
+ Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, "PRINT",
+ G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv);
else {
#ifdef USE_SFIO
/* SFIO can really mess with your errno */
#endif
PerlIO * const serr = Perl_error_log;
- PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
+ do_print(msv, serr);
(void)PerlIO_flush(serr);
#ifdef USE_SFIO
RESTORE_ERRNO;
}
}
-/* Common code used by vcroak, vdie, vwarn and vwarner */
+/*
+=head1 Warning and Dieing
+*/
+
+/* Common code used in dieing and warning */
+
+STATIC SV *
+S_with_queued_errors(pTHX_ SV *ex)
+{
+ PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS;
+ if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) {
+ sv_catsv(PL_errors, ex);
+ ex = sv_mortalcopy(PL_errors);
+ SvCUR_set(PL_errors, 0);
+ }
+ return ex;
+}
STATIC bool
-S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
+S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
{
dVAR;
HV *stash;
/* sv_2cv might call Perl_croak() or Perl_warner() */
SV * const oldhook = *hook;
- assert(oldhook);
+ if (!oldhook)
+ return FALSE;
ENTER;
SAVESPTR(*hook);
LEAVE;
if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
dSP;
- SV *msg;
+ SV *exarg;
ENTER;
save_re_context();
SAVESPTR(*hook);
*hook = NULL;
}
- if (warn || message) {
- msg = newSVpvn_flags(message, msglen, utf8);
- SvREADONLY_on(msg);
- SAVEFREESV(msg);
- }
- else {
- msg = ERRSV;
- }
+ exarg = newSVsv(ex);
+ SvREADONLY_on(exarg);
+ SAVEFREESV(exarg);
PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
PUSHMARK(SP);
- XPUSHs(msg);
+ XPUSHs(exarg);
PUTBACK;
call_sv(MUTABLE_SV(cv), G_DISCARD);
POPSTACK;
return FALSE;
}
-STATIC const char *
-S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
- I32* utf8)
-{
- dVAR;
- const char *message;
+/*
+=for apidoc Am|OP *|die_sv|SV *baseex
- if (pat) {
- SV * const msv = vmess(pat, args);
- if (PL_errors && SvCUR(PL_errors)) {
- sv_catsv(PL_errors, msv);
- message = SvPV_const(PL_errors, *msglen);
- SvCUR_set(PL_errors, 0);
- }
- else
- message = SvPV_const(msv,*msglen);
- *utf8 = SvUTF8(msv);
- }
- else {
- message = NULL;
- }
+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.
+The function never actually returns.
- if (PL_diehook) {
- S_vdie_common(aTHX_ message, *msglen, *utf8, FALSE);
- }
- return message;
-}
+=cut
+*/
-static OP *
-S_vdie(pTHX_ const char* pat, va_list *args)
+OP *
+Perl_die_sv(pTHX_ SV *baseex)
{
- dVAR;
- const char *message;
- const int was_in_eval = PL_in_eval;
- STRLEN msglen;
- I32 utf8 = 0;
+ PERL_ARGS_ASSERT_DIE_SV;
+ croak_sv(baseex);
+ /* NOTREACHED */
+ return NULL;
+}
- message = vdie_croak_common(pat, args, &msglen, &utf8);
+/*
+=for apidoc Am|OP *|die|const char *pat|...
- PL_restartop = die_where(message, msglen);
- SvFLAGS(ERRSV) |= utf8;
- if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
- JMPENV_JUMP(3);
- return PL_restartop;
-}
+Behaves the same as L</croak>, except for the return type.
+It should be used only where the C<OP *> return type is required.
+The function never actually returns.
+
+=cut
+*/
#if defined(PERL_IMPLICIT_CONTEXT)
OP *
Perl_die_nocontext(const char* pat, ...)
{
dTHX;
- OP *o;
va_list args;
va_start(args, pat);
- o = vdie(pat, &args);
+ vcroak(pat, &args);
+ /* NOTREACHED */
va_end(args);
- return o;
+ return NULL;
}
#endif /* PERL_IMPLICIT_CONTEXT */
OP *
Perl_die(pTHX_ const char* pat, ...)
{
- OP *o;
va_list args;
va_start(args, pat);
- o = vdie(pat, &args);
+ vcroak(pat, &args);
+ /* NOTREACHED */
va_end(args);
- return o;
+ return NULL;
}
+/*
+=for apidoc Am|void|croak_sv|SV *baseex
+
+This is an XS interface to Perl's C<die> function.
+
+C<baseex> is the error message or object. If it is a reference, it
+will be used as-is. Otherwise it is used as a string, and if it does
+not end with a newline then it will be extended with some indication of
+the current location in the code, as described for L</mess_sv>.
+
+The error message or object will be used as an exception, by default
+returning control to the nearest enclosing C<eval>, but subject to
+modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak_sv>
+function never returns normally.
+
+To die with a simple string message, the L</croak> function may be
+more convenient.
+
+=cut
+*/
+
void
-Perl_vcroak(pTHX_ const char* pat, va_list *args)
+Perl_croak_sv(pTHX_ SV *baseex)
{
- dVAR;
- const char *message;
- STRLEN msglen;
- I32 utf8 = 0;
+ SV *ex = with_queued_errors(mess_sv(baseex, 0));
+ PERL_ARGS_ASSERT_CROAK_SV;
+ invoke_exception_hook(ex, FALSE);
+ die_unwind(ex);
+}
+
+/*
+=for apidoc Am|void|vcroak|const char *pat|va_list *args
- message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
+This is an XS interface to Perl's C<die> function.
- if (PL_in_eval) {
- PL_restartop = die_where(message, msglen);
- SvFLAGS(ERRSV) |= utf8;
- JMPENV_JUMP(3);
- }
- else if (!message)
- message = SvPVx_const(ERRSV, msglen);
+C<pat> and C<args> are a sprintf-style format pattern and encapsulated
+argument list. These are used to generate a string message. If the
+message does not end with a newline, then it will be extended with
+some indication of the current location in the code, as described for
+L</mess_sv>.
- write_to_stderr(message, msglen);
- my_failure_exit();
+The error message will be used as an exception, by default
+returning control to the nearest enclosing C<eval>, but subject to
+modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
+function never returns normally.
+
+For historical reasons, if C<pat> is null then the contents of C<ERRSV>
+(C<$@>) will be used as an error message or object instead of building an
+error message from arguments. If you want to throw a non-string object,
+or build an error message in an SV yourself, it is preferable to use
+the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
+
+=cut
+*/
+
+void
+Perl_vcroak(pTHX_ const char* pat, va_list *args)
+{
+ SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0));
+ invoke_exception_hook(ex, FALSE);
+ die_unwind(ex);
}
+/*
+=for apidoc Am|void|croak|const char *pat|...
+
+This is an XS interface to Perl's C<die> function.
+
+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,
+then it will be extended with some indication of the current location
+in the code, as described for L</mess_sv>.
+
+The error message will be used as an exception, by default
+returning control to the nearest enclosing C<eval>, but subject to
+modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
+function never returns normally.
+
+For historical reasons, if C<pat> is null then the contents of C<ERRSV>
+(C<$@>) will be used as an error message or object instead of building an
+error message from arguments. If you want to throw a non-string object,
+or build an error message in an SV yourself, it is preferable to use
+the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
+
+=cut
+*/
+
#if defined(PERL_IMPLICIT_CONTEXT)
void
Perl_croak_nocontext(const char *pat, ...)
}
#endif /* PERL_IMPLICIT_CONTEXT */
+void
+Perl_croak(pTHX_ const char *pat, ...)
+{
+ va_list args;
+ va_start(args, pat);
+ vcroak(pat, &args);
+ /* NOTREACHED */
+ va_end(args);
+}
+
/*
-=head1 Warning and Dieing
+=for apidoc Am|void|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
+paths reduces CPU cache pressure.
+
+=cut
+*/
+
+void
+Perl_croak_no_modify(pTHX)
+{
+ Perl_croak(aTHX_ "%s", PL_no_modify);
+}
+
+/*
+=for apidoc Am|void|warn_sv|SV *baseex
-=for apidoc croak
+This is an XS interface to Perl's C<warn> function.
-This is the XSUB-writer's interface to Perl's C<die> function.
-Normally call this function the same way you call the C C<printf>
-function. Calling C<croak> returns control directly to Perl,
-sidestepping the normal C order of execution. See C<warn>.
+C<baseex> is the error message or object. If it is a reference, it
+will be used as-is. Otherwise it is used as a string, and if it does
+not end with a newline then it will be extended with some indication of
+the current location in the code, as described for L</mess_sv>.
-If you want to throw an exception object, assign the object to
-C<$@> and then pass C<NULL> to croak():
+The error message or object will by default be written to standard error,
+but this is subject to modification by a C<$SIG{__WARN__}> handler.
- errsv = get_sv("@", GV_ADD);
- sv_setsv(errsv, exception_object);
- croak(NULL);
+To warn with a simple string message, the L</warn> function may be
+more convenient.
=cut
*/
void
-Perl_croak(pTHX_ const char *pat, ...)
+Perl_warn_sv(pTHX_ SV *baseex)
{
- va_list args;
- va_start(args, pat);
- vcroak(pat, &args);
- /* NOTREACHED */
- va_end(args);
+ SV *ex = mess_sv(baseex, 0);
+ PERL_ARGS_ASSERT_WARN_SV;
+ if (!invoke_exception_hook(ex, TRUE))
+ write_to_stderr(ex);
}
+/*
+=for apidoc Am|void|vwarn|const char *pat|va_list *args
+
+This is an XS interface to Perl's C<warn> function.
+
+C<pat> and C<args> are a sprintf-style format pattern and encapsulated
+argument list. These are used to generate a string message. If the
+message does not end with a newline, then it will be extended with
+some indication of the current location in the code, as described for
+L</mess_sv>.
+
+The error message or object will by default be written to standard error,
+but this is subject to modification by a C<$SIG{__WARN__}> handler.
+
+Unlike with L</vcroak>, C<pat> is not permitted to be null.
+
+=cut
+*/
+
void
Perl_vwarn(pTHX_ const char* pat, va_list *args)
{
- dVAR;
- STRLEN msglen;
- SV * const msv = vmess(pat, args);
- const I32 utf8 = SvUTF8(msv);
- const char * const message = SvPV_const(msv, msglen);
-
+ SV *ex = vmess(pat, args);
PERL_ARGS_ASSERT_VWARN;
+ if (!invoke_exception_hook(ex, TRUE))
+ write_to_stderr(ex);
+}
- if (PL_warnhook) {
- if (vdie_common(message, msglen, utf8, TRUE))
- return;
- }
+/*
+=for apidoc Am|void|warn|const char *pat|...
- write_to_stderr(message, msglen);
-}
+This is an XS interface to Perl's C<warn> function.
+
+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,
+then it will be extended with some indication of the current location
+in the code, as described for L</mess_sv>.
+
+The error message or object will by default be written to standard error,
+but this is subject to modification by a C<$SIG{__WARN__}> handler.
+
+Unlike with L</croak>, C<pat> is not permitted to be null.
+
+=cut
+*/
#if defined(PERL_IMPLICIT_CONTEXT)
void
}
#endif /* PERL_IMPLICIT_CONTEXT */
-/*
-=for apidoc warn
-
-This is the XSUB-writer's interface to Perl's C<warn> function. Call this
-function the same way you call the C C<printf> function. See C<croak>.
-
-=cut
-*/
-
void
Perl_warn(pTHX_ const char *pat, ...)
{
PERL_ARGS_ASSERT_VWARNER;
if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
SV * const msv = vmess(pat, args);
- STRLEN msglen;
- const char * const message = SvPV_const(msv, msglen);
- const I32 utf8 = SvUTF8(msv);
- if (PL_diehook) {
- assert(message);
- S_vdie_common(aTHX_ message, msglen, utf8, FALSE);
- }
- if (PL_in_eval) {
- PL_restartop = die_where(message, msglen);
- SvFLAGS(ERRSV) |= utf8;
- JMPENV_JUMP(3);
- }
- write_to_stderr(message, msglen);
- my_failure_exit();
+ invoke_exception_hook(msv, FALSE);
+ die_unwind(msv);
}
else {
Perl_vwarn(aTHX_ pat, args);
if (PL_curcop->cop_warnings == pWARN_NONE)
return FALSE;
+ /* Check the assumption that at least the first slot is non-zero. */
+ assert(unpackWARN1(w));
+
+ /* Check the assumption that it is valid to stop as soon as a zero slot is
+ seen. */
+ if (!unpackWARN2(w)) {
+ assert(!unpackWARN3(w));
+ assert(!unpackWARN4(w));
+ } else if (!unpackWARN3(w)) {
+ assert(!unpackWARN4(w));
+ }
+
/* Right, dealt with all the special cases, which are implemented as non-
pointers, so there is a pointer to a real warnings mask. */
- return isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
- || (unpackWARN2(w) &&
- isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
- || (unpackWARN3(w) &&
- isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
- || (unpackWARN4(w) &&
- isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)));
+ do {
+ if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
+ return TRUE;
+ } while (w >>= WARNshift);
+
+ return FALSE;
}
/* Set buffer=NULL to get a new one. */
default, binary, low-level mode; see PerlIOBuf_open(). */
PerlLIO_setmode((*mode == 'r'), O_BINARY);
#endif
-
- if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
- SvREADONLY_off(GvSV(tmpgv));
- sv_setiv(GvSV(tmpgv), PerlProc_getpid());
- SvREADONLY_on(GvSV(tmpgv));
- }
#ifdef THREADS_HAVE_PIDS
PL_ppid = (IV)getppid();
#endif
int status;
SV **svp;
Pid_t pid;
- Pid_t pid2;
+ Pid_t pid2 = 0;
bool close_failed;
dSAVEDERRNO;
+ const int fd = PerlIO_fileno(ptr);
- svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
+#ifdef USE_PERLIO
+ /* Find out whether the refcount is low enough for us to wait for the
+ child proc without blocking. */
+ const bool should_wait = PerlIOUnix_refcnt(fd) == 1;
+#else
+ const bool should_wait = 1;
+#endif
+
+ svp = av_fetch(PL_fdpid,fd,TRUE);
pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
SvREFCNT_dec(*svp);
*svp = &PL_sv_undef;
rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &istat);
rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
#endif
- do {
+ if (should_wait) do {
pid2 = wait4pid(pid, &status, 0);
} while (pid2 == -1 && errno == EINTR);
#ifndef PERL_MICRO
RESTORE_ERRNO;
return -1;
}
- return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
+ return(
+ should_wait
+ ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
+ : 0
+ );
}
#else
#if defined(__LIBCATAMOUNT__)
}
void
-Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
-{
- const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
-
- if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
- if (ckWARN(WARN_IO)) {
- const char * const direction =
- (const char *)((op == OP_phoney_INPUT_ONLY) ? "in" : "out");
- if (name && *name)
- Perl_warner(aTHX_ packWARN(WARN_IO),
- "Filehandle %s opened only for %sput",
- name, direction);
- else
- Perl_warner(aTHX_ packWARN(WARN_IO),
- "Filehandle opened only for %sput", direction);
- }
- }
- else {
- const char *vile;
- I32 warn_type;
-
- if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
- vile = "closed";
- warn_type = WARN_CLOSED;
- }
- else {
- vile = "unopened";
- warn_type = WARN_UNOPENED;
- }
+Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
+{
+ if (ckWARN(WARN_IO)) {
+ const char * const name
+ = gv && (isGV(gv) || isGV_with_GP(gv)) ? GvENAME(gv) : NULL;
+ const char * const direction = have == '>' ? "out" : "in";
- if (ckWARN(warn_type)) {
- const char * const pars =
- (const char *)(OP_IS_FILETEST(op) ? "" : "()");
- const char * const func =
- (const char *)
- (op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
- op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
- op < 0 ? "" : /* handle phoney cases */
- PL_op_desc[op]);
- const char * const type =
- (const char *)
- (OP_IS_SOCKET(op) ||
- (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ?
- "socket" : "filehandle");
- if (name && *name) {
- Perl_warner(aTHX_ packWARN(warn_type),
- "%s%s on %s %s %s", func, pars, vile, type, name);
- if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
- Perl_warner(
- aTHX_ packWARN(warn_type),
- "\t(Are you trying to call %s%s on dirhandle %s?)\n",
- func, pars, name
- );
- }
- else {
- Perl_warner(aTHX_ packWARN(warn_type),
- "%s%s on %s %s", func, pars, vile, type);
- if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
- Perl_warner(
- aTHX_ packWARN(warn_type),
- "\t(Are you trying to call %s%s on dirhandle?)\n",
- func, pars
- );
- }
- }
+ if (name && *name)
+ Perl_warner(aTHX_ packWARN(WARN_IO),
+ "Filehandle %s opened only for %sput",
+ name, direction);
+ else
+ Perl_warner(aTHX_ packWARN(WARN_IO),
+ "Filehandle opened only for %sput", direction);
}
}
-#ifdef EBCDIC
-/* in ASCII order, not that it matters */
-static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
-
-int
-Perl_ebcdic_control(pTHX_ int ch)
+void
+Perl_report_evil_fh(pTHX_ const GV *gv)
{
- if (ch > 'a') {
- const char *ctlp;
+ const IO *io = gv ? GvIO(gv) : NULL;
+ const PERL_BITFIELD16 op = PL_op->op_type;
+ const char *vile;
+ I32 warn_type;
- if (islower(ch))
- ch = toupper(ch);
-
- if ((ctlp = strchr(controllablechars, ch)) == 0) {
- Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
+ if (io && IoTYPE(io) == IoTYPE_CLOSED) {
+ vile = "closed";
+ warn_type = WARN_CLOSED;
+ }
+ else {
+ vile = "unopened";
+ warn_type = WARN_UNOPENED;
+ }
+
+ if (ckWARN(warn_type)) {
+ const char * const name
+ = gv && (isGV(gv) || isGV_with_GP(gv)) ? GvENAME(gv) : NULL;
+ const char * const pars =
+ (const char *)(OP_IS_FILETEST(op) ? "" : "()");
+ const char * const func =
+ (const char *)
+ (op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
+ op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
+ PL_op_desc[op]);
+ const char * const type =
+ (const char *)
+ (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
+ ? "socket" : "filehandle");
+ if (name && *name) {
+ Perl_warner(aTHX_ packWARN(warn_type),
+ "%s%s on %s %s %s", func, pars, vile, type, name);
+ if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
+ Perl_warner(
+ aTHX_ packWARN(warn_type),
+ "\t(Are you trying to call %s%s on dirhandle %s?)\n",
+ func, pars, name
+ );
+ }
+ else {
+ Perl_warner(aTHX_ packWARN(warn_type),
+ "%s%s on %s %s", func, pars, vile, type);
+ if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
+ Perl_warner(
+ aTHX_ packWARN(warn_type),
+ "\t(Are you trying to call %s%s on dirhandle?)\n",
+ func, pars
+ );
}
-
- if (ctlp == controllablechars)
- return('\177'); /* DEL */
- else
- return((unsigned char)(ctlp - controllablechars - 1));
- } else { /* Want uncontrol */
- if (ch == '\177' || ch == -1)
- return('?');
- else if (ch == '\157')
- return('\177');
- else if (ch == '\174')
- return('\000');
- else if (ch == '^') /* '\137' in 1047, '\260' in 819 */
- return('\036');
- else if (ch == '\155')
- return('\037');
- else if (0 < ch && ch < (sizeof(controllablechars) - 1))
- return(controllablechars[ch+1]);
- else
- Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
}
}
-#endif
/* To workaround core dumps from the uninitialised tm_zone we get the
* system to give us a reasonable struct to copy. This fix means that
* outside the scope for this routine. Since we convert back based on the
* same rules we used to build the yearday, you'll only get strange results
* for input which needed normalising, or for the 'odd' century years which
- * were leap years in the Julian calander but not in the Gregorian one.
+ * were leap years in the Julian calendar but not in the Gregorian one.
* I can live with that.
*
* This algorithm also fails to handle years before A.D. 1 gracefully, but
const int fmtlen = strlen(fmt);
int bufsize = fmtlen + buflen;
- Newx(buf, bufsize, char);
+ Renew(buf, bufsize, char);
while (buf) {
buflen = strftime(buf, bufsize, fmt, &mytm);
if (buflen > 0 && buflen < bufsize)
}
#define VERSION_MAX 0x7FFFFFFF
+
+/*
+=for apidoc prescan_version
+
+Validate that a given string can be parsed as a version object, but doesn't
+actually perform the parsing. Can use either strict or lax validation rules.
+Can optionally set a number of hint variables to save the parsing code
+some time when tokenizing.
+
+=cut
+*/
+const char *
+Perl_prescan_version(pTHX_ const char *s, bool strict,
+ const char **errstr,
+ bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) {
+ bool qv = (sqv ? *sqv : FALSE);
+ int width = 3;
+ int saw_decimal = 0;
+ bool alpha = FALSE;
+ const char *d = s;
+
+ PERL_ARGS_ASSERT_PRESCAN_VERSION;
+
+ if (qv && isDIGIT(*d))
+ goto dotted_decimal_version;
+
+ if (*d == 'v') { /* explicit v-string */
+ d++;
+ if (isDIGIT(*d)) {
+ qv = TRUE;
+ }
+ else { /* degenerate v-string */
+ /* requires v1.2.3 */
+ BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
+ }
+
+dotted_decimal_version:
+ if (strict && d[0] == '0' && isDIGIT(d[1])) {
+ /* no leading zeros allowed */
+ BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
+ }
+
+ while (isDIGIT(*d)) /* integer part */
+ d++;
+
+ if (*d == '.')
+ {
+ saw_decimal++;
+ d++; /* decimal point */
+ }
+ else
+ {
+ if (strict) {
+ /* require v1.2.3 */
+ BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
+ }
+ else {
+ goto version_prescan_finish;
+ }
+ }
+
+ {
+ int i = 0;
+ int j = 0;
+ while (isDIGIT(*d)) { /* just keep reading */
+ i++;
+ while (isDIGIT(*d)) {
+ d++; j++;
+ /* maximum 3 digits between decimal */
+ if (strict && j > 3) {
+ BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)");
+ }
+ }
+ if (*d == '_') {
+ if (strict) {
+ BADVERSION(s,errstr,"Invalid version format (no underscores)");
+ }
+ if ( alpha ) {
+ BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
+ }
+ d++;
+ alpha = TRUE;
+ }
+ else if (*d == '.') {
+ if (alpha) {
+ BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
+ }
+ saw_decimal++;
+ d++;
+ }
+ else if (!isDIGIT(*d)) {
+ break;
+ }
+ j = 0;
+ }
+
+ if (strict && i < 2) {
+ /* requires v1.2.3 */
+ BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
+ }
+ }
+ } /* end if dotted-decimal */
+ else
+ { /* decimal versions */
+ /* special strict case for leading '.' or '0' */
+ if (strict) {
+ if (*d == '.') {
+ BADVERSION(s,errstr,"Invalid version format (0 before decimal required)");
+ }
+ if (*d == '0' && isDIGIT(d[1])) {
+ BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
+ }
+ }
+
+ /* consume all of the integer part */
+ while (isDIGIT(*d))
+ d++;
+
+ /* look for a fractional part */
+ if (*d == '.') {
+ /* we found it, so consume it */
+ saw_decimal++;
+ d++;
+ }
+ else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') {
+ if ( d == s ) {
+ /* found nothing */
+ BADVERSION(s,errstr,"Invalid version format (version required)");
+ }
+ /* found just an integer */
+ goto version_prescan_finish;
+ }
+ else if ( d == s ) {
+ /* didn't find either integer or period */
+ BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
+ }
+ else if (*d == '_') {
+ /* underscore can't come after integer part */
+ if (strict) {
+ BADVERSION(s,errstr,"Invalid version format (no underscores)");
+ }
+ else if (isDIGIT(d[1])) {
+ BADVERSION(s,errstr,"Invalid version format (alpha without decimal)");
+ }
+ else {
+ BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
+ }
+ }
+ else {
+ /* anything else after integer part is just invalid data */
+ BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
+ }
+
+ /* scan the fractional part after the decimal point*/
+
+ if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) {
+ /* strict or lax-but-not-the-end */
+ BADVERSION(s,errstr,"Invalid version format (fractional part required)");
+ }
+
+ while (isDIGIT(*d)) {
+ d++;
+ if (*d == '.' && isDIGIT(d[-1])) {
+ if (alpha) {
+ BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
+ }
+ if (strict) {
+ BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
+ }
+ d = (char *)s; /* start all over again */
+ qv = TRUE;
+ goto dotted_decimal_version;
+ }
+ if (*d == '_') {
+ if (strict) {
+ BADVERSION(s,errstr,"Invalid version format (no underscores)");
+ }
+ if ( alpha ) {
+ BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
+ }
+ if ( ! isDIGIT(d[1]) ) {
+ BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
+ }
+ d++;
+ alpha = TRUE;
+ }
+ }
+ }
+
+version_prescan_finish:
+ while (isSPACE(*d))
+ d++;
+
+ if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) {
+ /* trailing non-numeric data */
+ BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
+ }
+
+ if (sqv)
+ *sqv = qv;
+ if (swidth)
+ *swidth = width;
+ if (ssaw_decimal)
+ *ssaw_decimal = saw_decimal;
+ if (salpha)
+ *salpha = alpha;
+ return d;
+}
+
/*
=for apidoc scan_version
const char *start;
const char *pos;
const char *last;
- int saw_period = 0;
- int alpha = 0;
+ const char *errstr = NULL;
+ int saw_decimal = 0;
int width = 3;
+ bool alpha = FALSE;
bool vinf = FALSE;
AV * const av = newAV();
SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
(void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
+#ifndef NODEFAULT_SHAREKEYS
+ HvSHAREKEYS_on(hv); /* key-sharing on by default */
+#endif
+
while (isSPACE(*s)) /* leading whitespace is OK */
s++;
- start = last = s;
-
- if (*s == 'v') {
- s++; /* get past 'v' */
- qv = 1; /* force quoted version processing */
- }
-
- pos = s;
-
- /* pre-scan the input string to check for decimals/underbars */
- while ( *pos == '.' || *pos == '_' || *pos == ',' || isDIGIT(*pos) )
- {
- if ( *pos == '.' )
- {
- if ( alpha )
- Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
- saw_period++ ;
- last = pos;
- }
- else if ( *pos == '_' )
- {
- if ( alpha )
- Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
- alpha = 1;
- width = pos - last - 1; /* natural width of sub-version */
+ last = prescan_version(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
+ if (errstr) {
+ /* "undef" is a special case and not an error */
+ if ( ! ( *s == 'u' && strEQ(s,"undef")) ) {
+ Perl_croak(aTHX_ "%s", errstr);
}
- else if ( *pos == ',' && isDIGIT(pos[1]) )
- {
- saw_period++ ;
- last = pos;
- }
-
- pos++;
}
- if ( alpha && !saw_period )
- Perl_croak(aTHX_ "Invalid version format (alpha without decimal)");
-
- if ( alpha && saw_period && width == 0 )
- Perl_croak(aTHX_ "Invalid version format (misplaced _ in number)");
-
- if ( saw_period > 1 )
- qv = 1; /* force quoted version processing */
-
- last = pos;
+ start = s;
+ if (*s == 'v')
+ s++;
pos = s;
if ( qv )
* point of a version originally created with a bare
* floating point number, i.e. not quoted in any way
*/
- if ( !qv && s > start && saw_period == 1 ) {
+ if ( !qv && s > start && saw_decimal == 1 ) {
mult *= 100;
while ( s < end ) {
orev = rev;
}
else if ( s > start ) {
SV * orig = newSVpvn(start,s-start);
- if ( qv && saw_period == 1 && *start != 'v' ) {
+ if ( qv && saw_decimal == 1 && *start != 'v' ) {
/* need to insert a v to be consistent */
sv_insert(orig, 0, 0, "v", 1);
}
/* This will get reblessed later if a derived class*/
SV * const hv = newSVrv(rv, "version");
(void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
+#ifndef NODEFAULT_SHAREKEYS
+ HvSHAREKEYS_on(hv); /* key-sharing on by default */
+#endif
if ( SvROK(ver) )
ver = SvRV(ver);
char * const version = savepvn( (const char*)mg->mg_ptr, len);
sv_setpvn(rv,version,len);
/* this is for consistency with the pure Perl class */
- if ( *version != 'v' )
+ if ( isDIGIT(*version) )
sv_insert(rv, 0, 0, "v", 1);
Safefree(version);
}
#ifdef SvVOK
else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
- qv = 1;
+ qv = TRUE;
}
#endif
else /* must be a string or something like a string */
#ifndef SvVOK
# if PERL_VERSION > 5
/* This will only be executed for 5.6.0 - 5.8.0 inclusive */
- if ( len == 3 && !instr(version,".") && !instr(version,"_") ) {
+ if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {
/* may be a v-string */
- SV * const nsv = sv_newmortal();
- const char *nver;
- const char *pos;
- int saw_period = 0;
- sv_setpvf(nsv,"v%vd",ver);
- pos = nver = savepv(SvPV_nolen(nsv));
-
- /* scan the resulting formatted string */
- pos++; /* skip the leading 'v' */
- while ( *pos == '.' || isDIGIT(*pos) ) {
- if ( *pos == '.' )
- saw_period++ ;
- pos++;
- }
+ char *testv = (char *)version;
+ STRLEN tlen = len;
+ for (tlen=0; tlen < len; tlen++, testv++) {
+ /* if one of the characters is non-text assume v-string */
+ if (testv[0] < ' ') {
+ SV * const nsv = sv_newmortal();
+ const char *nver;
+ const char *pos;
+ int saw_decimal = 0;
+ sv_setpvf(nsv,"v%vd",ver);
+ pos = nver = savepv(SvPV_nolen(nsv));
+
+ /* scan the resulting formatted string */
+ pos++; /* skip the leading 'v' */
+ while ( *pos == '.' || isDIGIT(*pos) ) {
+ if ( *pos == '.' )
+ saw_decimal++ ;
+ pos++;
+ }
- /* is definitely a v-string */
- if ( saw_period == 2 ) {
- Safefree(version);
- version = nver;
+ /* is definitely a v-string */
+ if ( saw_decimal >= 2 ) {
+ Safefree(version);
+ version = nver;
+ }
+ break;
+ }
}
}
# endif
/*
=for apidoc vverify
-Validates that the SV contains a valid version object.
+Validates that the SV contains valid internal structure for a version object.
+It may be passed either the version object (RV) or the hash itself (HV). If
+the structure is valid, it returns the HV. If the structure is invalid,
+it returns NULL.
- bool vverify(SV *vobj);
+ SV *hv = vverify(sv);
Note that it only confirms the bare minimum structure (so as not to get
confused by derived classes which may contain additional hash entries):
=over 4
-=item * The SV contains a [reference to a] hash
+=item * The SV is an HV or a reference to an HV
=item * The hash contains a "version" key
-=item * The "version" key has [a reference to] an AV as its value
+=item * The "version" key has a reference to an AV as its value
=back
=cut
*/
-bool
+SV *
Perl_vverify(pTHX_ SV *vs)
{
SV *sv;
&& hv_exists(MUTABLE_HV(vs), "version", 7)
&& (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
&& SvTYPE(sv) == SVt_PVAV )
- return TRUE;
+ return vs;
else
- return FALSE;
+ return NULL;
}
/*
NOTE: you can pass either the object directly or the SV
contained within the RV.
+The SV returned has a refcount of 1.
+
=cut
*/
I32 i, len, digit;
int width;
bool alpha = FALSE;
- SV * const sv = newSV(0);
+ SV *sv;
AV *av;
PERL_ARGS_ASSERT_VNUMIFY;
- if ( SvROK(vs) )
- vs = SvRV(vs);
-
- if ( !vverify(vs) )
+ /* extract the HV from the object */
+ vs = vverify(vs);
+ if ( ! vs )
Perl_croak(aTHX_ "Invalid version object");
/* see if various flags exist */
/* attempt to retrieve the version array */
if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
- sv_catpvs(sv,"0");
- return sv;
+ return newSVpvs("0");
}
len = av_len(av);
if ( len == -1 )
{
- sv_catpvs(sv,"0");
- return sv;
+ return newSVpvs("0");
}
digit = SvIV(*av_fetch(av, 0, 0));
- Perl_sv_setpvf(aTHX_ sv, "%d.", (int)PERL_ABS(digit));
+ sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
for ( i = 1 ; i < len ; i++ )
{
digit = SvIV(*av_fetch(av, i, 0));
NOTE: you can pass either the object directly or the SV
contained within the RV.
+The SV returned has a refcount of 1.
+
=cut
*/
{
I32 i, len, digit;
bool alpha = FALSE;
- SV * const sv = newSV(0);
+ SV *sv;
AV *av;
PERL_ARGS_ASSERT_VNORMAL;
- if ( SvROK(vs) )
- vs = SvRV(vs);
-
- if ( !vverify(vs) )
+ /* extract the HV from the object */
+ vs = vverify(vs);
+ if ( ! vs )
Perl_croak(aTHX_ "Invalid version object");
if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
len = av_len(av);
if ( len == -1 )
{
- sv_catpvs(sv,"");
- return sv;
+ return newSVpvs("");
}
digit = SvIV(*av_fetch(av, 0, 0));
- Perl_sv_setpvf(aTHX_ sv, "v%"IVdf, (IV)digit);
+ sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
for ( i = 1 ; i < len ; i++ ) {
digit = SvIV(*av_fetch(av, i, 0));
Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
In order to maintain maximum compatibility with earlier versions
of Perl, this function will return either the floating point
notation or the multiple dotted notation, depending on whether
-the original version contained 1 or more dots, respectively
+the original version contained 1 or more dots, respectively.
+
+The SV returned has a refcount of 1.
=cut
*/
{
PERL_ARGS_ASSERT_VSTRINGIFY;
- if ( SvROK(vs) )
- vs = SvRV(vs);
-
- if ( !vverify(vs) )
+ /* extract the HV from the object */
+ vs = vverify(vs);
+ if ( ! vs )
Perl_croak(aTHX_ "Invalid version object");
if (hv_exists(MUTABLE_HV(vs), "original", sizeof("original") - 1)) {
PERL_ARGS_ASSERT_VCMP;
- if ( SvROK(lhv) )
- lhv = SvRV(lhv);
- if ( SvROK(rhv) )
- rhv = SvRV(rhv);
-
- if ( !vverify(lhv) )
- Perl_croak(aTHX_ "Invalid version object");
-
- if ( !vverify(rhv) )
+ /* extract the HVs from the objects */
+ lhv = vverify(lhv);
+ rhv = vverify(rhv);
+ if ( ! ( lhv && rhv ) )
Perl_croak(aTHX_ "Invalid version object");
/* get the left hand term */
opt = (U32) atoi(p);
while (isDIGIT(*p))
p++;
- if (*p && *p != '\n' && *p != '\r')
+ if (*p && *p != '\n' && *p != '\r') {
+ if(isSPACE(*p)) goto the_end_of_the_opts_parser;
+ else
Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
+ }
}
else {
for (; *p; p++) {
case PERL_UNICODE_UTF8CACHEASSERT:
opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
default:
- if (*p != '\n' && *p != '\r')
+ if (*p != '\n' && *p != '\r') {
+ if(isSPACE(*p)) goto the_end_of_the_opts_parser;
+ else
Perl_croak(aTHX_
"Unknown Unicode option letter '%c'", *p);
+ }
}
}
}
else
opt = PERL_UNICODE_DEFAULT_FLAGS;
+ the_end_of_the_opts_parser:
+
if (opt & ~PERL_UNICODE_ALL_FLAGS)
Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
(UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
* help. Sum in another random number that will
* fill in the low bits. */
myseed +=
- (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
+ (UV)(Drand01() * (NV)((((UV)1) << ((UVSIZE * 8 - RANDBITS))) - 1));
#endif /* RANDBITS < (UVSIZE * 8) */
if (myseed == 0) { /* Superparanoia. */
myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
mem_log_common (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
#else
/* this is suboptimal, but bug compatible. User is providing their
- own implemenation, but is getting these functions anyway, and they
+ own implementation, but is getting these functions anyway, and they
do nothing. But _NOIMPL users should be able to cope or fix */
# define \
mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
retval = vsprintf(buffer, format, ap);
#endif
va_end(ap);
- /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
- if (retval < 0 || (len > 0 && (Size_t)retval >= len))
+ /* vsprintf() shows failure with < 0 */
+ if (retval < 0
+#ifdef HAS_VSNPRINTF
+ /* vsnprintf() shows failure with >= len */
+ ||
+ (len > 0 && (Size_t)retval >= len)
+#endif
+ )
Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
return retval;
}
retval = vsprintf(buffer, format, ap);
# endif
#endif /* #ifdef NEED_VA_COPY */
- /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
- if (retval < 0 || (len > 0 && (Size_t)retval >= len))
+ /* vsprintf() shows failure with < 0 */
+ if (retval < 0
+#ifdef HAS_VSNPRINTF
+ /* vsnprintf() shows failure with >= len */
+ ||
+ (len > 0 && (Size_t)retval >= len)
+#endif
+ )
Perl_croak(aTHX_ "panic: my_vsnprintf buffer overflow");
return retval;
}
PERL_ARGS_ASSERT_MY_CXT_INIT;
if (*index == -1) {
/* this module hasn't been allocated an index yet */
+#if defined(USE_ITHREADS)
MUTEX_LOCK(&PL_my_ctx_mutex);
+#endif
*index = PL_my_cxt_index++;
+#if defined(USE_ITHREADS)
MUTEX_UNLOCK(&PL_my_ctx_mutex);
+#endif
}
/* make sure the array is big enough */
index = Perl_my_cxt_index(aTHX_ my_cxt_key);
if (index == -1) {
/* this module hasn't been allocated an index yet */
+#if defined(USE_ITHREADS)
MUTEX_LOCK(&PL_my_ctx_mutex);
+#endif
index = PL_my_cxt_index++;
+#if defined(USE_ITHREADS)
MUTEX_UNLOCK(&PL_my_ctx_mutex);
+#endif
}
/* make sure the array is big enough */
#endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
#endif /* PERL_IMPLICIT_CONTEXT */
+void
+Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
+ STRLEN xs_len)
+{
+ SV *sv;
+ const char *vn = NULL;
+ SV *const module = PL_stack_base[ax];
+
+ PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK;
+
+ if (items >= 2) /* version supplied as bootstrap arg */
+ sv = PL_stack_base[ax + 1];
+ else {
+ /* XXX GV_ADDWARN */
+ vn = "XS_VERSION";
+ sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
+ if (!sv || !SvOK(sv)) {
+ vn = "VERSION";
+ sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
+ }
+ }
+ if (sv) {
+ SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP);
+ SV *pmsv = sv_derived_from(sv, "version")
+ ? sv : sv_2mortal(new_version(sv));
+ xssv = upg_version(xssv, 0);
+ if ( vcmp(pmsv,xssv) ) {
+ SV *string = vstringify(xssv);
+ SV *xpt = Perl_newSVpvf(aTHX_ "%"SVf" object version %"SVf
+ " does not match ", module, string);
+
+ SvREFCNT_dec(string);
+ string = vstringify(pmsv);
+
+ if (vn) {
+ Perl_sv_catpvf(aTHX_ xpt, "$%"SVf"::%s %"SVf, module, vn,
+ string);
+ } else {
+ Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %"SVf, string);
+ }
+ SvREFCNT_dec(string);
+
+ Perl_sv_2mortal(aTHX_ xpt);
+ Perl_croak_sv(aTHX_ xpt);
+ }
+ }
+}
+
+void
+Perl_xs_apiversion_bootcheck(pTHX_ SV *module, const char *api_p,
+ STRLEN api_len)
+{
+ SV *xpt = NULL;
+ SV *compver = Perl_newSVpvn_flags(aTHX_ api_p, api_len, SVs_TEMP);
+ SV *runver;
+
+ PERL_ARGS_ASSERT_XS_APIVERSION_BOOTCHECK;
+
+ /* This might croak */
+ compver = upg_version(compver, 0);
+ /* This should never croak */
+ runver = new_version(PL_apiversion);
+ if (vcmp(compver, runver)) {
+ SV *compver_string = vstringify(compver);
+ SV *runver_string = vstringify(runver);
+ xpt = Perl_newSVpvf(aTHX_ "Perl API version %"SVf
+ " of %"SVf" does not match %"SVf,
+ compver_string, module, runver_string);
+ Perl_sv_2mortal(aTHX_ xpt);
+
+ SvREFCNT_dec(compver_string);
+ SvREFCNT_dec(runver_string);
+ }
+ SvREFCNT_dec(runver);
+ if (xpt)
+ Perl_croak_sv(aTHX_ xpt);
+}
+
#ifndef HAS_STRLCAT
Size_t
Perl_my_strlcat(char *dst, const char *src, Size_t size)
{
dVAR;
SV * const dbsv = GvSVn(PL_DBsub);
+ const bool save_taint = PL_tainted;
+
/* We do not care about using sv to call CV;
* it's for informational purposes only.
*/
PERL_ARGS_ASSERT_GET_DB_SUB;
+ PL_tainted = FALSE;
save_item(dbsv);
if (!PERLDB_SUB_NN) {
- GV * const gv = CvGV(cv);
+ GV *gv = CvGV(cv);
if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
|| strEQ(GvNAME(gv), "END")
|| ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
!( (SvTYPE(*svp) == SVt_PVGV)
- && (GvCV((const GV *)*svp) == cv) )))) {
+ && (GvCV((const GV *)*svp) == cv)
+ && (gv = (GV *)*svp)
+ )
+ )
+ )) {
/* Use GV from the stack as a fallback. */
/* GV is potentially non-unique, or contain different CV. */
SV * const tmp = newRV(MUTABLE_SV(cv));
(void)SvIOK_on(dbsv);
SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
}
+ TAINT_IF(save_taint);
}
int
REGEXP *
Perl_get_re_arg(pTHX_ SV *sv) {
- SV *tmpsv;
if (sv) {
if (SvMAGICAL(sv))
mg_get(sv);
- if (SvROK(sv) &&
- (tmpsv = MUTABLE_SV(SvRV(sv))) && /* assign deliberate */
- SvTYPE(tmpsv) == SVt_REGEXP)
- {
- return (REGEXP*) tmpsv;
- }
+ if (SvROK(sv))
+ sv = MUTABLE_SV(SvRV(sv));
+ if (SvTYPE(sv) == SVt_REGEXP)
+ return (REGEXP*) sv;
}
return NULL;
https://perl5.git.perl.org / perl5.git / blobdiff