#  File src/library/base/R/datetime.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2025 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
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  A copy of the GNU General Public License is available at
#  https://www.R-project.org/Licenses/

Sys.time <- function() .POSIXct(.Internal(Sys.time()))

### Extensively rewritten for R 3.4.4
### There is no portable way to find the system timezone by location.
### For some ideas (not all accurate) see
### https://stackoverflow.com/questions/3118582/how-do-i-find-the-current-system-timezone

### See http://mm.icann.org/pipermail/tz/2017-December/025617.html for
### why you cannot deduce the timezone name from current abbreviations
### and offset from UTC -- cf Europe/Dublin and Europe/London which
### (despite the GB-Eire alias) have a different history including of
### DST in 1971.

### Will be called from C startup code for internal tzcode as Sys.timezone()
### For bootstrapping, it must be simple if TZ is set.
Sys.timezone <- function(location = TRUE)
{
    if(!location)
        .Deprecated(msg = "Sys.timezone(location = FALSE) is defunct and ignored")

    ## caching added in 3.5.0
    if(!is.na(tz <- get0(".sys.timezone", baseenv(), mode = "character",
                         inherits = FALSE, ifnotfound = NA_character_)))
        return(tz)

    cacheIt <- function(tz) {
        unlockBinding(".sys.timezone", baseenv())
        assign(".sys.timezone", tz, baseenv())
        lockBinding(".sys.timezone", baseenv())
    }

    ## Many Unix set TZ, e.g. Solaris and AIX.
    ## For Solaris the system setting is a line in /etc/TIMEZONE
    tz <- Sys.getenv("TZ")
    if(nzchar(tz)) return(tz)
    if(.Platform$OS.type == "windows") return(.Internal(tzone_name()))

    if(!nzchar(Sys.getenv("TZDIR")) && grepl("darwin", R.Version()$os) &&
       dir.exists(zp <-file.path(R.home("share"), "zoneinfo")))  {
        ## On macOS, have choice of system or internal zoneinfo
        ## so chose system if newer.
        veri <- tryCatch(readLines(file.path(zp, "VERSION")),             error = \(e)e)
        vers <- tryCatch(readLines("/var/db/timezone/zoneinfo/+VERSION"), error = \(e)e)
        if(!inherits(veri, "error") && !inherits(vers, "error") && vers != veri) {
            yri <- substr(veri, 1L, 4L); sufi <- substr(veri, 5, 5)
            yrs <- substr(vers, 1L, 4L); sufs <- substr(vers, 5, 5)
            if (yrs > yri || (yrs == yri && sufs > sufi))
                Sys.setenv(TZDIR = "macOS")
        }
    }
    if(Sys.getenv("TZDIR") == "macOS" && grepl("darwin", R.Version()$os))
        Sys.setenv(TZDIR = "/var/db/timezone/zoneinfo")


    ## At least tzcode and glibc respect TZDIR.
    ## glibc uses $(datadir)/zoneinfo
    ## musl does not mention it, just reads /etc/localtime (as from 1.1.13)
    ##   (A search of /usr/share/zoneinfo, /share/zoneinfo, /etc/zoneinfo
    ##   is hardcoded in musl.)
    ## Systems using --with-internal-tzcode will use the database at
    ## file.path(R.home("share"), "zoneinfo"), but it is a reasonable
    ## assumption that /etc/localtime is based on the system database.
    tzdir <- Sys.getenv("TZDIR")
    if(nzchar(tzdir) && !dir.exists(tzdir)) tzdir <- ""
    if(!nzchar(tzdir)) { ## See comments in OlsonNames
        if(dir.exists(tzdir <- "/usr/share/zoneinfo") ||
           dir.exists(tzdir <- "/share/zoneinfo") ||
           dir.exists(tzdir <- "/usr/share/lib/zoneinfo") ||
           dir.exists(tzdir <- "/usr/lib/zoneinfo") ||
           dir.exists(tzdir <- "/usr/local/etc/zoneinfo") ||
           dir.exists(tzdir <- "/etc/zoneinfo") ||
           dir.exists(tzdir <- "/usr/etc/zoneinfo")) {
        } else tzdir <- ""
    }

    ## First try timedatectl: should work on any modern (post 2015)
    ## glibc-based Linux as part of systemd (and probably nowhere else)
    ## https://www.freedesktop.org/software/systemd/man/sd_booted.html
    ## systemd is (in 2025) an optional part of musl
    if (dir.exists("/run/systemd/system") && nzchar(Sys.which("timedatectl"))) {
        inf <- system("timedatectl", intern = TRUE)
        ## typical format:
        ## "       Time zone: Europe/London (GMT, +0000)"
        ## "       Time zone: Europe/Vienna (CET, +0100)"
        lines <- grep("Time zone: ", inf)
        if (length(lines)) {
            tz <- sub(" .*", "", sub(" *Time zone: ", "", inf[lines[1L]]))
            ## quick sanity check
            if(nzchar(tzdir)) {
                if(file.exists(file.path(tzdir, tz))) {
                    cacheIt(tz)
                    return(tz)
                } else
                    warning(sprintf("%s indicates the non-existent timezone name %s",
                                    sQuote("timedatectl"), sQuote(tz)),
                            call. = FALSE, immediate. = TRUE, domain = NA)
            } else {
                cacheIt(tz)
                return(tz)
            }
        }
    }

    ## Debian/Ubuntu Linux do things differently, so try that next.
    ## Derived loosely from PR#17186
    ## As the Java sources say
    ##
    ## 'There's no spec of the file format available. This parsing
    ## assumes that there's one line of an Olson tzid followed by a
    ## '\n', no leading or trailing spaces, no comments.'
    ##
    ## but we do trim whitespace and do a sanity check (Java does not)
    if (grepl("linux", R.Version()$platform, ignore.case = TRUE) &&
        file.exists("/etc/timezone")) {
        tz0 <- try(readLines("/etc/timezone"))
        if(!inherits(tz0, "try-error") && length(tz0) == 1L) {
            tz <- trimws(tz0)
            ## quick sanity check
            if(nzchar(tzdir)) {
                if(file.exists(file.path(tzdir, tz))) {
                    cacheIt(tz)
                    return(tz)
                } else
                    warning(sprintf("%s indicates the non-existent timezone name %s",
                                    sQuote("/etc/timezone"), sQuote(tz)),
                            call. = FALSE, immediate. = TRUE, domain = NA)
            } else {
                cacheIt(tz)
                return(tz)
            }
        }
    }

    ## non-Debian Linux (if not covered above), macOS, *BSD, ...
    ## According to the glibc's (at least 2.26)
    ##   manual/time.texi, it can be configured to use
    ##   /etc/localtime or /usr/local/etc/localtime
    ##  (and in fact can be overridden when glibc is installed)
    ## This should be a symlink,
    ##   but people including Debian have copied files instead.
    ## 'man 5 localtime' says (even on Debian)
    ##  'Because the timezone identifier is extracted from the symlink
    ##   target name of /etc/localtime, this file may not be a normal
    ##   file or hardlink.'
    ## tzcode mentions /usr/local/etc/zoneinfo/localtime
    ##  as the 'local time zone file' (not seen in the wild)
    ## man tzset on macOS (from BSD) mentions /var/db/timezone/localtime
    if ((file.exists(lt0 <- "/etc/localtime") ||
         file.exists(lt0 <- "/usr/local/etc/localtime") ||
         file.exists(lt0 <- "/usr/local/etc/zoneinfo/localtime") ||
         file.exists(lt0 <- "/var/db/timezone/localtime")) &&
        !is.na(lt <- Sys.readlink(lt0)) && nzchar(lt)) { # so it is a symlink
        tz <- NA_character_
        ## glibc and macOS < 10.13 this is a link into /usr/share/zoneinfo
        ## (Debian Etch and later replaced it with a copy,
        ## as have RHEL/Centos 6.x.)
        ## macOS 10.13.0 is a link into /usr/share/zoneinfo.default
        ## macOS 10.13.[12] is a link into /var/db/timezone/zoneinfo,
        ##  itself a link (with target different on different machines)
        if ((nzchar(tzdir) && grepl(pat <- paste0("^", tzdir, "/"), lt)) ||
            grepl(pat <- "^/usr/share/zoneinfo.default/", lt))
            tz <- sub(pat, "", lt)
        ## all the locations listed for OlsonNames end in zoneinfo
        else if(grepl(pat <- ".*/zoneinfo/(.*)", lt))
            tz <- sub(pat, "\\1", lt)
        if(!is.na(tz)) {
            cacheIt(tz)
            return(tz)
        } else
            message("unable to deduce timezone name from ", sQuote(lt))
    }

    ## Last-gasp (slow, several seconds) fallback: compare a
    ## non-link lt0 to all the files under tzdir (as Java does).
    ## This may match more than one tz file: we don't care which.
    if (nzchar(tzdir) && # we already found lt0
         (is.na(lt <- Sys.readlink(lt0)) || !nzchar(lt))) {
        warning(sprintf("Your system is mis-configured: %s is not a symlink",
                        sQuote(lt0)),
                call. = FALSE, immediate. = TRUE, domain = NA)
        if(nzchar(Sys.which("cmp"))) {
            known <- dir(tzdir, recursive = TRUE)
            for(tz in known) {
                status <- system2("cmp", c("-s", shQuote(lt0),
                                  shQuote(file.path(tzdir, tz))))
                if (status == 0L) {
                    cacheIt(tz)
                    warning(sprintf("It is strongly recommended to set envionment variable TZ to %s (or equivalent)",
                                    sQuote(tz)),
                            call. = FALSE, immediate. = TRUE, domain = NA)
                    return(tz)
                }
            }
            warning(sprintf("%s is not identical to any known timezone file",
                            sQuote(lt0)),
                    call. = FALSE, immediate. = TRUE, domain = NA)
        }
    }

    ## all heuristics have failed, so give up
    NA_character_
}

