more for Devel::SelfStubber

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

diff --git a/util.c b/util.c
index 542d0dd..52872a8 100644 (file)
--- a/util.c
+++ b/util.c
@@ -4040,11 +4040,12 @@ Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op)
        op == OP_LEAVEWRITE ? "write" :         /* "write exit" not nice */
        PL_op_desc[op];
     char *pars = OP_IS_FILETEST(op) ? "" : "()";
-    char *type = OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET) ?
+    char *type = OP_IS_SOCKET(op) ||
+                 (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ?
                      "socket" : "filehandle";
     char *name = NULL;
 
-    if (io && IoTYPE(io) == IoTYPE_CLOSED) {
+    if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
        vile = "closed";
        warn_type = WARN_CLOSED;
     }
@@ -4078,7 +4079,7 @@ Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op)
     else {
        Perl_warner(aTHX_ warn_type,
                    "%s%s on %s %s", func, pars, vile, type);
-       if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
+       if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
            Perl_warner(aTHX_ warn_type,
                        "\t(Are you trying to call %s%s on dirhandle?)\n",
                        func, pars);
@@ -4125,16 +4126,6 @@ Perl_ebcdic_control(pTHX_ int ch)
 }
 #endif
 
-#ifdef HAS_TZNAME
-#  if !defined(WIN32) && !defined(__CYGWIN__)
-extern char *tzname[];
-#  endif
-#else
-#if !defined(WIN32) || (defined(__MINGW32__) && !defined(tzname))
-char *tzname[] = { "" , "" };
-#endif
-#endif
-
 /* XXX struct tm on some systems (SunOS4/BSD) contains extra (non POSIX)
  * fields for which we don't have Configure support yet:
  *   char *tm_zone;   -- abbreviation of timezone name
@@ -4156,7 +4147,7 @@ char *tzname[] = { "" , "" };
 #endif
 
 void
-init_tm(struct tm *ptm)                /* see mktime, strftime and asctime     */
+Perl_init_tm(pTHX_ struct tm *ptm)     /* see mktime, strftime and asctime */
 {
 #ifdef STRUCT_TM_HASZONE
     Time_t now;
@@ -4170,7 +4161,7 @@ init_tm(struct tm *ptm)           /* see mktime, strftime and asctime     */
  * semantics (and overhead) of mktime().
  */
 void
-mini_mktime(struct tm *ptm)
+Perl_mini_mktime(pTHX_ struct tm *ptm)
 {
     int yearday;
     int secs;
@@ -4361,3 +4352,69 @@ mini_mktime(struct tm *ptm)
     if ((unsigned)ptm->tm_wday > 6)
        ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
 }
+
+char *
+Perl_my_strftime(pTHX_ char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst)
+{
+#ifdef HAS_STRFTIME
+  char *buf;
+  int buflen;
+  struct tm mytm;
+  int len;
+
+  init_tm(&mytm);      /* XXX workaround - see init_tm() above */
+  mytm.tm_sec = sec;
+  mytm.tm_min = min;
+  mytm.tm_hour = hour;
+  mytm.tm_mday = mday;
+  mytm.tm_mon = mon;
+  mytm.tm_year = year;
+  mytm.tm_wday = wday;
+  mytm.tm_yday = yday;
+  mytm.tm_isdst = isdst;
+  mini_mktime(&mytm);
+  buflen = 64;
+  New(0, buf, buflen, char);
+  len = strftime(buf, buflen, fmt, &mytm);
+  /*
+  ** The following is needed to handle to the situation where 
+  ** tmpbuf overflows.  Basically we want to allocate a buffer
+  ** and try repeatedly.  The reason why it is so complicated
+  ** is that getting a return value of 0 from strftime can indicate
+  ** one of the following:
+  ** 1. buffer overflowed,
+  ** 2. illegal conversion specifier, or
+  ** 3. the format string specifies nothing to be returned(not
+  **     an error).  This could be because format is an empty string
+  **    or it specifies %p that yields an empty string in some locale.
+  ** If there is a better way to make it portable, go ahead by
+  ** all means.
+  */
+  if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
+    return buf;
+  else {
+    /* Possibly buf overflowed - try again with a bigger buf */
+    int     fmtlen = strlen(fmt);
+    int            bufsize = fmtlen + buflen;
+    
+    New(0, buf, bufsize, char);
+    while (buf) {
+      buflen = strftime(buf, bufsize, fmt, &mytm);
+      if (buflen > 0 && buflen < bufsize)
+       break;
+      /* heuristic to prevent out-of-memory errors */
+      if (bufsize > 100*fmtlen) {
+       Safefree(buf);
+       buf = NULL;
+       break;
+      }
+      bufsize *= 2;
+      Renew(buf, bufsize, char);
+    }
+    return buf;
+  }
+#else
+  Perl_croak(aTHX_ "panic: no strftime");
+#endif
+}
+