#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");
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)
#endif /* USE_LOCALE_NUMERIC */
}
-#ifdef USE_LOCALE_NUMERIC
-
void
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_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 */
+}
/*
#ifdef USE_LOCALE
- char *lc_all = getenv("LC_ALL");
- char *lang = getenv("LANG");
#ifdef USE_LOCALE_CTYPE
- char *lc_ctype = getenv("LC_CTYPE");
char *curctype = NULL;
#endif /* USE_LOCALE_CTYPE */
#ifdef USE_LOCALE_COLLATE
- char *lc_collate = getenv("LC_COLLATE");
char *curcoll = NULL;
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
- char *lc_numeric = getenv("LC_NUMERIC");
char *curnum = NULL;
#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 */
+ }
+
+#else /* !LC_ALL */
#ifdef USE_LOCALE_CTYPE
- if (! (curctype = setlocale(LC_CTYPE, subloc)))
+ if (! (curctype = setlocale(LC_CTYPE, "")))
setlocale_failure = TRUE;
#endif /* USE_LOCALE_CTYPE */
#ifdef USE_LOCALE_COLLATE
- if (! (curcoll = setlocale(LC_COLLATE, subloc)))
+ if (! (curcoll = setlocale(LC_COLLATE, "")))
setlocale_failure = TRUE;
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
- if (! (curnum = setlocale(LC_NUMERIC, subloc)))
+ if (! (curnum = setlocale(LC_NUMERIC, "")))
setlocale_failure = TRUE;
#endif /* USE_LOCALE_NUMERIC */
- if (setlocale_failure && (lc_all || lang)) {
- char *perl_badlang;
+#endif /* LC_ALL */
- if (printwarn > 1 ||
- printwarn &&
- (!(perl_badlang = getenv("PERL_BADLANG")) || atoi(perl_badlang))) {
-
+#endif /* !LOCALE_ENVIRON_REQUIRED */
+
+ if (setlocale_failure) {
+ char *p;
+ bool locwarn = (printwarn > 1 ||
+ printwarn &&
+ (!(p = getenv("PERL_BADLANG")) || atoi(p)));
+
+ if (locwarn) {
+#ifdef LC_ALL
+
+ PerlIO_printf(PerlIO_stderr(),
+ "perl: warning: Setting locale failed.\n");
+
+#else /* !LC_ALL */
+
PerlIO_printf(PerlIO_stderr(),
"perl: warning: Setting locale failed for the categories:\n\t");
#ifdef USE_LOCALE_CTYPE
if (! curctype)
- PerlIO_printf(PerlIO_stderr(), "USE_LOCALE_CTYPE ");
+ PerlIO_printf(PerlIO_stderr(), "LC_CTYPE ");
#endif /* USE_LOCALE_CTYPE */
#ifdef USE_LOCALE_COLLATE
if (! curcoll)
- PerlIO_printf(PerlIO_stderr(), "USE_LOCALE_COLLATE ");
+ PerlIO_printf(PerlIO_stderr(), "LC_COLLATE ");
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
if (! curnum)
- PerlIO_printf(PerlIO_stderr(), "USE_LOCALE_NUMERIC ");
+ PerlIO_printf(PerlIO_stderr(), "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 USE_LOCALE_CTYPE
- if (! curctype)
- PerlIO_printf(PerlIO_stderr(),
- "\tLC_CTYPE = %c%s%c,\n",
- lc_ctype ? '"' : '(',
- lc_ctype ? lc_ctype : "unset",
- lc_ctype ? '"' : ')');
-#endif /* USE_LOCALE_CTYPE */
-#ifdef USE_LOCALE_COLLATE
- if (! curcoll)
- PerlIO_printf(PerlIO_stderr(),
- "\tLC_COLLATE = %c%s%c,\n",
- lc_collate ? '"' : '(',
- lc_collate ? lc_collate : "unset",
- lc_collate ? '"' : ')');
-#endif /* USE_LOCALE_COLLATE */
-#ifdef USE_LOCALE_NUMERIC
- if (! curnum)
- PerlIO_printf(PerlIO_stderr(),
- "\tLC_NUMERIC = %c%s%c,\n",
- lc_numeric ? '"' : '(',
- lc_numeric ? lc_numeric : "unset",
- lc_numeric ? '"' : ')');
-#endif /* USE_LOCALE_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");
+ }
+#ifdef LC_ALL
+
+ if (setlocale(LC_ALL, "C")) {
+ if (locwarn)
+ PerlIO_printf(PerlIO_stderr(),
+ "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;
+ }
-#ifdef LC_ALL
- if (setlocale_failure) {
- PerlIO_printf(PerlIO_stderr(),
- "perl: warning: Falling back to the \"C\" locale.\n");
- if (setlocale(LC_ALL, "C")) {
+#else /* ! LC_ALL */
+
+ if (0
#ifdef USE_LOCALE_CTYPE
- curctype = "C";
+ || !(curctype || setlocale(LC_CTYPE, "C"))
#endif /* USE_LOCALE_CTYPE */
#ifdef USE_LOCALE_COLLATE
- curcoll = "C";
+ || !(curcoll || setlocale(LC_COLLATE, "C"))
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
- curnum = "C";
+ || !(curnum || setlocale(LC_NUMERIC, "C"))
#endif /* USE_LOCALE_NUMERIC */
- }
- else {
+ )
+ {
+ if (locwarn)
PerlIO_printf(PerlIO_stderr(),
- "perl: warning: Failed to fall back to the \"C\" locale.\n");
- ok = -1;
- }
+ "perl: warning: Cannot 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");
+
#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 USE_LOCALE_CTYPE
perl_init_i18nl14n(printwarn)
int printwarn;
{
- perl_init_i18nl10n(printwarn);
+ return perl_init_i18nl10n(printwarn);
}
#ifdef USE_LOCALE_COLLATE
#ifdef I_STDARG
char *
-mess(char *pat, va_list *args)
+mess(const char *pat, va_list *args)
#else
/*VARARGS0*/
char *
mess(pat, args)
- char *pat;
+ const char *pat;
va_list *args;
#endif
{
if (usermess) {
tmpstr = sv_newmortal();
sv_setpv(tmpstr, va_arg(*args, char *));
- *s++ = SvPVX(tmpstr)[SvCUR(tmpstr)-1];
+ *s++ = SvCUR(tmpstr) ? SvPVX(tmpstr)[SvCUR(tmpstr)-1] : ' ';
}
else {
(void) vsprintf(s,pat,*args);
}
va_end(*args);
- if (s[-1] != '\n') {
+ if (!(s > s_start && s[-1] == '\n')) {
if (dirty)
strcpy(s, " during global destruction.\n");
else {
#ifdef I_STDARG
OP *
-die(char* pat, ...)
+die(const char* pat, ...)
#else
/*VARARGS0*/
OP *
die(pat, va_alist)
- char *pat;
+ const char *pat;
va_dcl
#endif
{
message = mess(pat, &args);
va_end(args);
- if (diehook && (cv = sv_2cv(diehook, &stash, &gv, 0)) && !CvDEPTH(cv)) {
- dSP;
- SV *msg = sv_2mortal(newSVpv(message, 0));
+ if (diehook) {
+ /* sv_2cv might call croak() */
+ SV *olddiehook = diehook;
+ ENTER;
+ SAVESPTR(diehook);
+ diehook = Nullsv;
+ cv = sv_2cv(olddiehook, &stash, &gv, 0);
+ LEAVE;
+ if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
+ dSP;
+ SV *msg;
- PUSHMARK(sp);
- EXTEND(sp, 1);
- PUSHs(msg);
- PUTBACK;
- perl_call_sv((SV*)cv, G_DISCARD);
+ ENTER;
+ msg = newSVpv(message, 0);
+ SvREADONLY_on(msg);
+ SAVEFREESV(msg);
- /* It's okay for the __DIE__ hook to modify the message. */
- message = SvPV(msg, na);
+ PUSHMARK(sp);
+ XPUSHs(msg);
+ PUTBACK;
+ perl_call_sv((SV*)cv, G_DISCARD);
+
+ LEAVE;
+ }
}
restartop = die_where(message);
#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 = sv_2mortal(newSVpv(message, 0));
+ SV *msg;
+
+ ENTER;
+ msg = newSVpv(message, 0);
+ SvREADONLY_on(msg);
+ SAVEFREESV(msg);
PUSHMARK(sp);
- EXTEND(sp, 1);
- PUSHs(msg);
+ XPUSHs(msg);
PUTBACK;
perl_call_sv((SV*)cv, G_DISCARD);
- /* It's okay for the __DIE__ hook to modify the message. */
- message = SvPV(msg, na);
+ LEAVE;
}
}
if (in_eval) {
}
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;
}
}
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) {
#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;
return retval;
}
-unsigned long
+UV
scan_hex(start, len, retlen)
char *start;
I32 len;
projects / p5sagit/p5-mst-13.2.git / blobdiff