as.POSIXlt <- function(x, tz = "", ...) UseMethod("as.POSIXlt")

as.POSIXlt.Date <- function(x, tz = "UTC", ...)
    as.POSIXlt(.Internal(Date2POSIXlt(x, tz)), tz = tz)

## ## Moved to packages date and chron.
## as.POSIXlt.date <- as.POSIXlt.dates <- function(x, ...)
##     as.POSIXlt(as.POSIXct(x), ...)

as.POSIXlt.POSIXct <- function(x, tz = "", ...)
{
    if((missing(tz) || is.null(tz)) &&
       !is.null(tzone <- attr(x, "tzone"))) tz <- tzone[1L]
    .Internal(as.POSIXlt(x, tz))
}

as.POSIXlt.factor <- function(x, ...)
{
    y <- as.POSIXlt(as.character(x), ...)
    ## as.character(.) dropping names ===>
    names(y$year) <- names(x)
    y
}

as.POSIXlt.character <-
    function(x, tz = "", format,
             tryFormats = c("%Y-%m-%d %H:%M:%OS",
                            "%Y/%m/%d %H:%M:%OS",
                            "%Y-%m-%d %H:%M",
                            "%Y/%m/%d %H:%M",
                            "%Y-%m-%d",
                            "%Y/%m/%d"), optional = FALSE, ...)
{
    x <- unclass(x) # precaution PR#7826
    if(!missing(format)) {
        res <- strptime(x, format, tz = tz)
        if(nzchar(tz)) attr(res, "tzone") <- tz
        return(res)
    }
    xx <- x[!is.na(x)]
    if (!length(xx)) { # all NA
        res <- strptime(x, "%Y/%m/%d")
        if(nzchar(tz)) attr(res, "tzone") <- tz
        return(res)
    } else
        for(f in tryFormats)
            if(all(!is.na(strptime(xx, f, tz = tz)))) {
                res <- strptime(x, f, tz = tz)
                if(nzchar(tz)) attr(res, "tzone") <- tz
                return(res)
            }
    ## no success :
    if(optional)
        as.POSIXlt.character(rep.int(NA_character_, length(x)), tz=tz)
    else stop("character string is not in a standard unambiguous format")
}

as.POSIXlt.numeric <- function(x, tz = "", origin, ...)
    as.POSIXlt(if(missing(origin)) .POSIXct(x, tz)
               else as.POSIXct(origin, tz = "UTC", ...) + x,
               tz)

as.POSIXlt.default <- function(x, tz = "", optional = FALSE, ...)
{
    if(inherits(x, "POSIXlt"))
        return(if(missing(tz)) x else .POSIXlt(x, tz))
    if(is.null(x)) return(as.POSIXlt.character(character(), tz))
    if(is.logical(x) && all(is.na(x)))
        return(as.POSIXlt(as.POSIXct.default(x), tz = tz))
    if(optional)
        as.POSIXlt.character(rep.int(NA_character_, length(x)), tz=tz)
    else stop(gettextf("do not know how to convert '%s' to class %s",
                       deparse1(substitute(x)),
                       dQuote("POSIXlt")),
              domain = NA)
}


as.POSIXct <- function(x, tz = "", ...) UseMethod("as.POSIXct")

as.POSIXct.Date <- function(x, tz = "UTC", ...) .POSIXct(unclass(x)*86400, tz=tz)
                                        #  \\\ do *not* pass these

## ## Moved to package date
## as.POSIXct.date <- function(x, ...)
## {
##     if(inherits(x, "date")) {
##         x <- (x - 3653) * 86400 # origin 1960-01-01
##         return(.POSIXct(x))
##     } else stop(gettextf("'%s' is not a \"date\" object",
##                          deparse1(substitute(x)) ))
## }

## ## Moved to package chron
## as.POSIXct.dates <- function(x, ...)
## {
##     if(inherits(x, "dates")) {
##         z <- attr(x, "origin")
##         x <- as.numeric(x) * 86400
##         if(length(z) == 3L && is.numeric(z))
##             x  <- x + as.numeric(ISOdate(z[3L], z[1L], z[2L], 0))
##         return(.POSIXct(x))
##     } else stop(gettextf("'%s' is not a \"dates\" object",
##                          deparse1(substitute(x)) ))
## }

as.POSIXct.POSIXlt <- function(x, tz = "", ...)
{
    tzone <- attr(x, "tzone")
    if(missing(tz) && !is.null(tzone)) tz <- tzone[1L]
    y <- .Internal(as.POSIXct(x, tz))
    ## FIXME: already do handling of 'tz' in C code  !?!
    .POSIXct(y, tz)
}

as.POSIXct.numeric <- function(x, tz = "", origin, ...)
    .POSIXct(if(missing(origin)) x else as.POSIXct(origin, tz = "GMT", ...) + x, tz)

as.POSIXct.default <- function(x, tz = "", ...)
{
    if(inherits(x, "POSIXct"))
        return(if(missing(tz)) x else .POSIXct(x, tz))
    if(is.null(x)) return(.POSIXct(integer(), tz))
    if(is.character(x) || is.factor(x))
    return(as.POSIXct(as.POSIXlt(x, tz, ...), tz, ...))
    if(is.logical(x) && all(is.na(x)))
        return(.POSIXct(as.numeric(x), tz))
    stop(gettextf("do not know how to convert '%s' to class %s",
                  deparse1(substitute(x)),
                  dQuote("POSIXct")),
         domain = NA)
}

`length<-.POSIXct` <- function(x, value)
    .POSIXct(NextMethod(), attr(x, "tzone"), oldClass(x))

as.double.POSIXlt <- function(x, ...) as.double(as.POSIXct(x))

## POSIXlt is not primarily a list, but primarily an abstract vector of
## time stamps:
length.POSIXlt <- function(x) max(lengths(unclass(x)))
## keep somewhat in sync with rep.POSIXlt  (further down)
`length<-.POSIXlt` <- function(x, value) {
    r <- lapply(unclass(x), `length<-`, value)
    class(r) <- oldClass(x)
    attr(r, "tzone"      ) <- attr(x, "tzone")# "balanced" vs "filled" :
    attr(r, "balanced") <- if(isTRUE(attr(x, "balanced"))) TRUE else NA
    r
}

## Exists only to update|remove the "balanced"
`$<-.POSIXlt` <- function (x, name, value) {
    r <- NextMethod("$<-")
    class(r) <- oldClass(x)
    attr(r, "tzone"      ) <- attr(x, "tzone")# "balanced" vs "filled" :
    attr(r, "balanced") <- if(isTRUE(attr(x, "balanced")) &&
                                 length(value) == length(x)) NA # "filled" else NULL
    r
}

