Clean up and document API for hashes

[p5sagit/p5-mst-13.2.git] / util.c

diff --git a/util.c b/util.c
index 84c5573..c93663c 100644 (file)
--- a/util.c
+++ b/util.c
@@ -548,24 +548,60 @@ perl_init_i18nl10n(printwarn)
 
 #ifdef USE_LOCALE
 
-#ifdef LC_ALL
-    char *lc_all     = getenv("LC_ALL");
-#endif /* LC_ALL */
 #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;
 
+#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
+    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, ""))
@@ -599,6 +635,8 @@ perl_init_i18nl10n(printwarn)
 
 #endif /* LC_ALL */
 
+#endif /* !LOCALE_ENVIRON_REQUIRED */
+
     if (setlocale_failure) {
        char *p;
        bool locwarn = (printwarn > 1 || 
@@ -634,13 +672,11 @@ perl_init_i18nl10n(printwarn)
            PerlIO_printf(PerlIO_stderr(),
                "perl: warning: Please check that your locale settings:\n");
 
-#ifdef LC_ALL
            PerlIO_printf(PerlIO_stderr(),
                          "\tLC_ALL = %c%s%c,\n",
                          lc_all ? '"' : '(',
                          lc_all ? lc_all : "unset",
                          lc_all ? '"' : ')');
-#endif /* LC_ALL */
 
            {
              char **e;
@@ -1063,7 +1099,7 @@ mess(pat, args)
     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);
@@ -1145,18 +1181,30 @@ die(pat, va_alist)
     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;
+
+           ENTER;
+           msg = newSVpv(message, 0);
+           SvREADONLY_on(msg);
+           SAVEFREESV(msg);
 
-       PUSHMARK(sp);
-       EXTEND(sp, 1);
-       PUSHs(msg);
-       PUTBACK;
-       perl_call_sv((SV*)cv, G_DISCARD);
+           PUSHMARK(sp);
+           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;
+       }
     }
 
     restartop = die_where(message);
@@ -1190,22 +1238,28 @@ croak(pat, va_alist)
     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) {
@@ -1214,21 +1268,7 @@ croak(pat, va_alist)
     }
     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
@@ -1256,18 +1296,28 @@ warn(pat,va_alist)
     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;
        }
     }
@@ -1601,12 +1651,7 @@ char     *mode;
     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) {