{
#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);
{
char *newaddr;
STRLEN pvlen;
+
+ PERL_UNUSED_CONTEXT;
+
if (!pv)
return NULL;
{
char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
+ PERL_UNUSED_CONTEXT;
/* PERL_ARGS_ASSERT_SAVESHAREDPVN; */
if (!newaddr) {
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;
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;
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
PERL_UNUSED_CONTEXT;
return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
- ? NULL : PL_magic_vtables + vtbl_id;
+ ? NULL : (MGVTBL*)PL_magic_vtables + vtbl_id;
}
I32
#ifdef HAS_TM_TM_ZONE
Time_t now;
const struct tm* my_tm;
+ PERL_UNUSED_CONTEXT;
PERL_ARGS_ASSERT_INIT_TM;
(void)time(&now);
my_tm = localtime(&now);
if (my_tm)
Copy(my_tm, ptm, 1, struct tm);
#else
+ PERL_UNUSED_CONTEXT;
PERL_ARGS_ASSERT_INIT_TM;
PERL_UNUSED_ARG(ptm);
#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;
if (strchr(pmlenv, 't')) {
len = my_snprintf(buf, sizeof(buf),
MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
- PerlLIO_write(fd, buf, len);
+ PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len));
}
switch (mlt) {
case MLT_ALLOC:
default:
len = 0;
}
- PerlLIO_write(fd, buf, len);
+ PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len));
}
}
}
int retval;
va_list ap;
PERL_ARGS_ASSERT_MY_SNPRINTF;
+#ifndef HAS_VSNPRINTF
+ PERL_UNUSED_VAR(len);
+#endif
va_start(ap, format);
#ifdef HAS_VSNPRINTF
retval = vsnprintf(buffer, len, format, ap);
va_list apc;
PERL_ARGS_ASSERT_MY_VSNPRINTF;
-
+#ifndef HAS_VSNPRINTF
+ PERL_UNUSED_VAR(len);
+#endif
Perl_va_copy(ap, apc);
# ifdef HAS_VSNPRINTF
retval = vsnprintf(buffer, len, format, apc);
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)
#elif defined(HAS_DIR_DD_FD)
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;
}