format.POSIXlt <- function(x, format = "", usetz = FALSE,
                           digits = getOption("digits.secs"), ...)
{
    if(!inherits(x, "POSIXlt")) stop("wrong class")
    nf <- length(format)
    useDig <- function(secs, digits) {
        secs <- secs[is.finite(secs)]
        np <- min(6L, digits)
        if(np >= 1L) # no unnecessary trailing '0'; use trunc() as .Internal() code:
            for (i in seq_len(np)- 1L)
                if(all( abs(secs - trunc(secs*(ti <- 10^i))/ti) < 1e-6 )) {
                    np <- i
                    break
                }
        np
    }
    if(any(f0 <- format == "")) {
        x_ <- if(nf == 1L) x else x[f0]  # any(f0) & nf = 1  ==>  x[f0] = x
        np <- if(!is.null(digits)) useDig(x_$sec, digits) else 0L
        ## need list `[` method here to get 1:3 ~ {sec, min, hour} :
        times <- unlist(unclass(x_)[1L:3L], use.names = FALSE)
        format[f0] <-
            if(all(times[is.finite(times)] == 0)) "%Y-%m-%d"
            else if(np == 0L) "%Y-%m-%d %H:%M:%S"
            else paste0("%Y-%m-%d %H:%M:%OS", np)
    }
    if(!missing(digits) && !is.null(digits) && digits != getOption("digits.secs", 0L) &&
       any(OS. <- grepl("%OS($|[^0-9])", format))) {
        x_ <- if(nf == 1L) x else x[OS.]
        digits <- useDig(x_$sec, digits)
    }
    ## C code in do_formatPOSIXlt()  *does*  recycle  {x, format}  as needed:
    .Internal(format.POSIXlt(x, format, usetz, digits))
}

## prior to 2.9.0 the same as format.POSIXlt.
## now more or less the same as format.POSIXct but also works for Dates.
strftime <- function(x, format = "", tz = "", usetz = FALSE, ...)
    format(as.POSIXlt(x, tz = tz), format = format, usetz = usetz, ...)

strptime <- function(x, format, tz = "")
    .Internal(strptime(if(is.character(x)) x # not losing names(.) here
                       else if(is.object(x)) `names<-`(as.character(x), names(x))
                       else                  `storage.mode<-`(x, "character"),
                       format, tz))


format.POSIXct <- function(x, format = "", tz = "", usetz = FALSE, ...)
{
    if(!inherits(x, "POSIXct")) stop("wrong class")
    ## NB identical(tz, "") is *NOT* the same as missing(tz)
    if(missing(tz) && !is.null(tzone <- attr(x, "tzone"))) tz <- tzone
    structure(format.POSIXlt(as.POSIXlt(x, tz), format, usetz, ...),
              names = names(x))
}

## keep in sync with  print.Date()  in ./dates.R
print.POSIXct <-
print.POSIXlt <- function(x, tz = "", usetz = TRUE, max = NULL,
                          digits = getOption("digits.secs"), ...)
{
    if(is.null(max)) max <- getOption("max.print", 9999L)
    FORM <- if(missing(tz))
             function(z) format(z,        usetz=usetz, digits=digits)
        else function(z) format(z, tz=tz, usetz=usetz, digits=digits)
    if(max < length(x)) {
    print(FORM(x[seq_len(max)]), max=max+1, ...)
    cat(" [ reached 'max' / getOption(\"max.print\") -- omitted",
        length(x) - max, 'entries ]\n')
    } else if(length(x))
    print(FORM(x), max = max, ...)
    else
    cat(class(x)[1L], "of length 0\n")
    invisible(x)
}


summary.POSIXct <- function(object, digits = 15L, ...)
{
    x <- summary.default(unclass(object), digits = digits, ...)
    if(m <- match("NA's", names(x), 0L)) {
        NAs <- as.integer(x[m])
        x <- x[-m]
        attr(x, "NAs") <- NAs
    }
    .POSIXct(x,
             tz = attr(object, "tzone"),
             cl = c("summaryDefault", oldClass(object)))
}

summary.POSIXlt <- function(object, digits = 15, ...)
    summary(as.POSIXct(object), digits = digits, ...)


`+.POSIXt` <- function(e1, e2)
{
    ## need to drop "units" attribute here
    coerceTimeUnit <- function(x)
        as.vector(switch(attr(x,"units"),
                         secs = x, mins = 60*x, hours = 60*60*x,
                         days = 60*60*24*x, weeks = 60*60*24*7*x))

    if (nargs() == 1L) return(e1)
    # only valid if one of e1 and e2 is a scalar/difftime
    if(inherits(e1, "POSIXt") && inherits(e2, "POSIXt"))
        stop("binary '+' is not defined for \"POSIXt\" objects")
    if(inherits(e1, "POSIXlt")) e1 <- as.POSIXct(e1)
    if(inherits(e2, "POSIXlt")) e2 <- as.POSIXct(e2)
    if (inherits(e1, "difftime")) e1 <- coerceTimeUnit(e1)
    if (inherits(e2, "difftime")) e2 <- coerceTimeUnit(e2)
    .POSIXct(unclass(e1) + unclass(e2), .check_tzones(e1, e2))
}

`-.POSIXt` <- function(e1, e2)
{
    ## need to drop "units" attribute here
    coerceTimeUnit <- function(x)
        as.vector(switch(attr(x,"units"),
                         secs = x, mins = 60*x, hours = 60*60*x,
                         days = 60*60*24*x, weeks = 60*60*24*7*x))
    if(!inherits(e1, "POSIXt"))
        stop("can only subtract from \"POSIXt\" objects")
    if (nargs() == 1L) stop("unary '-' is not defined for \"POSIXt\" objects")
    if(inherits(e2, "POSIXt")) return(difftime(e1, e2))
    if (inherits(e2, "difftime")) e2 <- coerceTimeUnit(e2)
    if(!is.null(attr(e2, "class")))
        stop("can only subtract numbers from \"POSIXt\" objects")
    e1 <- as.POSIXct(e1)
    .POSIXct(unclass(e1) - e2, attr(e1, "tzone"))
}

Ops.POSIXt <- function(e1, e2)
{
    if (nargs() == 1L)
        stop(gettextf("unary '%s' not defined for \"POSIXt\" objects",
                      .Generic), domain = NA)
    boolean <- switch(.Generic, "<" = , ">" = , "==" = ,
                      "!=" = , "<=" = , ">=" = TRUE, FALSE)
    if (!boolean)
        stop(gettextf("'%s' not defined for \"POSIXt\" objects", .Generic),
             domain = NA)
    if(inherits(e1, "POSIXlt") || is.character(e1)) e1 <- as.POSIXct(e1)
    if(inherits(e2, "POSIXlt") || is.character(e2)) e2 <- as.POSIXct(e2)
    .check_tzones(e1, e2)
    NextMethod(.Generic)
}

Math.POSIXt <- function (x, ...)
{
    stop(gettextf("'%s' not defined for \"POSIXt\" objects", .Generic),
         domain = NA)
}

.check_tzones <- function(...)
{
    tzs <- unique(vapply(list(...),
                         function(x) {
                             y <- attr(x, "tzone")
                             if(is.null(y)) "" else y[1L]
                         },
                         ""))
    tzs <- tzs[nzchar(tzs)]
    if(length(tzs) > 1L)
        warning("'tzone' attributes are inconsistent")
    if(length(tzs)) tzs[1L] else NULL
}

## NB: 'na.rm' is part of the Summary generic,
## --  but 'finite' is not: argument only of range.default() and these:
Summary.POSIXct <- function (..., na.rm, finite = FALSE)
{
    ok <- switch(.Generic, max = , min = , range = TRUE, FALSE)
    if (!ok)
        stop(gettextf("'%s' not defined for \"POSIXt\" objects", .Generic),
             domain = NA)
    args <- list(...)
    tz <- do.call(.check_tzones, args)
    .POSIXct(NextMethod(.Generic), tz = tz, cl = oldClass(args[[1L]]))
}

