{
#ifdef ALWAYS_NEED_THX
dTHX;
-#else
- dVAR;
#endif
DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
if (where) {
Malloc_t Perl_malloc (MEM_SIZE nbytes)
{
- dTHXs;
+#ifdef PERL_IMPLICIT_SYS
+ dTHX;
+#endif
return (Malloc_t)PerlMem_malloc(nbytes);
}
Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
{
- dTHXs;
+#ifdef PERL_IMPLICIT_SYS
+ dTHX;
+#endif
return (Malloc_t)PerlMem_calloc(elements, size);
}
Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
{
- dTHXs;
+#ifdef PERL_IMPLICIT_SYS
+ dTHX;
+#endif
return (Malloc_t)PerlMem_realloc(where, nbytes);
}
Free_t Perl_mfree (Malloc_t where)
{
- dTHXs;
+#ifdef PERL_IMPLICIT_SYS
+ dTHX;
+#endif
PerlMem_free(where);
}
void
Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
{
- dVAR;
const U8 *s;
STRLEN i;
STRLEN len;
char *
Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
{
- dVAR;
PERL_ARGS_ASSERT_SCREAMINSTR;
PERL_UNUSED_ARG(bigstr);
PERL_UNUSED_ARG(littlestr);
STATIC SV *
S_mess_alloc(pTHX)
{
- dVAR;
SV *sv;
XPVMG *any;
Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop,
bool opnext)
{
- dVAR;
/* Look for curop starting from o. cop is the last COP we've seen. */
/* opnext means that curop is actually the ->op_next of the op we are
seeking. */
if (o->op_flags & OPf_KIDS) {
const OP *kid;
- for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
+ for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) {
const COP *new_cop;
/* If the OP_NEXTSTATE has been optimised away we can still use it
SV *
Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
{
- dVAR;
SV *sv;
#if defined(USE_C_BACKTRACE) && defined(USE_C_BACKTRACE_ON_ERROR)
int wi;
/* The PERL_C_BACKTRACE_ON_WARN must be an integer of one or more. */
if ((ws = PerlEnv_getenv("PERL_C_BACKTRACE_ON_ERROR")) &&
- (wi = atoi(ws)) > 0) {
+ (wi = grok_atou(ws, NULL)) > 0) {
Perl_dump_c_backtrace(aTHX_ Perl_debug_log, wi, 1);
}
}
*/
const COP *cop =
- closest_cop(PL_curcop, PL_curcop->op_sibling, PL_op, FALSE);
+ closest_cop(PL_curcop, OP_SIBLING(PL_curcop), PL_op, FALSE);
if (!cop)
cop = PL_curcop;
SV *
Perl_vmess(pTHX_ const char *pat, va_list *args)
{
- dVAR;
SV * const sv = mess_alloc();
PERL_ARGS_ASSERT_VMESS;
void
Perl_write_to_stderr(pTHX_ SV* msv)
{
- dVAR;
IO *io;
MAGIC *mg;
STATIC bool
S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
{
- dVAR;
HV *stash;
GV *gv;
CV *cv;
SV *exarg;
ENTER;
- save_re_context();
if (warn) {
SAVESPTR(*hook);
*hook = NULL;
if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
SV * const msv = vmess(pat, args);
- invoke_exception_hook(msv, FALSE);
- die_unwind(msv);
+ if (PL_parser && PL_parser->error_count) {
+ qerror(msv);
+ }
+ else {
+ invoke_exception_hook(msv, FALSE);
+ die_unwind(msv);
+ }
}
else {
Perl_vwarn(aTHX_ pat, args);
bool
Perl_ckwarn(pTHX_ U32 w)
{
- dVAR;
/* If lexical warnings have not been set, use $^W. */
if (isLEXWARN_off)
return PL_dowarn & G_WARN_ON;
bool
Perl_ckwarn_d(pTHX_ U32 w)
{
- dVAR;
/* If lexical warnings have not been set then default classes warn. */
if (isLEXWARN_off)
return TRUE;
my_setenv_format(environ[i], nam, nlen, val, vlen);
} else {
# endif
-# if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__)
+ /* This next branch should only be called #if defined(HAS_SETENV), but
+ Configure doesn't test for that yet. For Solaris, setenv() and unsetenv()
+ were introduced in Solaris 9, so testing for HAS UNSETENV is sufficient.
+ */
+# if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__) || (defined(__sun) && defined(HAS_UNSETENV))
# if defined(HAS_UNSETENV)
if (val == NULL) {
(void)unsetenv(nam);
Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
{
#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
- dVAR;
int p[2];
I32 This, that;
Pid_t pid;
PerlLIO_close(pp[0]);
return PerlIO_fdopen(p[This], mode);
#else
-# ifdef OS2 /* Same, without fork()ing and all extra overhead... */
+# if defined(OS2) /* Same, without fork()ing and all extra overhead... */
return my_syspopen4(aTHX_ NULL, mode, n, args);
+# elif defined(WIN32)
+ return win32_popenlist(mode, n, args);
# else
Perl_croak(aTHX_ "List form of piped open not implemented");
return (PerlIO *) NULL;
PerlIO *
Perl_my_popen(pTHX_ const char *cmd, const char *mode)
{
- dVAR;
int p[2];
I32 This, that;
Pid_t pid;
void
Perl_atfork_lock(void)
{
- dVAR;
#if defined(USE_ITHREADS)
+ dVAR;
/* locks must be held in locking order (if any) */
# ifdef USE_PERLIO
MUTEX_LOCK(&PL_perlio_mutex);
void
Perl_atfork_unlock(void)
{
- dVAR;
#if defined(USE_ITHREADS)
+ dVAR;
/* locks must be released in same order as in atfork_lock() */
# ifdef USE_PERLIO
MUTEX_UNLOCK(&PL_perlio_mutex);
Sighandler_t
Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
{
- dVAR;
struct sigaction act, oact;
#ifdef USE_ITHREADS
+ dVAR;
/* only "parent" interpreter can diddle signals */
if (PL_curinterp != aTHX)
return (Sighandler_t) SIG_ERR;
int
Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
{
+#ifdef USE_ITHREADS
dVAR;
+#endif
struct sigaction act;
PERL_ARGS_ASSERT_RSIGNAL_SAVE;
int
Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
{
+#ifdef USE_ITHREADS
dVAR;
+#endif
+ PERL_UNUSED_CONTEXT;
#ifdef USE_ITHREADS
/* only "parent" interpreter can diddle signals */
if (PL_curinterp != aTHX)
I32
Perl_my_pclose(pTHX_ PerlIO *ptr)
{
- dVAR;
int status;
SV **svp;
Pid_t pid;
I32
Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
{
- dVAR;
I32 result = 0;
PERL_ARGS_ASSERT_WAIT4PID;
#ifdef PERL_USES_PL_PIDSTATUS
Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
const char *const *const search_ext, I32 flags)
{
- dVAR;
const char *xfound = NULL;
char *xfailed = NULL;
char tmpbuf[MAXPATHLEN];
void *
Perl_get_context(void)
{
- dVAR;
#if defined(USE_ITHREADS)
+ dVAR;
# ifdef OLD_PTHREADS_API
pthread_addr_t t;
int error = pthread_getspecific(PL_thr_key, &t)
void
Perl_set_context(void *t)
{
+#if defined(USE_ITHREADS)
dVAR;
+#endif
PERL_ARGS_ASSERT_SET_CONTEXT;
#if defined(USE_ITHREADS)
# ifdef I_MACH_CTHREADS
struct perl_vars *
Perl_GetVars(pTHX)
{
- return &PL_Vars;
+ PERL_UNUSED_CONTEXT;
+ return &PL_Vars;
}
#endif
* semantics (and overhead) of mktime().
*/
void
-Perl_mini_mktime(pTHX_ struct tm *ptm)
+Perl_mini_mktime(struct tm *ptm)
{
int yearday;
int secs;
int month, mday, year, jday;
int odd_cent, odd_year;
- PERL_UNUSED_CONTEXT;
PERL_ARGS_ASSERT_MINI_MKTIME;
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)
{
#ifdef HAS_STRFTIME
+
+ /* Note that yday and wday effectively are ignored by this function, as mini_mktime() overwrites them */
+
char *buf;
int buflen;
struct tm mytm;
Perl_getcwd_sv(pTHX_ SV *sv)
{
#ifndef PERL_MICRO
- dVAR;
SvTAINTED_on(sv);
PERL_ARGS_ASSERT_GETCWD_SV;
if (*p) {
if (isDIGIT(*p)) {
- opt = (U32) atoi(p);
- while (isDIGIT(*p))
- p++;
+ const char* endptr;
+ opt = (U32) grok_atou(p, &endptr);
+ p = endptr;
if (*p && *p != '\n' && *p != '\r') {
if(isSPACE(*p)) goto the_end_of_the_opts_parser;
else
U32
Perl_seed(pTHX)
{
- dVAR;
/*
* This is really just a quick hack which grabs various garbage
* values. It really should be a real hash algorithm which
void
Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer)
{
- dVAR;
const char *env_pv;
unsigned long i;
# ifdef PERL_GLOBAL_STRUCT
const IV nppaddr = C_ARRAY_LENGTH(Gppaddr);
const IV ncheck = C_ARRAY_LENGTH(Gcheck);
+ PERL_UNUSED_CONTEXT;
# ifdef PERL_GLOBAL_STRUCT_PRIVATE
/* PerlMem_malloc() because can't use even safesysmalloc() this early. */
plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
int veto = plvarsp->Gveto_cleanup;
PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT;
+ PERL_UNUSED_CONTEXT;
# ifdef PERL_GLOBAL_STRUCT
# ifdef PERL_UNSET_VARS
PERL_UNSET_VARS(plvarsp);
* The default implementation reads a single env var, PERL_MEM_LOG,
* expecting one or more of the following:
*
- * \d+ - fd fd to write to : must be 1st (atoi)
+ * \d+ - fd fd to write to : must be 1st (grok_atou)
* 'm' - memlog was PERL_MEM_LOG=1
* 's' - svlog was PERL_SV_LOG=1
* 't' - timestamp was PERL_MEM_LOG_TIMESTAMP=1
* timeval. */
{
STRLEN len;
- int fd = atoi(pmlenv);
+ const char* endptr;
+ int fd = grok_atou(pmlenv, &endptr); /* Ignore endptr. */
if (!fd)
fd = PERL_MEM_LOG_FD;
#endif
/*
+=for apidoc quadmath_format_single
+
+quadmath_snprintf() is very strict about its format string and will
+fail, returning -1, if the format is invalid. It acccepts exactly
+one format spec.
+
+quadmath_format_single() checks that the intended single spec looks
+sane: begins with C<%>, has only one C<%>, ends with C<[efgaEFGA]>,
+and has C<Q> before it. This is not a full "printf syntax check",
+just the basics.
+
+Returns the format if it is valid, NULL if not.
+
+quadmath_format_single() can and will actually patch in the missing
+C<Q>, if necessary. In this case it will return the modified copy of
+the format, B<which the caller will need to free.>
+
+See also L</quadmath_format_needed>.
+
+=cut
+*/
+#ifdef USE_QUADMATH
+const char*
+Perl_quadmath_format_single(const char* format)
+{
+ STRLEN len;
+
+ PERL_ARGS_ASSERT_QUADMATH_FORMAT_SINGLE;
+
+ if (format[0] != '%' || strchr(format + 1, '%'))
+ return NULL;
+ len = strlen(format);
+ /* minimum length three: %Qg */
+ if (len < 3 || strchr("efgaEFGA", format[len - 1]) == NULL)
+ return NULL;
+ if (format[len - 2] != 'Q') {
+ char* fixed;
+ Newx(fixed, len + 1, char);
+ memcpy(fixed, format, len - 1);
+ fixed[len - 1] = 'Q';
+ fixed[len ] = format[len - 1];
+ fixed[len + 1] = 0;
+ return (const char*)fixed;
+ }
+ return format;
+}
+#endif
+
+/*
+=for apidoc quadmath_format_needed
+
+quadmath_format_needed() returns true if the format string seems to
+contain at least one non-Q-prefixed %[efgaEFGA] format specifier,
+or returns false otherwise.
+
+The format specifier detection is not complete printf-syntax detection,
+but it should catch most common cases.
+
+If true is returned, those arguments B<should> in theory be processed
+with quadmath_snprintf(), but in case there is more than one such
+format specifier (see L</quadmath_format_single>), and if there is
+anything else beyond that one (even just a single byte), they
+B<cannot> be processed because quadmath_snprintf() is very strict,
+accepting only one format spec, and nothing else.
+In this case, the code should probably fail.
+
+=cut
+*/
+#ifdef USE_QUADMATH
+bool
+Perl_quadmath_format_needed(const char* format)
+{
+ const char *p = format;
+ const char *q;
+
+ PERL_ARGS_ASSERT_QUADMATH_FORMAT_NEEDED;
+
+ while ((q = strchr(p, '%'))) {
+ q++;
+ if (*q == '+') /* plus */
+ q++;
+ if (*q == '#') /* alt */
+ q++;
+ if (*q == '*') /* width */
+ q++;
+ else {
+ if (isDIGIT(*q)) {
+ while (isDIGIT(*q)) q++;
+ }
+ }
+ if (*q == '.' && (q[1] == '*' || isDIGIT(q[1]))) { /* prec */
+ q++;
+ if (*q == '*')
+ q++;
+ else
+ while (isDIGIT(*q)) q++;
+ }
+ if (strchr("efgaEFGA", *q)) /* Would have needed 'Q' in front. */
+ return TRUE;
+ p = q + 1;
+ }
+ return FALSE;
+}
+#endif
+
+/*
=for apidoc my_snprintf
The C library C<snprintf> functionality, if available and
int
Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
{
- int retval;
+ int retval = -1;
va_list ap;
PERL_ARGS_ASSERT_MY_SNPRINTF;
#ifndef HAS_VSNPRINTF
PERL_UNUSED_VAR(len);
#endif
va_start(ap, format);
+#ifdef USE_QUADMATH
+ {
+ const char* qfmt = quadmath_format_single(format);
+ bool quadmath_valid = FALSE;
+ if (qfmt) {
+ /* If the format looked promising, use it as quadmath. */
+ retval = quadmath_snprintf(buffer, len, qfmt, va_arg(ap, NV));
+ if (retval == -1)
+ Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
+ quadmath_valid = TRUE;
+ if (qfmt != format)
+ Safefree(qfmt);
+ qfmt = NULL;
+ }
+ assert(qfmt == NULL);
+ /* quadmath_format_single() will return false for example for
+ * "foo = %g", or simply "%g". We could handle the %g by
+ * using quadmath for the NV args. More complex cases of
+ * course exist: "foo = %g, bar = %g", or "foo=%Qg" (otherwise
+ * quadmath-valid but has stuff in front).
+ *
+ * Handling the "Q-less" cases right would require walking
+ * through the va_list and rewriting the format, calling
+ * quadmath for the NVs, building a new va_list, and then
+ * letting vsnprintf/vsprintf to take care of the other
+ * arguments. This may be doable.
+ *
+ * We do not attempt that now. But for paranoia, we here try
+ * to detect some common (but not all) cases where the
+ * "Q-less" %[efgaEFGA] formats are present, and die if
+ * detected. This doesn't fix the problem, but it stops the
+ * vsnprintf/vsprintf pulling doubles off the va_list when
+ * __float128 NVs should be pulled off instead.
+ *
+ * If quadmath_format_needed() returns false, we are reasonably
+ * certain that we can call vnsprintf() or vsprintf() safely. */
+ if (!quadmath_valid && quadmath_format_needed(format))
+ Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", format);
+
+ }
+#endif
+ if (retval == -1)
#ifdef HAS_VSNPRINTF
- retval = vsnprintf(buffer, len, format, ap);
+ retval = vsnprintf(buffer, len, format, ap);
#else
- retval = vsprintf(buffer, format, ap);
+ retval = vsprintf(buffer, format, ap);
#endif
va_end(ap);
/* vsprintf() shows failure with < 0 */
int
Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
{
+#ifdef USE_QUADMATH
+ PERL_UNUSED_ARG(buffer);
+ PERL_UNUSED_ARG(len);
+ PERL_UNUSED_ARG(format);
+ PERL_UNUSED_ARG(ap);
+ Perl_croak_nocontext("panic: my_vsnprintf not available with quadmath");
+ return 0;
+#else
int retval;
#ifdef NEED_VA_COPY
va_list apc;
)
Perl_croak_nocontext("panic: my_vsnprintf buffer overflow");
return retval;
+#endif
}
void
void
Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
{
- dVAR;
SV * const dbsv = GvSVn(PL_DBsub);
const bool save_taint = TAINT_get;
if (!PERLDB_SUB_NN) {
GV *gv = CvGV(cv);
- if (!svp) {
+ if (!svp && !CvLEXICAL(cv)) {
gv_efullname3(dbsv, gv, NULL);
}
- else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
+ else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) || CvLEXICAL(cv)
|| strEQ(GvNAME(gv), "END")
|| ( /* Could be imported, and old sub redefined. */
(GvCV(gv) != cv || !S_gv_has_usable_name(aTHX_ gv))
else {
sv_sethek(dbsv, HvENAME_HEK(GvSTASH(gv)));
sv_catpvs(dbsv, "::");
- sv_catpvn_flags(
- dbsv, GvNAME(gv), GvNAMELEN(gv),
- GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
- );
+ sv_cathek(dbsv, GvNAME_HEK(gv));
}
}
else {
}
int
-Perl_my_dirfd(pTHX_ DIR * dir) {
+Perl_my_dirfd(DIR * dir) {
/* Most dirfd implementations have problems when passed NULL. */
if(!dir)
return -1;
#ifdef HAS_DIRFD
- PERL_UNUSED_CONTEXT;
return dirfd(dir);
#elif defined(HAS_DIR_DD_FD)
- PERL_UNUSED_CONTEXT;
return dir->dd_fd;
#else
- Perl_die(aTHX_ PL_no_func, "dirfd");
+ Perl_croak_nocontext(PL_no_func, "dirfd");
assert(0); /* NOT REACHED */
return 0;
#endif
/* Given an output buffer end |p| and its |start|, matches
* for the atos output, extracting the source code location
- * if possible, returning NULL otherwise. */
+ * and returning non-NULL if possible, returning NULL otherwise. */
static const char* atos_parse(const char* p,
const char* start,
STRLEN* source_name_size,
STRLEN* source_line) {
- /* atos() outputs is something like:
+ /* atos() output is something like:
* perl_parse (in miniperl) (perl.c:2314)\n\n".
* We cannot use Perl regular expressions, because we need to
* stay low-level. Therefore here we have a rolled-out version
* The matched regular expression is roughly "\(.*:\d+\)\s*$" */
const char* source_number_start;
const char* source_name_end;
+ const char* source_line_end;
+ const char* close_paren;
/* Skip trailing whitespace. */
while (p > start && isspace(*p)) p--;
/* Now we should be at the close paren. */
if (p == start || *p != ')')
return NULL;
+ close_paren = p;
p--;
/* Now we should be in the line number. */
if (p == start || !isdigit(*p))
return NULL;
p++;
*source_name_size = source_name_end - p;
- *source_line = atoi(source_number_start);
+ *source_line = grok_atou(source_number_start, &source_line_end);
+ if (source_line_end != close_paren)
+ return NULL;
return p;
}
https://perl5.git.perl.org / perl5.git / blobdiff