fix format.POSIXlt(<short TZ>) seg.fault (PR#16685)

git-svn-id: https://svn.r-project.org/R/trunk@70048 00db46b3-68df-0310-9c12-caf00c1e9a41

Author: maechler

doc/NEWS.Rd

@@ -527,9 +527,12 @@
 
       \item \code{withCallingHandler()} now (again) handles warnings
       even during S4 generic's argument evaluation.  (\PR{16111})
-      
-      \item \code{deparse(..., control = "quoteExpressions")} 
+
+      \item \code{deparse(..., control = "quoteExpressions")}
       incorrectly quoted empty expressions.  (\PR{16686})
+
+      \item \code{format()}ting datetime objects (\code{"POSIX[cl]?t"})
+      could segfault or recycle wrongly.  (\PR{16685})
     }
   }
 }

src/library/base/R/datetime.R

@@ -1,7 +1,7 @@
 #  File src/library/base/R/datetime.R
 #  Part of the R package, https://www.R-project.org
 #
-#  Copyright (C) 1995-2015 The R Core Team
+#  Copyright (C) 1995-2016 The R Core Team
 #
 #  This program is free software; you can redistribute it and/or modify
 #  it under the terms of the GNU General Public License as published by
@@ -162,21 +162,22 @@ length.POSIXlt <- function(x) length(x[[1L]])
 format.POSIXlt <- function(x, format = "", usetz = FALSE, ...)
 {
     if(!inherits(x, "POSIXlt")) stop("wrong class")
-    if(format == "") {
+    if(any(f0 <- format == "")) {
         ## need list [ method here.
-        times <- unlist(unclass(x)[1L:3L])
-        secs <- x$sec; secs <- secs[!is.na(secs)]
+	times <- unlist(unclass(x)[1L:3L])[f0]
+	secs <- x$sec[f0]; secs <- secs[!is.na(secs)]
         np <- getOption("digits.secs")
-        if(is.null(np)) np <- 0L else np <- min(6L, np)
+        np <- if(is.null(np)) 0L else min(6L, np)
         if(np >= 1L)
             for (i in seq_len(np)- 1L)
                 if(all( abs(secs - round(secs, i)) < 1e-6 )) {
                     np <- i
                     break
                 }
-        format <- if(all(times[!is.na(times)] == 0)) "%Y-%m-%d"
-        else if(np == 0L) "%Y-%m-%d %H:%M:%S"
-        else paste0("%Y-%m-%d %H:%M:%OS", np)
+	format[f0] <-
+	    if(all(times[!is.na(times)] == 0)) "%Y-%m-%d"
+	    else if(np == 0L) "%Y-%m-%d %H:%M:%S"
+	    else paste0("%Y-%m-%d %H:%M:%OS", np)
     }
     ## <FIXME>
     ## Move names handling to C code eventually ...

src/main/datetime.c

@@ -909,7 +909,12 @@ SEXP attribute_hidden do_formatPOSIXlt(SEXP call, SEXP op, SEXP args, SEXP env)
     if(n > 0) N = (m > n) ? m:n; else N = 0;
     PROTECT(ans = allocVector(STRSXP, N));
     char tm_zone[20];
-    Rboolean have_zone = LENGTH(x) >= 10 && LENGTH(VECTOR_ELT(x, 9)) == n;
+#ifdef HAVE_TM_GMTOFF
+    Rboolean have_zone = LENGTH(x) >= 11 && XLENGTH(VECTOR_ELT(x, 9)) == n &&
+	XLENGTH(VECTOR_ELT(x, 10)) == n;
+#else
+    Rboolean have_zone = LENGTH(x) >= 10 && XLENGTH(VECTOR_ELT(x, 9)) == n;
+#endif
     for(R_xlen_t i = 0; i < N; i++) {
 	double secs = REAL(VECTOR_ELT(x, 0))[i%nlen[0]], fsecs = floor(secs);
 	// avoid (int) NAN
@@ -923,7 +928,7 @@ SEXP attribute_hidden do_formatPOSIXlt(SEXP call, SEXP op, SEXP args, SEXP env)
 	tm.tm_yday  = INTEGER(VECTOR_ELT(x, 7))[i%nlen[7]];
 	tm.tm_isdst = INTEGER(VECTOR_ELT(x, 8))[i%nlen[8]];
 	if(have_zone) {
-	    strncpy(tm_zone, CHAR(STRING_ELT(VECTOR_ELT(x, 9), i)), 20);
+	    strncpy(tm_zone, CHAR(STRING_ELT(VECTOR_ELT(x, 9), i%n)), 20);
 	    tm_zone[20 - 1] = '\0';
 #ifdef HAVE_TM_ZONE
 	    tm.tm_zone = tm_zone;
@@ -999,8 +1004,8 @@ SEXP attribute_hidden do_formatPOSIXlt(SEXP call, SEXP op, SEXP args, SEXP env)
 		// Now assume tzone abbreviated name is < 40 bytes,
 		// but they are currently 3 or 4 bytes.
 		if(UseTZ) {
-		    if(LENGTH(x) >= 10) {
-			const char *p = CHAR(STRING_ELT(VECTOR_ELT(x, 9), i));
+		    if(have_zone) {
+			const char *p = CHAR(STRING_ELT(VECTOR_ELT(x, 9), i%n));
 			if(strlen(p)) {strcat(buff, " "); strcat(buff, p);}
 		    } else if(!isNull(tz)) {
 			int ii = 0;

tests/reg-tests-1c.R

@@ -1294,3 +1294,32 @@ stopifnot(all.equal(coef(flm), cf[,"tear"]),
                     cbind(rate = 3:2, additive = 3:4,
                           `rate:additive` = c(3L, 8L))))
 ## dummy.coef() were missing coefficients in R <= 3.2.3
+
+
+## format.POSIXlt() with modified 'zone' or length-2 format
+f0 <- "2016-01-28 01:23:45"; tz0 <- "Europe/Stockholm"
+d2 <- d1 <- rep(as.POSIXlt(f0, tz = tz0), 2)
+f1 <- format(d1, usetz=TRUE)
+d2$zone <- d1$zone[1] # length 1 instead of 2
+f2 <- format(d2, usetz=TRUE)## -> segfault
+f1.2 <- format(as.POSIXlt("2016-01-28 01:23:45"), format=c("%d", "%y"))# segfault
+stopifnot(
+    identical(f1, rep(paste(f0, "CET"), 2)),
+    identical(f2, rep(paste(f0,  tz0 ), 2)),
+    identical(f1.2, c("28", "16"))
+    )
+tims <- seq.POSIXt(as.POSIXct("2016-01-01"),
+		   as.POSIXct("2017-11-11"), by = as.difftime(pi, units="weeks"))
+form <- c("%m/%d/%y %H:%M:%S", "", "%Y-%m-%d %H:%M:%S")
+op <- options(warn = 2)# no warnings allowed
+head(rf1 <- format(tims, form)) # recycling was wrong
+head(rf2 <- format(tims, form[c(2,1,3)]))
+stopifnot(identical(rf1[1:3], c("01/01/16 00:00:00", "2016-01-22 23:47:15",
+				"2016-02-13 23:34:30")),
+	  identical(rf2[1:3], c("2016-01-01 00:00:00", "01/22/16 23:47:15",
+				rf1[3])),
+	  nchar(rf1) == rep(c(17,19,19), length = length(rf1)),
+	  nchar(rf2) == rep(c(19,17,19), length = length(rf2)))
+options(op)
+## Wrong-length 'zone' or short 'x' segfaulted -- PR#16685
+## Default 'format' setting sometimes failed for length(format) > 1