Summary.POSIXlt <- function (..., na.rm, finite = FALSE)
{
    ok <- switch(.Generic, max = , min = , range = TRUE, FALSE)
    if (!ok)
        stop(gettextf("'%s' not defined for \"POSIXt\" objects", .Generic),
             domain = NA)
    args <- list(...)
    tz <- do.call(.check_tzones, args)
    args <- lapply(args, as.POSIXct)
    val <- switch(.Generic,
                  max = , min = do.call(.Generic, c(args, na.rm = na.rm)), # not (yet?) finite
                  range =       do.call(range,    c(args, na.rm = na.rm, finite = finite)))
    as.POSIXlt(.POSIXct(val, tz))
}

`[.POSIXct` <-
function(x, ..., drop = TRUE)
    .POSIXct(NextMethod("["), attr(x, "tzone"), oldClass(x))

`[[.POSIXct` <-
function(x, ..., drop = TRUE)
    .POSIXct(NextMethod("[["), attr(x, "tzone"), oldClass(x))

`[<-.POSIXct` <-
function(x, ..., value) {
    if(!length(value)) return(x)
    value <- unclass(as.POSIXct(value))
    .POSIXct(NextMethod(.Generic), attr(x, "tzone"), oldClass(x))
}


## Alternatively use  lapply(*, function(.) .Internal(format.POSIXlt(., digits=0))
## *and* append the fractional seconds ('entirely') ..
as.character.POSIXt <- function(x, # digits after decimal:
                                digits = if(inherits(x, "POSIXlt")) 14L else 6L,
                                OutDec = ".", # *not* depending on options() !
                                ...) {
    if(length(dotn <- ...names()) && "format" %in% dotn)
        warning("as.character(td, ..) no longer obeys a 'format' argument; use format(td, ..) ?")
    if(missing(digits)) force(digits)
    else if(!is.numeric(digits)) stop("'digits' must be numeric, integer valued")
    x <- balancePOSIXlt(as.POSIXlt(x))
    s <- x$sec
    ## to distinguish {NA, 0, non-0}:
    time <- x$hour + x$min + s
    isNA <- is.na(s) & !is.nan(s)
    ok <- is.finite(time)
    r <- character(length(ok))
    if(anyN <- !all(ok)) { # i.e.,  any(!ok)
        r[   !ok &  isNA] <- NA
        i <- !ok & !isNA
        r[i] <- as.character(s[i])
    }
    if(any(ok)) {
        if(anyN) { x <- x[ok]; time <- time[ok] }
        r1 <- sprintf("%d-%02d-%02d", 1900 + x$year, x$mon+1L, x$mday)
        if(any(n0 <- time != 0)) { # add time if not 0
            s <- round(x$sec[n0], digits) # now, assume s >= 0 :
            ## ensure options() do *not* affect as.character():
            if(getOption("OutDec") != OutDec) { op <- options(OutDec = OutDec); on.exit(options(op)) }
            if(getOption("scipen") <= min(digits)) {
                o2 <- options(scipen = max(digits)+1L); on.exit(options(o2), add=TRUE) }
            sch <- paste0(c("","0")[(s < 10) + 1L], as.character(s))
            r1[n0] <- paste(r1[n0], sprintf("%02d:%02d:%s", x$hour[n0], x$min[n0], sch))
        }
        r[ok] <- r1
    }
    r
}


as.data.frame.POSIXct <- as.data.frame.vector

as.list.POSIXct <- function(x, ...)
{
    nms <- names(x)
    names(x) <- NULL
    y <- lapply(unclass(x), .POSIXct, attr(x, "tzone"), oldClass(x))
    names(y) <- nms
    y
}

is.na.POSIXlt       <- function(x) is.na      (as.POSIXct(x))
is.nan.POSIXlt      <- function(x) is.nan     (as.POSIXct(x))
is.finite.POSIXlt   <- function(x) is.finite  (as.POSIXct(x))
is.infinite.POSIXlt <- function(x) is.infinite(as.POSIXct(x))

anyNA.POSIXlt <- function(x, recursive = FALSE)
    anyNA(as.POSIXct(x))

## <FIXME> check the argument validity
## This is documented to remove the timezone (unless all are marked with
## the same).
c.POSIXct <- function(..., recursive = FALSE) {
    x <- lapply(list(...), function(e) unclass(as.POSIXct(e)))
    tzones <- lapply(x, attr, "tzone")
    tz <- if(length(unique(tzones)) == 1L) tzones[[1L]] else NULL
    .POSIXct(c(unlist(x)), tz)
}

## we need conversion to POSIXct as POSIXlt objects can be in different tz.
c.POSIXlt <- function(..., recursive = FALSE) {
    as.POSIXlt(do.call(c, lapply(list(...), as.POSIXct)))
}


ISOdatetime <- function(year, month, day, hour, min, sec, tz = "")
{
    if(min(lengths(list(year, month, day, hour, min, sec), use.names=FALSE)) == 0L)
        .POSIXct(integer(), tz = tz)
    else {
        x <- paste(year, month, day, hour, min, sec, sep = "-")
        as.POSIXct(strptime(x, "%Y-%m-%d-%H-%M-%OS", tz = tz), tz = tz)
    }
}

ISOdate <- function(year, month, day, hour = 12, min = 0, sec = 0, tz = "GMT")
    ISOdatetime(year, month, day, hour, min, sec, tz)

as.matrix.POSIXlt <- function(x, ...)
{
    as.matrix(as.data.frame(unclass(x)), ...)
}

mean.POSIXct <- function (x, ...)
    .POSIXct(mean(unclass(x), ...), attr(x, "tzone"))

mean.POSIXlt <- function (x, ...)
    as.POSIXlt(mean(as.POSIXct(x), ...))

## ----- difftime -----

difftime <-
    function(time1, time2, tz,
             units = c("auto", "secs", "mins", "hours", "days", "weeks"))
{
    if (missing(tz)) {
        time1 <- as.POSIXct(time1)
        time2 <- as.POSIXct(time2)
    } else {
        ## Wishlist PR#14182
        time1 <- as.POSIXct(time1, tz = tz)
        time2 <- as.POSIXct(time2, tz = tz)
    }
    z <- unclass(time1) - unclass(time2)
    attr(z, "tzone") <- NULL # it may get copied from args of `-`
    units <- match.arg(units)
    if(units == "auto")
    units <-
        if(all(is.na(z))) "secs"
        else {
        zz <- min(abs(z), na.rm = TRUE)
        if(!is.finite(zz) || zz < 60) "secs"
        else if(zz < 3600) "mins"
        else if(zz < 86400) "hours"
        else "days"
        }
    switch(units,
           "secs" = .difftime(z, units = "secs"),
           "mins" = .difftime(z/60, units = "mins"),
           "hours"= .difftime(z/3600, units = "hours"),
           "days" = .difftime(z/86400, units = "days"),
           "weeks"= .difftime(z/(7*86400), units = "weeks")
           )
}

## "difftime" constructor
## Martin Maechler, Date: 16 Sep 2002
## Numeric input version Peter Dalgaard, December 2006
as.difftime <- function(tim, format = "%X", units = "auto", tz = "UTC")
{
    if (inherits(tim, "difftime")) return(tim)
    if (is.character(tim)) {
        difftime(strptime(tim, format = format),
                 strptime("0:0:0", format = "%X"), units = units, tz = tz)
    } else {
        if (!is.numeric(tim)) stop("'tim' is not character or numeric")
        nms <- names(tim)
        tim <- as.double(tim)
        names(tim) <- nms
        if (units == "auto") stop("need explicit units for numeric conversion")
        if (!(units %in% c("secs", "mins", "hours", "days", "weeks")))
            stop("invalid units specified")
        .difftime(tim, units = units)
    }
}

### For now, these have only difftime methods, but you never know...
units <- function(x) UseMethod("units")

`units<-` <- function(x, value) UseMethod("units<-")

units.difftime <- function(x) attr(x, "units")

`units<-.difftime` <- function(x, value)
{
    from <- units(x)
    if (from == value) return(x)
    if (!(value %in% c("secs", "mins", "hours", "days", "weeks")))
        stop("invalid units specified")
    sc <- cumprod(c(secs = 1, mins = 60, hours = 60, days = 24, weeks = 7))
    newx <- unclass(x) * as.vector(sc[from]/sc[value])
    .difftime(newx, value)
}

as.double.difftime <- function(x, units = "auto", ...)
{
    if (units != "auto") units(x) <- units
    as.vector(x, "double")
}

