/* util.c
*
- * Copyright (c) 1991-1994, Larry Wall
+ * Copyright (c) 1991-1997, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
#include <signal.h>
#endif
+#ifndef SIG_ERR
+# define SIG_ERR ((Sighandler_t) -1)
+#endif
+
/* XXX If this causes problems, set i_unistd=undef in the hint file. */
#ifdef I_UNISTD
# include <unistd.h>
# include <sys/file.h>
#endif
+#ifdef I_SYS_WAIT
+# include <sys/wait.h>
+#endif
+
#define FLUSH
#ifdef LEAKTEST
#endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
#ifdef HAS_64K_LIMIT
- if (size > 0xffff) {
- PerlIO_printf(PerlIO_stderr(), "Reallocation too large: %lx\n", size) FLUSH;
- my_exit(1);
- }
+ if (size > 0xffff) {
+ PerlIO_printf(PerlIO_stderr(),
+ "Reallocation too large: %lx\n", size) FLUSH;
+ my_exit(1);
+ }
#endif /* HAS_64K_LIMIT */
if (!where)
croak("Null realloc");
/* safe version of free */
-void
+Free_t
safefree(where)
Malloc_t where;
{
Malloc_t ptr;
#ifdef HAS_64K_LIMIT
- if (size * count > 0xffff) {
- PerlIO_printf(PerlIO_stderr(), "Allocation too large: %lx\n", size * count) FLUSH;
- my_exit(1);
- }
+ if (size * count > 0xffff) {
+ PerlIO_printf(PerlIO_stderr(),
+ "Allocation too large: %lx\n", size * count) FLUSH;
+ my_exit(1);
+ }
#endif /* HAS_64K_LIMIT */
#ifdef DEBUGGING
if ((long)size < 0 || (long)count < 0)
croak("panic: calloc");
#endif
+ size *= count;
+ ptr = malloc(size?size:1); /* malloc(0) is NASTY on our system */
#if !(defined(I286) || defined(atarist))
DEBUG_m(PerlIO_printf(PerlIO_stderr(), "0x%x: (%05d) calloc %ld x %ld bytes\n",ptr,an++,(long)count,(long)size));
#else
DEBUG_m(PerlIO_printf(PerlIO_stderr(), "0x%lx: (%05d) calloc %ld x %ld bytes\n",ptr,an++,(long)count,(long)size));
#endif
- size *= count;
- ptr = malloc(size?size:1); /* malloc(0) is NASTY on our system */
if (ptr != Nullch) {
memset((void*)ptr, 0, size);
return ptr;
/* copy a string up to some (non-backslashed) delimiter, if any */
char *
-cpytill(to,from,fromend,delim,retlen)
+delimcpy(to, toend, from, fromend, delim, retlen)
register char *to;
+register char *toend;
register char *from;
register char *fromend;
register int delim;
I32 *retlen;
{
- char *origto = to;
-
- for (; from < fromend; from++,to++) {
+ register I32 tolen;
+ for (tolen = 0; from < fromend; from++, tolen++) {
if (*from == '\\') {
if (from[1] == delim)
from++;
- else if (from[1] == '\\')
- *to++ = *from++;
+ else {
+ if (to < toend)
+ *to++ = *from;
+ tolen++;
+ from++;
+ }
}
else if (*from == delim)
break;
- *to = *from;
+ if (to < toend)
+ *to++ = *from;
}
- *to = '\0';
- *retlen = to - origto;
+ if (to < toend)
+ *to = '\0';
+ *retlen = tolen;
return from;
}
return Nullch;
}
-#ifdef LC_CTYPE
-
/*
* Set up for a new ctype locale.
*/
perl_new_ctype(newctype)
char *newctype;
{
+#ifdef USE_LOCALE_CTYPE
+
int i;
for (i = 0; i < 256; i++) {
else
fold_locale[i] = i;
}
-}
-#endif /* LC_CTYPE */
-
-#ifdef LC_COLLATE
+#endif /* USE_LOCALE_CTYPE */
+}
/*
* Set up for a new collation locale.
perl_new_collate(newcoll)
char *newcoll;
{
+#ifdef USE_LOCALE_COLLATE
+
if (! newcoll) {
if (collation_name) {
++collation_ix;
Safefree(collation_name);
collation_name = NULL;
collation_standard = TRUE;
-#ifdef HAS_STRXFRM
collxfrm_base = 0;
collxfrm_mult = 2;
-#endif /* HAS_STRXFRM */
}
return;
}
++collation_ix;
Safefree(collation_name);
collation_name = savepv(newcoll);
- collation_standard = strEQ(newcoll, "C");
+ collation_standard = (strEQ(newcoll, "C") || strEQ(newcoll, "POSIX"));
-#ifdef HAS_STRXFRM
{
/* 2: at most so many chars ('a', 'b'). */
/* 50: surely no system expands a char more. */
collxfrm_base = (fa > mult) ? (fa - mult) : 0;
collxfrm_mult = mult;
}
-#endif /* HAS_STRXFRM */
}
-}
-
-#endif /* LC_COLLATE */
-#ifdef LC_NUMERIC
+#endif /* USE_LOCALE_COLLATE */
+}
/*
* Set up for a new numeric locale.
perl_new_numeric(newnum)
char *newnum;
{
+#ifdef USE_LOCALE_NUMERIC
+
if (! newnum) {
if (numeric_name) {
Safefree(numeric_name);
if (! numeric_name || strNE(numeric_name, newnum)) {
Safefree(numeric_name);
numeric_name = savepv(newnum);
- numeric_standard = strEQ(newnum, "C");
+ numeric_standard = (strEQ(newnum, "C") || strEQ(newnum, "POSIX"));
numeric_local = TRUE;
}
+
+#endif /* USE_LOCALE_NUMERIC */
}
void
-perl_numeric_standard()
+perl_set_numeric_standard()
{
+#ifdef USE_LOCALE_NUMERIC
+
if (! numeric_standard) {
setlocale(LC_NUMERIC, "C");
numeric_standard = TRUE;
numeric_local = FALSE;
}
+
+#endif /* USE_LOCALE_NUMERIC */
}
void
-perl_numeric_local()
+perl_set_numeric_local()
{
+#ifdef USE_LOCALE_NUMERIC
+
if (! numeric_local) {
setlocale(LC_NUMERIC, numeric_name);
numeric_standard = FALSE;
numeric_local = TRUE;
}
+
+#endif /* USE_LOCALE_NUMERIC */
}
-#endif /* LC_NUMERIC */
-/* Initialize locale awareness */
+/*
+ * Initialize locale awareness.
+ */
int
perl_init_i18nl10n(printwarn)
int printwarn;
* -1 = fallback to C locale failed
*/
-#ifdef HAS_SETLOCALE
+#ifdef USE_LOCALE
- char *lc_all = getenv("LC_ALL");
- char *lang = getenv("LANG");
-#ifdef LC_CTYPE
- char *lc_ctype = getenv("LC_CTYPE");
+#ifdef USE_LOCALE_CTYPE
char *curctype = NULL;
-#endif /* LC_CTYPE */
-#ifdef LC_COLLATE
- char *lc_collate = getenv("LC_COLLATE");
+#endif /* USE_LOCALE_CTYPE */
+#ifdef USE_LOCALE_COLLATE
char *curcoll = NULL;
-#endif /* LC_COLLATE */
-#ifdef LC_NUMERIC
- char *lc_numeric = getenv("LC_NUMERIC");
+#endif /* USE_LOCALE_COLLATE */
+#ifdef USE_LOCALE_NUMERIC
char *curnum = NULL;
-#endif /* LC_NUMERIC */
+#endif /* USE_LOCALE_NUMERIC */
+ char *lc_all = getenv("LC_ALL");
+ char *lang = getenv("LANG");
bool setlocale_failure = FALSE;
- char *subloc;
+
+#ifdef LOCALE_ENVIRON_REQUIRED
+
+ /*
+ * Ultrix setlocale(..., "") fails if there are no environment
+ * variables from which to get a locale name.
+ */
+
+ bool done = FALSE;
#ifdef LC_ALL
- subloc = NULL;
+ if (lang) {
+ if (setlocale(LC_ALL, ""))
+ done = TRUE;
+ else
+ setlocale_failure = TRUE;
+ }
+ if (!setlocale_failure)
+#endif /* LC_ALL */
+ {
+#ifdef USE_LOCALE_CTYPE
+ if (! (curctype = setlocale(LC_CTYPE,
+ (!done && (lang || getenv("LC_CTYPE")))
+ ? "" : Nullch)))
+ setlocale_failure = TRUE;
+#endif /* USE_LOCALE_CTYPE */
+#ifdef USE_LOCALE_COLLATE
+ if (! (curcoll = setlocale(LC_COLLATE,
+ (!done && (lang || getenv("LC_COLLATE")))
+ ? "" : Nullch)))
+ setlocale_failure = TRUE;
+#endif /* USE_LOCALE_COLLATE */
+#ifdef USE_LOCALE_NUMERIC
+ if (! (curnum = setlocale(LC_NUMERIC,
+ (!done && (lang || getenv("LC_NUMERIC")))
+ ? "" : Nullch)))
+ setlocale_failure = TRUE;
+#endif /* USE_LOCALE_NUMERIC */
+ }
+
+#else /* !LOCALE_ENVIRON_REQUIRED */
+
+#ifdef LC_ALL
+
if (! setlocale(LC_ALL, ""))
setlocale_failure = TRUE;
-#else
- subloc = "";
-#endif /* LC_ALL */
+ else {
+#ifdef USE_LOCALE_CTYPE
+ curctype = setlocale(LC_CTYPE, Nullch);
+#endif /* USE_LOCALE_CTYPE */
+#ifdef USE_LOCALE_COLLATE
+ curcoll = setlocale(LC_COLLATE, Nullch);
+#endif /* USE_LOCALE_COLLATE */
+#ifdef USE_LOCALE_NUMERIC
+ curnum = setlocale(LC_NUMERIC, Nullch);
+#endif /* USE_LOCALE_NUMERIC */
+ }
-#ifdef LC_CTYPE
- if (! (curctype = setlocale(LC_CTYPE, subloc)))
+#else /* !LC_ALL */
+
+#ifdef USE_LOCALE_CTYPE
+ if (! (curctype = setlocale(LC_CTYPE, "")))
setlocale_failure = TRUE;
-#endif /* LC_CTYPE */
-#ifdef LC_COLLATE
- if (! (curcoll = setlocale(LC_COLLATE, subloc)))
+#endif /* USE_LOCALE_CTYPE */
+#ifdef USE_LOCALE_COLLATE
+ if (! (curcoll = setlocale(LC_COLLATE, "")))
setlocale_failure = TRUE;
-#endif /* LC_COLLATE */
-#ifdef LC_NUMERIC
- if (! (curnum = setlocale(LC_NUMERIC, subloc)))
+#endif /* USE_LOCALE_COLLATE */
+#ifdef USE_LOCALE_NUMERIC
+ if (! (curnum = setlocale(LC_NUMERIC, "")))
setlocale_failure = TRUE;
-#endif /* LC_NUMERIC */
+#endif /* USE_LOCALE_NUMERIC */
+
+#endif /* LC_ALL */
+
+#endif /* !LOCALE_ENVIRON_REQUIRED */
+
+ if (setlocale_failure) {
+ char *p;
+ bool locwarn = (printwarn > 1 ||
+ printwarn &&
+ (!(p = getenv("PERL_BADLANG")) || atoi(p)));
- if (setlocale_failure && (lc_all || lang)) {
- char *perl_badlang;
+ if (locwarn) {
+#ifdef LC_ALL
+
+ PerlIO_printf(PerlIO_stderr(),
+ "perl: warning: Setting locale failed.\n");
- if (printwarn > 1 ||
- printwarn &&
- (!(perl_badlang = getenv("PERL_BADLANG")) || atoi(perl_badlang))) {
-
+#else /* !LC_ALL */
+
PerlIO_printf(PerlIO_stderr(),
"perl: warning: Setting locale failed for the categories:\n\t");
-#ifdef LC_CTYPE
+#ifdef USE_LOCALE_CTYPE
if (! curctype)
PerlIO_printf(PerlIO_stderr(), "LC_CTYPE ");
-#endif /* LC_CTYPE */
-#ifdef LC_COLLATE
+#endif /* USE_LOCALE_CTYPE */
+#ifdef USE_LOCALE_COLLATE
if (! curcoll)
PerlIO_printf(PerlIO_stderr(), "LC_COLLATE ");
-#endif /* LC_COLLATE */
-#ifdef LC_NUMERIC
+#endif /* USE_LOCALE_COLLATE */
+#ifdef USE_LOCALE_NUMERIC
if (! curnum)
PerlIO_printf(PerlIO_stderr(), "LC_NUMERIC ");
-#endif /* LC_NUMERIC */
+#endif /* USE_LOCALE_NUMERIC */
PerlIO_printf(PerlIO_stderr(), "\n");
+#endif /* LC_ALL */
+
PerlIO_printf(PerlIO_stderr(),
"perl: warning: Please check that your locale settings:\n");
lc_all ? '"' : '(',
lc_all ? lc_all : "unset",
lc_all ? '"' : ')');
-#ifdef LC_CTYPE
- if (! curctype)
- PerlIO_printf(PerlIO_stderr(),
- "\tLC_CTYPE = %c%s%c,\n",
- lc_ctype ? '"' : '(',
- lc_ctype ? lc_ctype : "unset",
- lc_ctype ? '"' : ')');
-#endif /* LC_CTYPE */
-#ifdef LC_COLLATE
- if (! curcoll)
- PerlIO_printf(PerlIO_stderr(),
- "\tLC_COLLATE = %c%s%c,\n",
- lc_collate ? '"' : '(',
- lc_collate ? lc_collate : "unset",
- lc_collate ? '"' : ')');
-#endif /* LC_COLLATE */
-#ifdef LC_NUMERIC
- if (! curcoll)
- PerlIO_printf(PerlIO_stderr(),
- "\tLC_NUMERIC = %c%s%c,\n",
- lc_numeric ? '"' : '(',
- lc_numeric ? lc_numeric : "unset",
- lc_numeric ? '"' : ')');
-#endif /* LC_NUMERIC */
+
+ {
+ char **e;
+ for (e = environ; *e; e++) {
+ if (strnEQ(*e, "LC_", 3)
+ && strnNE(*e, "LC_ALL=", 7)
+ && (p = strchr(*e, '=')))
+ PerlIO_printf(PerlIO_stderr(), "\t%.*s = \"%s\",\n",
+ (p - *e), *e, p + 1);
+ }
+ }
+
PerlIO_printf(PerlIO_stderr(),
"\tLANG = %c%s%c\n",
- lang ? '"' : ')',
+ lang ? '"' : '(',
lang ? lang : "unset",
lang ? '"' : ')');
PerlIO_printf(PerlIO_stderr(),
" are supported and installed on your system.\n");
-
- ok = 0;
}
#ifdef LC_ALL
- if (setlocale_failure) {
- PerlIO_printf(PerlIO_stderr(),
- "perl: warning: Falling back to the \"C\" locale.\n");
- if (setlocale(LC_ALL, "C")) {
-#ifdef LC_CTYPE
- curctype = "C";
-#endif /* LC_CTYPE */
-#ifdef LC_COLLATE
- curcoll = "C";
-#endif /* LC_COLLATE */
-#ifdef LC_NUMERIC
- curnum = "C";
-#endif /* LC_NUMERIC */
- }
- else {
+
+ if (setlocale(LC_ALL, "C")) {
+ if (locwarn)
PerlIO_printf(PerlIO_stderr(),
- "perl: warning: Failed to fall back to the \"C\" locale.\n");
- ok = -1;
- }
+ "perl: warning: Falling back to the standard locale (\"C\").\n");
+ ok = 0;
}
+ else {
+ if (locwarn)
+ PerlIO_printf(PerlIO_stderr(),
+ "perl: warning: Failed to fall back to the standard locale (\"C\").\n");
+ ok = -1;
+ }
+
#else /* ! LC_ALL */
- PerlIO_printf(PerlIO_stderr(),
- "perl: warning: Cannot fall back to the \"C\" locale.\n");
+
+ if (0
+#ifdef USE_LOCALE_CTYPE
+ || !(curctype || setlocale(LC_CTYPE, "C"))
+#endif /* USE_LOCALE_CTYPE */
+#ifdef USE_LOCALE_COLLATE
+ || !(curcoll || setlocale(LC_COLLATE, "C"))
+#endif /* USE_LOCALE_COLLATE */
+#ifdef USE_LOCALE_NUMERIC
+ || !(curnum || setlocale(LC_NUMERIC, "C"))
+#endif /* USE_LOCALE_NUMERIC */
+ )
+ {
+ if (locwarn)
+ PerlIO_printf(PerlIO_stderr(),
+ "perl: warning: Cannot fall back to the standard locale (\"C\").\n");
+ ok = -1;
+ }
+
#endif /* ! LC_ALL */
+
+#ifdef USE_LOCALE_CTYPE
+ curctype = setlocale(LC_CTYPE, Nullch);
+#endif /* USE_LOCALE_CTYPE */
+#ifdef USE_LOCALE_COLLATE
+ curcoll = setlocale(LC_COLLATE, Nullch);
+#endif /* USE_LOCALE_COLLATE */
+#ifdef USE_LOCALE_NUMERIC
+ curnum = setlocale(LC_NUMERIC, Nullch);
+#endif /* USE_LOCALE_NUMERIC */
}
-#ifdef LC_CTYPE
+#ifdef USE_LOCALE_CTYPE
perl_new_ctype(curctype);
-#endif /* LC_NUMERIC */
+#endif /* USE_LOCALE_CTYPE */
-#ifdef LC_COLLATE
+#ifdef USE_LOCALE_COLLATE
perl_new_collate(curcoll);
-#endif /* LC_NUMERIC */
+#endif /* USE_LOCALE_COLLATE */
-#ifdef LC_NUMERIC
+#ifdef USE_LOCALE_NUMERIC
perl_new_numeric(curnum);
-#endif /* LC_NUMERIC */
+#endif /* USE_LOCALE_NUMERIC */
-#endif /* #if defined(HAS_SETLOCALE) */
+#endif /* USE_LOCALE */
return ok;
}
perl_init_i18nl14n(printwarn)
int printwarn;
{
- perl_init_i18nl10n(printwarn);
+ return perl_init_i18nl10n(printwarn);
}
-#ifdef HAS_STRXFRM
+#ifdef USE_LOCALE_COLLATE
/*
* mem_collxfrm() is a bit like strxfrm() but with two important
return NULL;
}
-#endif /* HAS_STRXFRM */
+#endif /* USE_LOCALE_COLLATE */
void
fbm_compile(sv)
return Nullch;
little = (unsigned char*)SvPVX(littlestr);
s = bigend - littlelen;
- if (*s == *little && memcmp((char*)s,(char*)little,littlelen)==0)
+ if (*s == *little && memEQ((char*)s,(char*)little,littlelen))
return (char*)s; /* how sweet it is */
else if (bigend[-1] == '\n' && little[littlelen-1] != '\n'
&& s > big) {
s--;
- if (*s == *little && memcmp((char*)s,(char*)little,littlelen)==0)
+ if (*s == *little && memEQ((char*)s,(char*)little,littlelen))
return (char*)s;
}
return Nullch;
return newaddr;
}
-#if !defined(I_STDARG) && !defined(I_VARARGS)
+/* the SV for form() and mess() is not kept in an arena */
-/*
- * Fallback on the old hackers way of doing varargs
- */
+static SV *
+mess_alloc()
+{
+ SV *sv;
+ XPVMG *any;
+
+ /* Create as PVMG now, to avoid any upgrading later */
+ New(905, sv, 1, SV);
+ Newz(905, any, 1, XPVMG);
+ SvFLAGS(sv) = SVt_PVMG;
+ SvANY(sv) = (void*)any;
+ SvREFCNT(sv) = 1 << 30; /* practically infinite */
+ return sv;
+}
-/*VARARGS1*/
+#ifdef I_STDARG
char *
-mess(pat,a1,a2,a3,a4)
-char *pat;
-long a1, a2, a3, a4;
+form(const char* pat, ...)
+#else
+/*VARARGS0*/
+char *
+form(pat, va_alist)
+ const char *pat;
+ va_dcl
+#endif
{
- char *s;
- char *s_start;
- I32 usermess = strEQ(pat,"%s");
- SV *tmpstr;
+ va_list args;
+#ifdef I_STDARG
+ va_start(args, pat);
+#else
+ va_start(args);
+#endif
+ if (!mess_sv)
+ mess_sv = mess_alloc();
+ sv_vsetpvfn(mess_sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
+ va_end(args);
+ return SvPVX(mess_sv);
+}
- s = s_start = buf;
- if (usermess) {
- tmpstr = sv_newmortal();
- sv_setpv(tmpstr, (char*)a1);
- *s++ = SvPVX(tmpstr)[SvCUR(tmpstr)-1];
- }
- else {
- (void)sprintf(s,pat,a1,a2,a3,a4);
- s += strlen(s);
- }
+char *
+mess(pat, args)
+ const char *pat;
+ va_list *args;
+{
+ SV *sv;
+ static char dgd[] = " during global destruction.\n";
- if (s[-1] != '\n') {
+ if (!mess_sv)
+ mess_sv = mess_alloc();
+ sv = mess_sv;
+ sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
+ if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
if (dirty)
- strcpy(s, " during global destruction.\n");
+ sv_catpv(sv, dgd);
else {
- if (curcop->cop_line) {
- (void)sprintf(s," at %s line %ld",
- SvPVX(GvSV(curcop->cop_filegv)), (long)curcop->cop_line);
- s += strlen(s);
- }
- if (GvIO(last_in_gv) &&
- IoLINES(GvIOp(last_in_gv)) ) {
- (void)sprintf(s,", <%s> %s %ld",
- last_in_gv == argvgv ? "" : GvENAME(last_in_gv),
- strEQ(rs,"\n") ? "line" : "chunk",
- (long)IoLINES(GvIOp(last_in_gv)));
- s += strlen(s);
+ if (curcop->cop_line)
+ sv_catpvf(sv, " at %_ line %ld",
+ GvSV(curcop->cop_filegv), (long)curcop->cop_line);
+ if (GvIO(last_in_gv) && IoLINES(GvIOp(last_in_gv))) {
+ bool line_mode = (RsSIMPLE(rs) &&
+ SvLEN(rs) == 1 && *SvPVX(rs) == '\n');
+ sv_catpvf(sv, ", <%s> %s %ld",
+ last_in_gv == argvgv ? "" : GvNAME(last_in_gv),
+ line_mode ? "line" : "chunk",
+ (long)IoLINES(GvIOp(last_in_gv)));
}
- (void)strcpy(s,".\n");
- s += 2;
+ sv_catpv(sv, ".\n");
}
- if (usermess)
- sv_catpv(tmpstr,buf+1);
- }
-
- if (s - s_start >= sizeof(buf)) { /* Ooops! */
- if (usermess)
- PerlIO_puts(PerlIO_stderr(), SvPVX(tmpstr));
- else
- PerlIO_puts(PerlIO_stderr(), buf);
- PerlIO_puts(PerlIO_stderr(),"panic: message overflow - memory corrupted!\n");
- my_exit(1);
}
- if (usermess)
- return SvPVX(tmpstr);
- else
- return buf;
+ return SvPVX(sv);
}
-/*VARARGS1*/
-void croak(pat,a1,a2,a3,a4)
-char *pat;
-long a1, a2, a3, a4;
+#ifdef I_STDARG
+OP *
+die(const char* pat, ...)
+#else
+/*VARARGS0*/
+OP *
+die(pat, va_alist)
+ const char *pat;
+ va_dcl
+#endif
{
- char *tmps;
+ va_list args;
char *message;
+ I32 oldrunlevel = runlevel;
+ int was_in_eval = in_eval;
HV *stash;
GV *gv;
CV *cv;
- message = mess(pat,a1,a2,a3,a4);
+ /* We have to switch back to mainstack or die_where may try to pop
+ * the eval block from the wrong stack if die is being called from a
+ * signal handler. - dkindred@cs.cmu.edu */
+ if (curstack != mainstack) {
+ dSP;
+ SWITCHSTACK(curstack, mainstack);
+ }
+
+#ifdef I_STDARG
+ va_start(args, pat);
+#else
+ va_start(args);
+#endif
+ message = mess(pat, &args);
+ va_end(args);
+
if (diehook) {
+ /* sv_2cv might call croak() */
SV *olddiehook = diehook;
- diehook = Nullsv; /* sv_2cv might call croak() */
+ ENTER;
+ SAVESPTR(diehook);
+ diehook = Nullsv;
cv = sv_2cv(olddiehook, &stash, &gv, 0);
- diehook = olddiehook;
- if (cv && !CvDEPTH(cv)) {
+ LEAVE;
+ if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
dSP;
+ SV *msg;
- PUSHMARK(sp);
- EXTEND(sp, 1);
- PUSHs(sv_2mortal(newSVpv(message,0)));
- PUTBACK;
- perl_call_sv((SV*)cv, G_DISCARD);
- }
- }
- if (in_eval) {
- restartop = die_where(message);
- Siglongjmp(top_env, 3);
- }
- PerlIO_puts(PerlIO_stderr(),message);
- (void)PerlIO_flush(PerlIO_stderr());
- if (e_tmpname) {
- if (e_fp) {
- PerlIO_close(e_fp);
- e_fp = Nullfp;
- }
- (void)UNLINK(e_tmpname);
- Safefree(e_tmpname);
- e_tmpname = Nullch;
- }
- statusvalue = SHIFTSTATUS(statusvalue);
-#ifdef VMS
- my_exit((U32)vaxc$errno?vaxc$errno:errno?errno:statusvalue?statusvalue:SS$_ABORT);
-#else
- my_exit((U32)((errno&255)?errno:((statusvalue&255)?statusvalue:255)));
-#endif
-}
-
-/*VARARGS1*/
-void warn(pat,a1,a2,a3,a4)
-char *pat;
-long a1, a2, a3, a4;
-{
- char *message;
- SV *sv;
- HV *stash;
- GV *gv;
- CV *cv;
+ ENTER;
+ msg = newSVpv(message, 0);
+ SvREADONLY_on(msg);
+ SAVEFREESV(msg);
- message = mess(pat,a1,a2,a3,a4);
- if (warnhook) {
- SV *oldwarnhook = warnhook;
- warnhook = Nullsv; /* sv_2cv might end up calling warn() */
- cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
- warnhook = oldwarnhook;
- if (cv && !CvDEPTH(cv)) {
- dSP;
-
PUSHMARK(sp);
- EXTEND(sp, 1);
- PUSHs(sv_2mortal(newSVpv(message,0)));
+ XPUSHs(msg);
PUTBACK;
perl_call_sv((SV*)cv, G_DISCARD);
- return;
- }
- }
- PerlIO_puts(PerlIO_stderr(),message);
-#ifdef LEAKTEST
- DEBUG_L(xstat());
-#endif
- (void)PerlIO_flush(PerlIO_stderr());
-}
-
-#else /* !defined(I_STDARG) && !defined(I_VARARGS) */
-
-#ifdef I_STDARG
-char *
-mess(char *pat, va_list *args)
-#else
-/*VARARGS0*/
-char *
-mess(pat, args)
- char *pat;
- va_list *args;
-#endif
-{
- char *s;
- char *s_start;
- SV *tmpstr;
- I32 usermess;
-#ifndef HAS_VPRINTF
-#ifdef USE_CHAR_VSPRINTF
- char *vsprintf();
-#else
- I32 vsprintf();
-#endif
-#endif
- s = s_start = buf;
- usermess = strEQ(pat, "%s");
- if (usermess) {
- tmpstr = sv_newmortal();
- sv_setpv(tmpstr, va_arg(*args, char *));
- *s++ = SvPVX(tmpstr)[SvCUR(tmpstr)-1];
- }
- else {
- (void) vsprintf(s,pat,*args);
- s += strlen(s);
- }
- va_end(*args);
-
- if (s[-1] != '\n') {
- if (dirty)
- strcpy(s, " during global destruction.\n");
- else {
- if (curcop->cop_line) {
- (void)sprintf(s," at %s line %ld",
- SvPVX(GvSV(curcop->cop_filegv)), (long)curcop->cop_line);
- s += strlen(s);
- }
- if (GvIO(last_in_gv) && IoLINES(GvIOp(last_in_gv))) {
- bool line_mode = (RsSIMPLE(rs) &&
- SvLEN(rs) == 1 && *SvPVX(rs) == '\n');
- (void)sprintf(s,", <%s> %s %ld",
- last_in_gv == argvgv ? "" : GvNAME(last_in_gv),
- line_mode ? "line" : "chunk",
- (long)IoLINES(GvIOp(last_in_gv)));
- s += strlen(s);
- }
- (void)strcpy(s,".\n");
- s += 2;
+ LEAVE;
}
- if (usermess)
- sv_catpv(tmpstr,buf+1);
}
- if (s - s_start >= sizeof(buf)) { /* Ooops! */
- if (usermess)
- PerlIO_puts(PerlIO_stderr(), SvPVX(tmpstr));
- else
- PerlIO_puts(PerlIO_stderr(), buf);
- PerlIO_puts(PerlIO_stderr(), "panic: message overflow - memory corrupted!\n");
- my_exit(1);
- }
- if (usermess)
- return SvPVX(tmpstr);
- else
- return buf;
+ restartop = die_where(message);
+ if ((!restartop && was_in_eval) || oldrunlevel > 1)
+ JMPENV_JUMP(3);
+ return restartop;
}
#ifdef I_STDARG
void
-croak(char* pat, ...)
+croak(const char* pat, ...)
#else
/*VARARGS0*/
void
message = mess(pat, &args);
va_end(args);
if (diehook) {
+ /* sv_2cv might call croak() */
SV *olddiehook = diehook;
- diehook = Nullsv; /* sv_2cv might call croak() */
+ ENTER;
+ SAVESPTR(diehook);
+ diehook = Nullsv;
cv = sv_2cv(olddiehook, &stash, &gv, 0);
- diehook = olddiehook;
- if (cv && !CvDEPTH(cv)) {
+ LEAVE;
+ if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
dSP;
+ SV *msg;
+
+ ENTER;
+ msg = newSVpv(message, 0);
+ SvREADONLY_on(msg);
+ SAVEFREESV(msg);
PUSHMARK(sp);
- EXTEND(sp, 1);
- PUSHs(sv_2mortal(newSVpv(message,0)));
+ XPUSHs(msg);
PUTBACK;
perl_call_sv((SV*)cv, G_DISCARD);
+
+ LEAVE;
}
}
if (in_eval) {
restartop = die_where(message);
- Siglongjmp(top_env, 3);
+ JMPENV_JUMP(3);
}
PerlIO_puts(PerlIO_stderr(),message);
(void)PerlIO_flush(PerlIO_stderr());
- if (e_tmpname) {
- if (e_fp) {
- PerlIO_close(e_fp);
- e_fp = Nullfp;
- }
- (void)UNLINK(e_tmpname);
- Safefree(e_tmpname);
- e_tmpname = Nullch;
- }
- statusvalue = SHIFTSTATUS(statusvalue);
-#ifdef VMS
- my_exit((U32)(vaxc$errno?vaxc$errno:(statusvalue?statusvalue:44)));
-#else
- my_exit((U32)((errno&255)?errno:((statusvalue&255)?statusvalue:255)));
-#endif
+ my_failure_exit();
}
void
#ifdef I_STDARG
-warn(char* pat,...)
+warn(const char* pat,...)
#else
/*VARARGS0*/
warn(pat,va_alist)
- char *pat;
+ const char *pat;
va_dcl
#endif
{
va_end(args);
if (warnhook) {
+ /* sv_2cv might call warn() */
SV *oldwarnhook = warnhook;
- warnhook = Nullsv; /* sv_2cv might end up calling warn() */
+ ENTER;
+ SAVESPTR(warnhook);
+ warnhook = Nullsv;
cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
- warnhook = oldwarnhook;
- if (cv && !CvDEPTH(cv)) {
+ LEAVE;
+ if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
dSP;
+ SV *msg;
+
+ ENTER;
+ msg = newSVpv(message, 0);
+ SvREADONLY_on(msg);
+ SAVEFREESV(msg);
PUSHMARK(sp);
- EXTEND(sp, 1);
- PUSHs(sv_2mortal(newSVpv(message,0)));
+ XPUSHs(msg);
PUTBACK;
perl_call_sv((SV*)cv, G_DISCARD);
+
+ LEAVE;
return;
}
}
#endif
(void)PerlIO_flush(PerlIO_stderr());
}
-#endif /* !defined(I_STDARG) && !defined(I_VARARGS) */
#ifndef VMS /* VMS' my_setenv() is in VMS.c */
+#ifndef WIN32
void
my_setenv(nam,val)
char *nam, *val;
environ = tmpenv; /* tell exec where it is now */
}
if (!val) {
+ Safefree(environ[i]);
while (environ[i]) {
environ[i] = environ[i+1];
i++;
#endif /* MSDOS */
}
+#else /* if WIN32 */
+
+void
+my_setenv(nam,val)
+char *nam, *val;
+{
+
+#ifdef USE_WIN32_RTL_ENV
+
+ register char *envstr;
+ STRLEN namlen = strlen(nam);
+ STRLEN vallen;
+ char *oldstr = environ[setenv_getix(nam)];
+
+ /* putenv() has totally broken semantics in both the Borland
+ * and Microsoft CRTLs. They either store the passed pointer in
+ * the environment without making a copy, or make a copy and don't
+ * free it. And on top of that, they dont free() old entries that
+ * are being replaced/deleted. This means the caller must
+ * free any old entries somehow, or we end up with a memory
+ * leak every time my_setenv() is called. One might think
+ * one could directly manipulate environ[], like the UNIX code
+ * above, but direct changes to environ are not allowed when
+ * calling putenv(), since the RTLs maintain an internal
+ * *copy* of environ[]. Bad, bad, *bad* stink.
+ * GSAR 97-06-07
+ */
+
+ if (!val) {
+ if (!oldstr)
+ return;
+ val = "";
+ vallen = 0;
+ }
+ else
+ vallen = strlen(val);
+ New(904, envstr, namlen + vallen + 3, char);
+ (void)sprintf(envstr,"%s=%s",nam,val);
+ (void)putenv(envstr);
+ if (oldstr)
+ Safefree(oldstr);
+#ifdef _MSC_VER
+ Safefree(envstr); /* MSVCRT leaks without this */
+#endif
+
+#else /* !USE_WIN32_RTL_ENV */
+
+ /* The sane way to deal with the environment.
+ * Has these advantages over putenv() & co.:
+ * * enables us to store a truly empty value in the
+ * environment (like in UNIX).
+ * * we don't have to deal with RTL globals, bugs and leaks.
+ * * Much faster.
+ * Why you may want to enable USE_WIN32_RTL_ENV:
+ * * environ[] and RTL functions will not reflect changes,
+ * which might be an issue if extensions want to access
+ * the env. via RTL. This cuts both ways, since RTL will
+ * not see changes made by extensions that call the Win32
+ * functions directly, either.
+ * GSAR 97-06-07
+ */
+ SetEnvironmentVariable(nam,val);
+
+#endif
+}
+
+#endif /* WIN32 */
+
I32
setenv_getix(nam)
char *nam;
register I32 i, len = strlen(nam);
for (i = 0; environ[i]; i++) {
- if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
+ if (
+#ifdef WIN32
+ strnicmp(environ[i],nam,len) == 0
+#else
+ strnEQ(environ[i],nam,len)
+#endif
+ && environ[i][len] == '=')
break; /* strnEQ must come first to avoid */
} /* potential SEGV's */
return i;
}
+
#endif /* !VMS */
#ifdef UNLINK_ALL_VERSIONS
}
#endif
+#ifndef HAS_MEMSET
+void *
+my_memset(loc,ch,len)
+register char *loc;
+register I32 ch;
+register I32 len;
+{
+ char *retval = loc;
+
+ while (len--)
+ *loc++ = ch;
+ return retval;
+}
+#endif
+
#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
char *
my_bzero(loc,len)
}
#endif
-#ifndef HAS_MEMCMP
+#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
I32
my_memcmp(s1,s2,len)
-register unsigned char *s1;
-register unsigned char *s2;
+char *s1;
+char *s2;
register I32 len;
{
+ register U8 *a = (U8 *)s1;
+ register U8 *b = (U8 *)s2;
register I32 tmp;
while (len--) {
- if (tmp = *s1++ - *s2++)
+ if (tmp = *a++ - *b++)
return tmp;
}
return 0;
}
-#endif /* HAS_MEMCMP */
+#endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
#if defined(I_STDARG) || defined(I_VARARGS)
#ifndef HAS_VPRINTF
int
#endif
vsprintf(dest, pat, args)
-char *dest, *pat, *args;
+char *dest;
+const char *pat;
+char *args;
{
FILE fakebuf;
VTOH(vtohl,long)
#endif
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) \
- && !defined(VMS) /* VMS' my_popen() is in VMS.c, same with OS/2. */
+ /* VMS' my_popen() is in VMS.c, same with OS/2. */
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS)
PerlIO *
my_popen(cmd,mode)
char *cmd;
register I32 this, that;
register I32 pid;
SV *sv;
- I32 doexec =
-#ifdef AMIGAOS
- 1;
-#else
- strNE(cmd,"-");
-#endif
+ I32 doexec = strNE(cmd,"-");
#ifdef OS2
if (doexec) {
}
/*SUPPRESS 560*/
if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
- sv_setiv(GvSV(tmpgv),(I32)getpid());
+ sv_setiv(GvSV(tmpgv), (IV)getpid());
forkprocess = 0;
hv_clear(pidstatus); /* we have no children */
return Nullfp;
close(newfd);
return fcntl(oldfd, F_DUPFD, newfd);
#else
- int fdtmp[256];
+#define DUP2_MAX_FDS 256
+ int fdtmp[DUP2_MAX_FDS];
I32 fdx = 0;
int fd;
if (oldfd == newfd)
return oldfd;
close(newfd);
- while ((fd = dup(oldfd)) != newfd && fd >= 0) /* good enough for low fd's */
+ /* good enough for low fd's... */
+ while ((fd = dup(oldfd)) != newfd && fd >= 0) {
+ if (fdx >= DUP2_MAX_FDS) {
+ close(fd);
+ fd = -1;
+ break;
+ }
fdtmp[fdx++] = fd;
+ }
while (fdx > 0)
close(fdtmp[--fdx]);
return fd;
}
#endif
+
#ifdef HAS_SIGACTION
-Sighandler_t rsignal(signo,handler)
+Sighandler_t
+rsignal(signo, handler)
int signo;
Sighandler_t handler;
{
- struct sigaction act,oact;
-
+ struct sigaction act, oact;
+
act.sa_handler = handler;
sigemptyset(&act.sa_mask);
act.sa_flags = 0;
#ifdef SA_RESTART
act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
#endif
- if (sigaction(signo, &act, &oact) < 0)
- return(SIG_ERR);
+ if (sigaction(signo, &act, &oact) == -1)
+ return SIG_ERR;
else
- return(oact.sa_handler);
+ return oact.sa_handler;
}
-int rsignalsave(signo, handler, save)
+Sighandler_t
+rsignal_state(signo)
+int signo;
+{
+ struct sigaction oact;
+
+ if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
+ return SIG_ERR;
+ else
+ return oact.sa_handler;
+}
+
+int
+rsignal_save(signo, handler, save)
int signo;
Sighandler_t handler;
Sigsave_t *save;
{
struct sigaction act;
-
+
act.sa_handler = handler;
sigemptyset(&act.sa_mask);
act.sa_flags = 0;
return sigaction(signo, &act, save);
}
-int rsignalrestore(signo, save)
+int
+rsignal_restore(signo, save)
int signo;
Sigsave_t *save;
{
- return sigaction(signo, save, 0);
+ return sigaction(signo, save, (struct sigaction *)NULL);
}
-Sighandler_t rsignalstate(signo)
+#else /* !HAS_SIGACTION */
+
+Sighandler_t
+rsignal(signo, handler)
int signo;
+Sighandler_t handler;
{
- struct sigaction oact;
- if (sigaction(signo, 0, &oact)<0)
- return (SIG_ERR);
- else
- return (oact.sa_handler);
+ return signal(signo, handler);
}
-#else
-
static int sig_trapped;
static
-Signal_t sig_trap(signo)
+Signal_t
+sig_trap(signo)
int signo;
{
sig_trapped++;
}
-Sighandler_t rsignalstate(signo)
+Sighandler_t
+rsignal_state(signo)
int signo;
{
Sighandler_t oldsig;
- sig_trapped=0;
+
+ sig_trapped = 0;
oldsig = signal(signo, sig_trap);
signal(signo, oldsig);
if (sig_trapped)
- kill(getpid(),signo);
-
+ kill(getpid(), signo);
return oldsig;
}
-Sighandler_t rsignal(signo,handler)
-int signo;
-Sighandler_t handler;
-{
- return signal(signo,handler);
-}
-
-int rsignalsave(signo, handler, save)
+int
+rsignal_save(signo, handler, save)
int signo;
Sighandler_t handler;
Sigsave_t *save;
{
- *save = signal(signo,handler);
+ *save = signal(signo, handler);
return (*save == SIG_ERR) ? -1 : 0;
}
-int rsignalrestore(signo, save)
+int
+rsignal_restore(signo, save)
int signo;
Sigsave_t *save;
{
return (signal(signo, *save) == SIG_ERR) ? -1 : 0;
}
-#endif
-
+#endif /* !HAS_SIGACTION */
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) \
- && !defined(VMS) /* VMS' my_popen() is in VMS.c */
+ /* VMS' my_pclose() is in VMS.c; same with OS/2 */
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS)
I32
my_pclose(ptr)
PerlIO *ptr;
int status;
SV **svp;
int pid;
+ bool close_failed;
+ int saved_errno;
+#ifdef VMS
+ int saved_vaxc_errno;
+#endif
svp = av_fetch(fdpid,PerlIO_fileno(ptr),TRUE);
pid = (int)SvIVX(*svp);
return my_syspclose(ptr);
}
#endif
- PerlIO_close(ptr);
+ if ((close_failed = (PerlIO_close(ptr) == EOF))) {
+ saved_errno = errno;
+#ifdef VMS
+ saved_vaxc_errno = vaxc$errno;
+#endif
+ }
#ifdef UTS
if(kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
#endif
- rsignalsave(SIGHUP, SIG_IGN, &hstat);
- rsignalsave(SIGINT, SIG_IGN, &istat);
- rsignalsave(SIGQUIT, SIG_IGN, &qstat);
+ rsignal_save(SIGHUP, SIG_IGN, &hstat);
+ rsignal_save(SIGINT, SIG_IGN, &istat);
+ rsignal_save(SIGQUIT, SIG_IGN, &qstat);
do {
pid = wait4pid(pid, &status, 0);
} while (pid == -1 && errno == EINTR);
- rsignalrestore(SIGHUP, &hstat);
- rsignalrestore(SIGINT, &istat);
- rsignalrestore(SIGQUIT, &qstat);
- return(pid < 0 ? pid : status);
+ rsignal_restore(SIGHUP, &hstat);
+ rsignal_restore(SIGINT, &istat);
+ rsignal_restore(SIGQUIT, &qstat);
+ if (close_failed) {
+ SETERRNO(saved_errno, saved_vaxc_errno);
+ return -1;
+ }
+ return(pid < 0 ? pid : status == 0 ? 0 : (errno = 0, status));
}
#endif /* !DOSISH */
{
SV *sv;
SV** svp;
- char spid[16];
+ char spid[TYPE_CHARS(int)];
if (!pid)
return -1;
int status;
{
register SV *sv;
- char spid[16];
+ char spid[TYPE_CHARS(int)];
sprintf(spid, "%d", pid);
sv = *hv_fetch(pidstatus,spid,strlen(spid),TRUE);
char *fb = strrchr(b,'/');
struct stat tmpstatbuf1;
struct stat tmpstatbuf2;
-#ifndef MAXPATHLEN
-#define MAXPATHLEN 1024
-#endif
- char tmpbuf[MAXPATHLEN+1];
+ SV *tmpsv = sv_newmortal();
if (fa)
fa++;
if (strNE(a,b))
return FALSE;
if (fa == a)
- strcpy(tmpbuf,".");
+ sv_setpv(tmpsv, ".");
else
- strncpy(tmpbuf, a, fa - a);
- if (Stat(tmpbuf, &tmpstatbuf1) < 0)
+ sv_setpvn(tmpsv, a, fa - a);
+ if (Stat(SvPVX(tmpsv), &tmpstatbuf1) < 0)
return FALSE;
if (fb == b)
- strcpy(tmpbuf,".");
+ sv_setpv(tmpsv, ".");
else
- strncpy(tmpbuf, b, fb - b);
- if (Stat(tmpbuf, &tmpstatbuf2) < 0)
+ sv_setpvn(tmpsv, b, fb - b);
+ if (Stat(SvPVX(tmpsv), &tmpstatbuf2) < 0)
return FALSE;
return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
return retval;
}
-unsigned long
+UV
scan_hex(start, len, retlen)
char *start;
I32 len;
projects / p5sagit/p5-mst-13.2.git / blobdiff