as.data.frame.difftime <- as.data.frame.vector

format.difftime <- function(x,..., with.units = TRUE)
{
    y <- if(length(x))
        paste0(format(unclass(x),...), if(with.units) paste0(" ",units(x)))
    else
        character()
    names(y) <- names(x)
    y
}

print.difftime <- function(x, digits = getOption("digits"), ...)
{
    if(!length(x))
        cat(class(x)[1L], "of length 0\n")
    else if(is.array(x) || length(x) > 1L) {
        cat("Time differences in ", attr(x, "units"), "\n", sep = "")
        y <- unclass(x); attr(y, "units") <- NULL
        print(y, digits=digits, ...)
    }
    else
        cat("Time difference of ", format(unclass(x), digits = digits), " ",
            attr(x, "units"), "\n", sep = "")

    invisible(x)
}

`[.difftime` <- function(x, ..., drop = TRUE)
    .difftime(NextMethod("["), attr(x, "units"), oldClass(x))

diff.difftime <- function(x, ...)
    .difftime(NextMethod("diff"), attr(x, "units"), oldClass(x))

Ops.difftime <- function(e1, e2)
{
    coerceTimeUnit <- function(x)
    {
        switch(attr(x, "units"),
               secs = x, mins = 60*x, hours = 60*60*x,
               days = 60*60*24*x, weeks = 60*60*24*7*x)
    }
    if (nargs() == 1L) {
        switch(.Generic, "+" = {}, "-" = {e1[] <- -unclass(e1)},
               stop(gettextf("unary '%s' not defined for \"difftime\" objects",
                             .Generic), domain = NA, call. = FALSE)
               )
        return(e1)
    }
    boolean <- switch(.Generic, "<" = , ">" = , "==" = ,
                      "!=" = , "<=" = , ">=" = TRUE, FALSE)
    if (boolean) {
        ## assume user knows what he/she is doing if not both difftime
        if(inherits(e1, "difftime") && inherits(e2, "difftime")) {
            e1 <- coerceTimeUnit(e1)
            e2 <- coerceTimeUnit(e2)
        }
        NextMethod(.Generic)
    } else if(.Generic == "+" || .Generic == "-") {
        if(inherits(e1, "difftime") && !inherits(e2, "difftime"))
            return(.difftime(NextMethod(.Generic),
                             units = attr(e1, "units")))
        if(!inherits(e1, "difftime") && inherits(e2, "difftime"))
            return(.difftime(NextMethod(.Generic),
                             units = attr(e2, "units")))
        u1 <- attr(e1, "units")
        if(attr(e2, "units") == u1) {
            .difftime(NextMethod(.Generic), units = u1)
        } else {
            e1 <- coerceTimeUnit(e1)
            e2 <- coerceTimeUnit(e2)
            .difftime(NextMethod(.Generic), units = "secs")
        }
    } else {
        ## '*' is covered by a specific method
        stop(gettextf("'%s' not defined for \"difftime\" objects", .Generic),
             domain = NA)
    }
}

`*.difftime` <- function (e1, e2)
{
    ## need one scalar, one difftime.
    if(inherits(e1, "difftime") && inherits(e2, "difftime"))
        stop("both arguments of * cannot be \"difftime\" objects")
    if(inherits(e2, "difftime")) {tmp <- e1; e1 <- e2; e2 <- tmp}
    .difftime(e2 * unclass(e1), attr(e1, "units"))
}

`/.difftime` <- function (e1, e2)
{
    ## need one scalar, one difftime.
    if(inherits(e2, "difftime"))
        stop("second argument of / cannot be a \"difftime\" object")
    .difftime(unclass(e1) / e2, attr(e1, "units"))
}

## "Math": some methods should work; the other ones are meaningless :
Math.difftime <- function (x, ...)
{
    switch(.Generic,
           "abs" =, "sign" =, "floor" =, "ceiling" =, "trunc" =,
           "round" =, "signif" = {
               units <- attr(x, "units")
               .difftime(NextMethod(), units)
           },
           ### otherwise :
           stop(gettextf("'%s' not defined for \"difftime\" objects", .Generic),
                domain = NA))
}


mean.difftime <- function (x, ...)
    .difftime(mean(unclass(x), ...), attr(x, "units"))

Summary.difftime <- function (..., na.rm)
{
    ## FIXME: this could return in the smallest of the units of the inputs.
    coerceTimeUnit <- function(x)
    {
        as.vector(switch(attr(x,"units"),
                         secs = x, mins = 60*x, hours = 60*60*x,
                         days = 60*60*24*x, weeks = 60*60*24*7*x))
    }
    ok <- switch(.Generic, max = , min = , sum=, range = TRUE, FALSE)
    if (!ok)
        stop(gettextf("'%s' not defined for \"difftime\" objects", .Generic),
             domain = NA)
    x <- list(...)
    Nargs <- length(x)
    if(Nargs == 0) {
        .difftime(do.call(.Generic), "secs")
    } else {
        units <- sapply(x, attr, "units")
        if(all(units == units[1L])) {
            args <- c(lapply(x, as.vector), na.rm = na.rm)
        } else {
            args <- c(lapply(x, coerceTimeUnit), na.rm = na.rm)
            units <- "secs"
        }
        .difftime(do.call(.Generic, args), units[[1L]])
    }
}

c.difftime <-
function(..., recursive = FALSE)
{
    coerceTimeUnit <- function(x) {
        switch(attr(x, "units"),
               secs = x, mins = 60*x, hours = 60*60*x,
               days = 60*60*24*x, weeks = 60*60*24*7*x)
    }
    args <- list(...)
    if(!length(args)) return(.difftime(double(), "secs"))
    ind <- vapply(args, inherits, NA, "difftime")
    pos <- which(!ind)
    units <- sapply(args[ind], attr, "units")
    if(all(units == (un1 <- units[1L]))) {
        if(length(pos))
            args[pos] <-
                lapply(args[pos], as.difftime, units = un1)
        .difftime(unlist(args), un1)
    } else {
        if(length(pos))
            args[pos] <-
                lapply(args[pos], as.difftime, units = "secs")
        args[ind] <- lapply(args[ind], coerceTimeUnit)
        .difftime(unlist(args), "secs")
    }
}

`length<-.difftime` <-
function(x, value)
    .difftime(NextMethod(), attr(x, "units"), oldClass(x))

## Added in R 4.5.0.
summary.difftime <-
function(object, digits = getOption("digits"), ...)
{
    x <- summary.default(unclass(object), digits = digits, ...)
    if(m <- match("NA's", names(x), 0L)) {
        NAs <- as.integer(x[m])
        x <- x[-m]
        attr(x, "NAs") <- NAs
    }
    .difftime(x, attr(object, "units"),
              c("summaryDefault", oldClass(object)))
}

## ----- convenience functions -----

seq.POSIXt <-
function(from, to, by, length.out = NULL, along.with = NULL, ...)
{
    if (!missing(along.with)) {
        length.out <- length(along.with)
    }  else if (!is.null(length.out)) {
        if (length(length.out) != 1L) stop(gettextf("'%s' must be of length 1", "length.out"), domain=NA)
        length.out <- ceiling(length.out)
    }
    missing_arg <- names(which(c(from = missing(from), to = missing(to),
                                 length.out = is.null(length.out), by = missing(by))))
    if(length(missing_arg) != 1L)
        stop("exactly three of 'to', 'from', 'by' and 'length.out' / 'along.with' must be specified")
    # NB: process 'to' first so that 'tz' is overwritten to that from 'from' unless missing(from)
    if (missing_arg != "to") {
        if (!inherits(to, "POSIXt")) stop(gettextf("'%s' must be a \"%s\" object", "to", "POSIXt"), domain=NA)
        if (length(to) != 1L) stop(gettextf("'%s' must be of length 1", "to"), domain=NA)
        cto <- as.POSIXct(to)
        tz <- attr(cto, "tzone")
    }
    if (missing_arg != "from") {
        if (!inherits(from, "POSIXt")) stop(gettextf("'%s' must be a \"%s\" object", "from", "POSIXt"), domain=NA)
        if (length(from) != 1L) stop(gettextf("'%s' must be of length 1", "from"), domain=NA)
        cfrom <- as.POSIXct(from)
        tz <- attr(cfrom, "tzone")
    }
    if (missing_arg == "by") {
        from <- unclass(as.POSIXct(from))
        to   <- unclass(as.POSIXct(to))
        res <- seq.int(from, to, length.out = length.out)
        return(.POSIXct(res, tz = attr(from, "tzone")))
    }
    ## else 'by' is not missing
    if (length(by) != 1L) stop(gettextf("'%s' must be of length 1", "by"), domain=NA)
    valid <- 0L
    if (inherits(by, "difftime")) {
        units(by) <- "secs"
        by <- as.vector(by) # simple numeric (int/dbl)
    } else if(is.character(by)) {
        by2 <- strsplit(by, " ", fixed = TRUE)[[1L]]
        if(length(by2) > 2L || length(by2) < 1L)
            stop("invalid 'by' string")
        valid <- pmatch(by2[length(by2)],
                        c("secs", "mins", "hours", "days", "weeks",
                          "months", "years", "DSTdays", "quarters"))
        if(is.na(valid)) stop("invalid string for 'by'")
        if(valid <= 5L) {
            by <- c(1, 60, 3600, 86400, 7*86400)[valid]
            if (length(by2) == 2L) by <- by * as.integer(by2[1L])
        } else # months or longer
            by <- if(length(by2) == 2L) as.integer(by2[1L]) else 1L
    } else if(!is.numeric(by)) stop("invalid mode for 'by'")
    if(is.na(by)) stop("'by' is NA")

    if(valid <= 5L) { # one of secs, mins, hours, days, or weeks
       res <- switch(missing_arg,
           from       = seq.int(to   = unclass(cto),   by = by,           length.out = length.out),
           to         = seq.int(from = unclass(cfrom), by = by,           length.out = length.out),
           length.out = seq.int(from = unclass(cfrom), to = unclass(cto), by = by)
       )
       return(.POSIXct(res, tz))
    }
    ## months or longer -->  via  POSIXlt
    lres <- as.POSIXlt(if (missing_arg != "from") from else to)
    if (missing_arg == "length.out") lto <- as.POSIXlt(to)
    if(valid == 7L) { # years
        lres$year <- switch(missing_arg,
          from       = seq.int(to   = lres$year, by = by, length.out = length.out),
          to         = seq.int(from = lres$year, by = by, length.out = length.out),
          length.out = seq.int(from = lres$year, to = lto$year, by = by)
        )
    } else if(valid %in% c(6L, 9L)) { # months or quarters
        if (valid == 9L) by <- by * 3
        lres$mon <- switch(missing_arg,
          from       = seq.int(to   = lres$mon, by = by, length.out = length.out),
          to         = seq.int(from = lres$mon, by = by, length.out = length.out),
          length.out = seq.int(lres$mon, 12*(lto$year - lres$year) + lto$mon, by)
        )
    } else if(valid == 8L) { # DSTdays
        lres$mday <- switch(missing_arg,
          from       = seq.int(to   = lres$mday, by = by, length.out = length.out),
          to         = seq.int(from = lres$mday, by = by, length.out = length.out),
          ## We might have a short day, so need to over-estimate.
          length.out = seq.int(lres$mday, by = by,
                               length.out = 2L + floor((unclass(cto) - unclass(cfrom))/(by * 86400)))
        )
    }
    lres$isdst <- -1L
    res <- as.POSIXct(lres)
    if(missing_arg == "length.out") # shorten if necessary.
        res[if(by > 0) res <= cto else res >= cto]
    else
        res
}

## *very* similar to cut.Date [ ./dates.R ] -- keep in sync!
cut.POSIXt <-
    function (x, breaks, labels = NULL, start.on.monday = TRUE,
              right = FALSE, ...)
{
    if(!inherits(x, "POSIXt")) stop("'x' must be a date-time object")
    x <- as.POSIXct(x)

    if (inherits(breaks, "POSIXt")) {
    breaks <- sort(as.POSIXct(breaks))
    } else if(is.numeric(breaks) && length(breaks) == 1L) {
    ## specified number of breaks
    } else if(is.character(breaks) && length(breaks) == 1L) {
        by2 <- strsplit(breaks, " ", fixed = TRUE)[[1L]]
        if(length(by2) > 2L || length(by2) < 1L)
            stop("invalid specification of 'breaks'")
    valid <-
        pmatch(by2[length(by2)],
           c("secs", "mins", "hours", "days", "weeks",
             "months", "years", "DSTdays", "quarters"))
    if(is.na(valid)) stop("invalid specification of 'breaks'")
    start <- as.POSIXlt(min(x, na.rm = TRUE))
    incr <- 1
    if(valid > 1L) { start$sec <- 0L; incr <- 60 }
    if(valid > 2L) { start$min <- 0L; incr <- 3600 }
        ## start of day need not be on the same DST, PR#14208
    if(valid > 3L) { start$hour <- 0L; start$isdst <- -1L; incr <- 86400 }
    if(valid == 5L) {               # weeks
        start$mday <- start$mday - start$wday
        if(start.on.monday)
        start$mday <- start$mday + ifelse(start$wday > 0L, 1L, -6L)
        incr <- 7*86400
    }
        if(valid == 8L) incr <- 25*3600 # DSTdays
        if(valid == 6L) {               # months
            start$mday <- 1L
            maxx <- max(x, na.rm = TRUE)
            end <- as.POSIXlt(maxx)
            step <- if(length(by2) == 2L) as.integer(by2[1L]) else 1L
            end <- as.POSIXlt(end + (31 * step * 86400))
            end$mday <- 1L
            end$isdst <- -1L
            breaks <- seq(start, end, breaks)
            ## 31 days ahead could give an empty level, so
        lb <- length(breaks)
        if(maxx < breaks[lb-1]) breaks <- breaks[-lb]
        } else if(valid == 7L) {        # years
            start$mon <- 0L
            start$mday <- 1L
            maxx <- max(x, na.rm = TRUE)
            end <- as.POSIXlt(maxx)
            step <- if(length(by2) == 2L) as.integer(by2[1L]) else 1L
            end <- as.POSIXlt(end + (366 * step* 86400))
            end$mon <- 0L
            end$mday <- 1L
            end$isdst <- -1L
            breaks <- seq(start, end, breaks)
            ## 366 days ahead could give an empty level, so
        lb <- length(breaks)
        if(maxx < breaks[lb-1]) breaks <- breaks[-lb]
        } else if(valid == 9L) {        # quarters
            qtr <- rep(c(0L, 3L, 6L, 9L), each = 3L)
            start$mon <- qtr[start$mon + 1L]
            start$mday <- 1L
            maxx <- max(x, na.rm = TRUE)
            end <- as.POSIXlt(maxx)
            step <- if(length(by2) == 2L) as.integer(by2[1L]) else 1L
            end <- as.POSIXlt(end + (93 * step * 86400))
            end$mon <- qtr[end$mon + 1L]
            end$mday <- 1L
            end$isdst <- -1L
            breaks <- seq(start, end, paste(step * 3, "months"))
            ## 93 days ahead could give an empty level, so
            lb <- length(breaks)
            if(maxx < breaks[lb-1]) breaks <- breaks[-lb]
        } else {                        # weeks or shorter
            if (length(by2) == 2L) incr <- incr * as.integer(by2[1L])
            maxx <- max(x, na.rm = TRUE)
            breaks <- seq(start, maxx + incr, breaks)
            breaks <- breaks[seq_len(1+max(which(breaks <= maxx)))]
        }
    } else stop("invalid specification of 'breaks'")
    res <- cut(unclass(x), unclass(breaks), labels = labels,
               right = right, ...)
    if(is.null(labels)) {
    levels(res) <-
        as.character(if (is.numeric(breaks)) x[!duplicated(res)]
             else breaks[-length(breaks)])
    }
    res
}

julian <- function(x, ...) UseMethod("julian")

julian.POSIXt <- function(x, origin = as.POSIXct("1970-01-01", tz = "GMT"), ...)
{
    origin <- as.POSIXct(origin)
    if(length(origin) != 1L) stop(gettextf("'%s' must be of length 1", "origin"), domain=NA)
    res <- difftime(as.POSIXct(x), origin, units = "days")
    structure(res, "origin" = origin)
}

## Note that  'abbreviate' works *vectorized* here :

weekdays <- function(x, abbreviate) UseMethod("weekdays")
weekdays.POSIXt <- function(x, abbreviate = FALSE)
{
    format(x, ifelse(abbreviate, "%a", "%A"))
}

months <- function(x, abbreviate) UseMethod("months")
months.POSIXt <- function(x, abbreviate = FALSE)
{
    format(x, ifelse(abbreviate, "%b", "%B"))
}

quarters <- function(x, abbreviate) UseMethod("quarters")
quarters.POSIXt <- function(x, ...)
{
    x <- (as.POSIXlt(x)$mon)%/%3
    paste0("Q", x+1)
}

trunc.POSIXt <-
function(x, units = c("secs", "mins", "hours", "days", "months", "years"), ...)
{
    units <- match.arg(units)
    x <- as.POSIXlt(x)
    if(length(x$sec))
    switch(units,
           "secs" = {x$sec <- trunc(x$sec)},
           "mins" = {x$sec[] <- 0},
           "hours" = {x$sec[] <- 0; x$min[] <- 0L},
               ## start of day need not be on the same DST.
           "days" = {
                   x$sec[] <- 0; x$min[] <- 0L; x$hour[] <- 0L;
                   x$isdst[] <- -1L
               },
               "months" = {
                   x$sec[] <- 0; x$min[] <- 0L; x$hour[] <- 0L;
                   x$mday[] <- 1L
                   x$isdst[] <- -1L
                   ## To get wday and yday correctly:
                   x <- as.POSIXlt(as.POSIXct(x))
               },
               "years" = {
                   x$sec[] <- 0; x$min[] <- 0L; x$hour[] <- 0L;
                   x$mday[] <- 1L; x$mon[] <- 0L
                   x$isdst[] <- -1L
                   ## To get wday and yday correctly:
                   x <- as.POSIXlt(as.POSIXct(x))
               }
           )
    x
}

round.POSIXt <-
function(x, units = c("secs", "mins", "hours", "days", "months", "years"))
{
    .round_x_to_l_or_u <- function(lx, ll, lu) {
        ## lx ll lu all POSIXlt, lu not necessarily valid yet.
        cu <- as.POSIXct(lu)
        lu <- as.POSIXlt(cu)
        tu <- unclass(cu)
        tx <- unclass(as.POSIXct(lx))
        tl <- unclass(as.POSIXct(ll))
        up <- ((tu - tx) <= (tx - tl))
        up <- !is.na(up) & up
        y <- ll
        y[up] <- lu[up]
        y
    }

    ## this gets the default from the generic's 2nd arg 'digits = 0' :
    units <- if(is.numeric(units) && units == 0.) "secs" else match.arg(units)

    if(units == "months") {
        x <- as.POSIXlt(x)
        ## Start of this month:
        ll <- trunc.POSIXt(x, "months")
        ## Start of next month:
        lu <- ll
        lu$mon <- lu$mon + 1L
        ## Now make lu valid and round ...
        .round_x_to_l_or_u(x, ll, lu)
    }
    else if(units == "years") {
        x <- as.POSIXlt(x)
        ## Start of this year:
        ll <- trunc.POSIXt(x, "years")
        ## Start of next year:
        lu <- ll
        lu$year <- lu$year + 1L
        ## Now make lu valid and round ...
        .round_x_to_l_or_u(x, ll, lu)
    }
    else
        trunc.POSIXt(as.POSIXct(x) +
                     switch(units,
                            "secs" = 0.5,
                            "mins" = 30,
                            "hours" = 1800,
                            "days" = 43200),
                     units = units)
}

## ---- additions in 1.5.0 -----

## R 3.5.0 added a j index to the [ POSIXlt extract and replace methods,
## in order to avoid having users unclass (and reclass) for extracting
## or replacing single components (as the [[ method was changed to work
## on datetimes rather than components, and the $ methods are convenient
## for component literals only).
##
## Dealing with the j index is not quite straightforward though: we now
## insist on it being a character string, and if it does not exactly
## match a component name we extract or replace nothing.  If it matches,
## the replace method currently does not ensure the "validity" (correct
## length or type etc) of the replacement (as the internal POSIXlt codes
## seem rather generous when dealing with invalid components).
##
## Dealing with a character i index is not quite straightforward either,
## as the names of POSIXlt objects are kept in the 'year' component.  It
## seems that for extracting we can get by (and get results consistent
## with the POSIXct case) via matching i against the names of x, whereas
## this does not deal with all boundary (out-of-bounds etc) cases for
## replacing: hence for the latter, we simply add the names to all
## components (if i is character).

`[.POSIXlt` <- function(x, i, j, drop = TRUE)
{
    if((mj <- missing(j)) & (mi <- missing(i)))
        return(x)
    if(!mj)
        if(!is.character(j) || (length(j) != 1L))
            stop("component subscript must be a character string")

    if(mi) # but !mj : x[, ".."]
        unCfillPOSIXlt(x)[[j]]
    else {
        if(is.character(i))
            i <- match(i, names(x),
                       incomparables = c("", NA_character_))
        if(mj) # x[i]
            `attr<-`(.POSIXlt(lapply(unCfillPOSIXlt(x), `[`, i, drop = drop),
                              attr(x, "tzone"), oldClass(x)),
                     "balanced", if(isTRUE(attr(x, "balanced"))) TRUE else NA)
        else # x[i,j]
            unCfillPOSIXlt(x)[[j]][i]
    }
}

`[<-.POSIXlt` <- function(x, i, j, value)
{
    if(!(mj <- missing(j)))
        if(!is.character(j) || (length(j) != 1L))
            stop("component subscript must be a character string")

    if(!length(value))
        return(x)
    if((mi <- missing(i)) && mj) # x[] <- v
        return(as.POSIXlt(value)) #  , tz = attr(x,"tzone")  ??

    cl <- oldClass(x)
    x <- unCfillPOSIXlt(x) # list

    if(mi) { ## x[, ".."] <- v
        x[[j]] <- value
    } else {
        ici <- is.character(i)
        nms <- names(x$year)
        if(mj) {
            tz <- attr(x, "tzone")
            value <- unCfillPOSIXlt(
                if(inherits(value, "POSIXlt") && identical(tz, attr(value, "tzone")))
                    value
                else as.POSIXlt(as.POSIXct(value), tz = tz[1L]))
            if(ici) {
                for(n in names(x))
                    names(x[[n]]) <- nms
            }
            for(n in names(x))
                x[[n]][i] <- value[[n]]
        } else {
            if(ici) {
                names(x[[j]]) <- nms
            }
            x[[j]][i] <- value
        }
    }

    class(x) <- cl
    x
}

as.data.frame.POSIXlt <- function(x, row.names = NULL, optional = FALSE, ...)
{
    value <- as.data.frame.vector(as.POSIXct(x), row.names, optional, ...)
    if (!optional)
        names(value) <- deparse1(substitute(x))
    value
}

## ---- additions in 1.8.0 -----

rep.POSIXct <- function(x, ...)
    .POSIXct(NextMethod(), attr(x, "tzone"), oldClass(x))

rep.POSIXlt <- function(x, ...) {
    cl <- oldClass(x)
    x <- unCfillPOSIXlt(x)
    ## fails to set class: `attributes<-`(lapply(x, rep, ...), attributes(x))
    r <- lapply(x, rep, ...)
    class(r) <- cl
    attr(r, "tzone") <- attr(x, "tzone")
    attr(r, "balanced") <- if(isTRUE(attr(x, "balanced"))) TRUE else NA
    r
}

diff.POSIXt <- function (x, lag = 1L, differences = 1L, ...)
{
    ismat <- is.matrix(x)
    r <- if(inherits(x, "POSIXlt")) as.POSIXct(x) else x
    xlen <- if (ismat) dim(x)[1L] else length(r)
    if (length(lag) != 1L || length(differences) > 1L || lag < 1L || differences < 1L)
        stop("'lag' and 'differences' must be integers >= 1")
    if (lag * differences >= xlen) return(.difftime(numeric(), "secs"))
    i1 <- -seq_len(lag)
    if (ismat)
        for (i in seq_len(differences))
            r <- r[i1, , drop = FALSE] - r[-nrow(r):-(nrow(r) - lag + 1), , drop = FALSE]
    else
        for (i in seq_len(differences))
             r <- r[i1] -  r[-length(r):-(length(r) - lag + 1L)]
    dots <- list(...)
    if("units" %in% names(dots) && dots$units != "auto")
        units(r) <- match.arg(dots$units,  choices = setdiff(eval(formals(difftime)$units), "auto"))
    r
}


## ---- additions in 2.2.0 -----

duplicated.POSIXlt <- function(x, incomparables = FALSE, ...)
{
    x <- as.POSIXct(x)
    NextMethod("duplicated", x)
}

unique.POSIXlt <- function(x, incomparables = FALSE, ...)
    x[!duplicated(x, incomparables, ...)]

## ---- additions in 2.4.0 -----

sort.POSIXlt <- function(x, decreasing = FALSE, na.last = NA, ...)
    x[order(as.POSIXct(x), na.last = na.last, decreasing = decreasing)]


## ---- additions in 2.6.0 -----

is.numeric.POSIXt <- function(x) FALSE

## ---- additions in 2.8.0 -----

split.POSIXct <-
function(x, f, drop = FALSE, ...)
    lapply(split.default(as.double(x), f, drop = drop, ...),
           .POSIXct, attr(x, "tzone"), oldClass(x))

xtfrm.POSIXct <- function(x) as.numeric(x)
xtfrm.POSIXlt <- function(x) as.double(x)  # has POSIXlt method
xtfrm.difftime <- function(x) as.numeric(x)
is.numeric.difftime <- function(x) FALSE

## Class generators added in 2.11.0, class order changed in 2.12.0.

## FIXME:
## At least temporarily avoid structure() for performance reasons.
## .POSIXct <- function(xx, tz = NULL)
##     structure(xx, class = c("POSIXct", "POSIXt"), tzone = tz)
.POSIXct <- function(xx, tz = NULL, cl = c("POSIXct", "POSIXt")) {
    class(xx) <- cl
    attr(xx, "tzone") <- tz
    xx
}

## FIXME:
## At least temporarily avoid structure() for performance reasons.
## .POSIXlt <- function(xx, tz = NULL)
##     structure(xx, class = c("POSIXlt", "POSIXt"), tzone = tz)
.POSIXlt <- function(xx, tz = NULL, cl = c("POSIXlt", "POSIXt")) {
    class(xx) <- cl
    attr(xx, "tzone") <- tz
    xx
}

## FIXME:
## At least temporarily avoid structure() for performance reasons.
## .difftime <- function(xx, units)
##     structure(xx, units = units, class = "difftime")
.difftime <- function(xx, units, cl = "difftime") {
    class(xx) <- cl
    attr(xx, "units") <- units
    xx
}

## ---- additions in 2.13.0 -----

names.POSIXlt <- function(x) names(x$year)

`names<-.POSIXlt` <-
function(x, value)
{
    if(length(yr <- x$year) < (n <- length(x))) # must recycle
        x$year <- rep_len(yr, n)
    names(x$year) <- value
    x
}

## Added in 3.1.0.

OlsonNames <- function(tzdir = NULL)
{
    if (is.null(tzdir)) {
        if(.Platform$OS.type == "windows")
            tzdir <- Sys.getenv("TZDIR", file.path(R.home("share"), "zoneinfo"))
        else {
            if(Sys.getenv("TZDIR") == "internal")
                tzdir <- file.path(R.home("share"), "zoneinfo")
            else if (grepl("darwin", R.Version()$os) &&
                     Sys.getenv("TZDIR") == "macOS") {
                tzdir <- "/var/db/timezone/zoneinfo"
            } else {
                ## Try known locations in turn.
                ## The list is not exhaustive (mac OS 10.13's
                ## /usr/share/zoneinfo is a symlink) and there is a risk that
                ## the wrong one is found.
                ## We assume that if the second exists that the system was
                ## configured with --with-internal-tzcode
                tzdirs <- c(Sys.getenv("TZDIR"), # defaults to ""
                            file.path(R.home("share"), "zoneinfo"),
                            "/usr/share/zoneinfo", # Linux, macOS, FreeBSD
                            "/share/zoneinfo", # in musl's search
                            "/usr/share/lib/zoneinfo", # Solaris, AIX
                            "/usr/lib/zoneinfo",   # early glibc
                            "/usr/local/etc/zoneinfo", # tzcode default
                            "/etc/zoneinfo", "/usr/etc/zoneinfo")
                tzdirs <- tzdirs[file.exists(tzdirs)]
                if (!length(tzdirs)) {
                    warning("no Olson database found")
                    return(character())
                } else tzdir <- tzdirs[1L]
            }
        }
    } else if(!dir.exists(tzdir))
        stop(sprintf("%s is not a directory", sQuote(tzdir)), domain = NA)

    x <- list.files(tzdir, recursive = TRUE)
    ## Some databases have VERSION (tzdata hence --with-internal-tzcode),
    ## some +VERSION (Apple), some neither (including glibc)
    ver <- if(file.exists(vf <- file.path(tzdir, "VERSION")))
        readLines(vf, warn = FALSE)
    else if(file.exists(vf <- file.path(tzdir, "+VERSION")))
        readLines(vf, warn = FALSE)
    else if(file.exists(vf <- file.path(tzdir, "tzdata.zi"))) {
        ## exists on Fedora, at least
        l <- readLines(vf, n = 1L)
        patt <- "^# version "
        if(grepl(patt, l)) sub(patt, "", l) else NULL
    }
    ## else NULL

    x <- setdiff(x, "VERSION")
    ## all other auxiliary files are l/case.
    ans <- grep("^[ABCDEFGHIJKLMNOPQRSTUVWXYZ]", x, value = TRUE)
    if(!is.null(ver)) attr(ans, "Version") <- ver
    ans
}

## Added in 3.5.0.

`[[.POSIXlt` <- function(x, i, drop = TRUE)
{
    if(!missing(i) && is.character(i)) {
        idx <- match(i, names(x), incomparables = c("", NA_character_))
        if (length(i) == 1L && is.na(idx) && i %in% names(unclass(x[[1L]])))
            stop(gettextf(
                'No element named "%s" found in x, did you mean x[, "%1$s"] instead?', i),
                domain = NA)
        i <- idx
    }
    `attr<-`(.POSIXlt(lapply(unCfillPOSIXlt(x), `[[`, i, drop = drop),
                      attr(x, "tzone"), oldClass(x)),
             "balanced", if(isTRUE(attr(x, "balanced"))) TRUE else NA)
}

as.list.POSIXlt <- function(x, ...)
{
    nms <- names(x)
    names(x) <- NULL
    y <- lapply(X = do.call(Map, c(list, unCfillPOSIXlt(x))),
                FUN = .POSIXlt, attr(x, "tzone"), oldClass(x))
    names(y) <- nms
    y
}

## Added in 3.6.0.

`[[<-.POSIXlt` <- function(x, i, value)
{
    cl <- oldClass(x)
    x <- unCfillPOSIXlt(x)

    if(!missing(i) && is.character(i)) {
        nms <- names(x$year)
        for(n in names(x))
            names(x[[n]]) <- nms
    }

    tz <- attr(x, "tzone")
    value <- unCfillPOSIXlt(
        if(inherits(value, "POSIXlt") && identical(tz, attr(value, "tzone")))
            value
        else as.POSIXlt(as.POSIXct(value), tz = tz[1L]))
    for(n in names(x))
        x[[n]][[i]] <- value[[n]]

    class(x) <- cl
    x
}

## Added in 4.0.0.

as.list.difftime <- function(x, ...)
    lapply(unclass(x), .difftime, attr(x, "units"), oldClass(x))

## Added in 4.1.0.

rep.difftime <- function(x, ...)
    .difftime(NextMethod("rep"), attr(x, "units"), oldClass(x))

`[<-.difftime` <- function(x, i, value) {
    if(inherits(value, "difftime") && !identical(units(x), units(value)))
        units(value) <- units(x)
    NextMethod("[<-")
}

## Added in 4.2.0.

as.vector.POSIXlt <- function(x, mode = "any")
    as.vector(as.list(x), mode)

## Added in 4.3.0.

balancePOSIXlt <- function(x, fill.only=FALSE, classed=TRUE)
    .Internal(balancePOSIXlt(x, fill.only, classed))
