date.stk 11.2 KB
Newer Older
eg's avatar
eg committed
1
;;;;
2
;;;; date.stk                   -- Date and Time Operations
3
;;;;
4
;;;; Copyright © 2002-2018 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
5 6
;;;;
;;;;
eg's avatar
eg committed
7 8 9 10
;;;; 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.
11
;;;;
eg's avatar
eg committed
12 13 14 15
;;;; 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.
16
;;;;
eg's avatar
eg committed
17 18
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
19
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
eg's avatar
eg committed
20
;;;; USA.
21
;;;;
eg's avatar
eg committed
22 23
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date:  3-Apr-2002 10:06 (eg)
24
;;;; Last file update: 11-Sep-2018 10:26 (eg)
eg's avatar
eg committed
25 26
;;;;

27 28
;;;; ======================================================================
;;;;
29
;;;;                    TIME functions
30 31 32 33
;;;;
;;;; ======================================================================

#|
34
<doc EXT time?
35 36
 * (time? obj)
 *
37
 * Return |%t| if |obj| is a time object, othererwise returns |%f|.
38 39 40 41 42 43 44 45 46 47 48
doc>
|#
(define (time? obj)
  (and (struct? obj) (eq? (struct-type obj) %time)))


#|
<doc EXT time->seconds
 * (time->seconds time)
 *
 * Convert the time object |time| into an inexact real number representing
49
 * the number of seconds elapsed since the Epoch.
50 51 52 53 54 55 56 57
 * @lisp
 * (time->seconds (current-time))  ==>  1138983411.09337
 * @end lisp
doc>
|#
(define (time->seconds time)
  (if (time? time)
      (+ (%fast-struct-ref time %time 'second 0)
58
         (/ (%fast-struct-ref time %time 'nanosecond 1)  #e1e9))
59 60 61 62 63 64 65 66 67 68
      (error 'time-seconds "bad time ~S" time)))


#|
<doc EXT seconds->time
 * (seconds->time x)
 *
 * Converts into a time object the real number |x| representing the number
 * of seconds elapsed since the Epoch.
 * @lisp
69
 * (seconds->time (+ 10 (time->seconds (current-time))))
70 71 72 73 74 75 76
 *          ==>  a time object representing 10 seconds in the future
 * @end lisp
doc>
|#
(define (seconds->time x)
  (if (and (number? x) (positive? x))
      (cond
77 78 79 80 81 82 83
        ((real? x)
         (let ((n (inexact->exact (round (* x #e1e9)))))
           (make-struct %time (quotient n #e1e9) (remainder n #e1e9))))
        ((integer? x)
         (make-struct %time  x 0))
        (else
         (error 'seconds->time "cannot convert ~S to a time" x)))
84 85 86 87 88
      (error 'seconds->time "bad number ~S" x)))


;;;; ======================================================================
;;;;
89
;;;;                    DATE functions
90 91
;;;;
;;;; ======================================================================
eg's avatar
eg committed
92 93 94
#|
<doc EXT make-date
 * (make-date :key second minute hour day month year)
95
 *
eg's avatar
eg committed
96 97 98 99 100
 * Build a date from its argument. |hour|, |minute|, |second| default to 0;
 * |day| and |month| default to 1; |year| defaults to 1970
doc>
|#
(define (make-date :key (second 0) (minute 0) (hour 0)
101
                        (day 1) (month 1) (year 1970))
eg's avatar
eg committed
102 103 104 105 106 107 108 109 110
  (let ((tmp (make-struct %date second minute hour day month year)))
    ;; tmp is probably partially initialized convert it to seconds and back
    ;; to a date
    (seconds->date (date->seconds tmp))))

#|
<doc EXT date?
 * (date? obj)
 *
111
 * Return |%t| if |obj| is a date, and otherwise returns |%f|.
eg's avatar
eg committed
112 113 114 115 116
doc>
|#
(define (date? obj)
  (and (struct? obj) (eq? (struct-type obj) %date)))

117 118 119 120 121


(define (seconds->date s)
  (%seconds->date (if (real? s) (inexact->exact (round s)) s)))

eg's avatar
eg committed
122
;; ======================================================================
123
;;      date writer
eg's avatar
eg committed
124 125 126 127 128
;; ======================================================================
(struct-type-change-writer!
   %date
   (lambda (s port)
     (format port "#[date ~A-~A-~A ~A:~A:~A]"
129 130
             (struct-ref s 'year) (struct-ref s 'month) (struct-ref s 'day)
             (struct-ref s 'hour) (struct-ref s 'minute) (struct-ref s 'second))))
eg's avatar
eg committed
131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189


#|
<doc EXT date-second
 * (date-second d)
 *
 * Return the second of date |d|, in the range 0 to 59.
doc>
<doc EXT date-minute
 * (date-minute d)
 *
 * Return the minute of date |d|, in the range 0 to 59.
doc>
<doc EXT date-hour
 * (date-hour d)
 *
 * Return the hour of date |d|, in the range 0 to 23.
doc>
<doc EXT date-day
 * (date-day d)
 *
 * Return the day of date |d|, in the range 1 to 31
doc>
<doc EXT date-month
 * (date-month d)
 *
 * Return the month of date |d|, in the range 1 to 12
doc>
<doc EXT date-year
 * (date-year d)
 *
 * Return the year of date |d|.
doc>
<doc EXT date-week-day
 * (date-week-day d)
 *
 * Return the week day of date |d|, in the range 0 to 6 (0 is Sunday).
doc>
<doc EXT date-year-day
 * (date-year-day d)
 *
 * Return the the number of days since January 1 of date |d|, in the range
 * 1 to 366.
doc>
<doc EXT date-dst
 * (date-dst d)
 *
 * Return an indication about daylight saving adjustment:
 * ,(itemize
 *   (item [0 if no daylight saving adjustment])
 *   (item [1 if daylight saving adjustment])
 *   (item [-1 if the information is not available]))
doc>
<doc EXT date-tz
 * (date-tz d)
 *
 * Return the time zone of date |d|.
doc>
|#
190 191 192
(define (date-second d)         (%fast-struct-ref d %date 'date-second 0))
(define (date-minute d)         (%fast-struct-ref d %date 'date-minute 1))
(define (date-hour d)           (%fast-struct-ref d %date 'date-hour 2))
eg's avatar
eg committed
193

194 195 196
(define (date-day d)            (%fast-struct-ref d %date 'date-day 3))
(define (date-month d)          (%fast-struct-ref d %date 'date-month 4))
(define (date-year d)           (%fast-struct-ref d %date 'date-year 5))
eg's avatar
eg committed
197

198 199
(define (date-week-day d)       (%fast-struct-ref d %date 'date-week-day 6))
(define (date-year-day d)       (%fast-struct-ref d %date 'date-year-day 7))
eg's avatar
eg committed
200

201 202
(define (date-dst d)            (%fast-struct-ref d %date 'date-dst 8))
(define (date-tz d)             (%fast-struct-ref d %date 'date-tz 9))
eg's avatar
eg committed
203 204 205 206 207


#|
<doc EXT seconds->list
 * (seconds->list sec)
208 209
 *
 * Returns a keyword list for the date given by |sec| (a date based on the
eg's avatar
eg committed
210
 * Epoch). The keyed values returned are
211
 * ,(itemize
eg's avatar
eg committed
212 213 214 215 216 217 218 219 220 221 222 223 224
 * (item [second : 0 to 59 (but can be up to 61 to allow for leap seconds)])
 * (item [minute : 0 to 59])
 * (item [hour : 0 to 23])
 * (item [day : 1 to 31])
 * (item [month : 1 to 12])
 * (item [year : e.g., 2002])
 * (item [week-day : 0 (Sunday) to 6 (Saturday)])
 * (item [year-day : 0 to 365 (365 in leap years)])
 * (item [dst : indication about daylight savings time. See ,(ref :mark "date-dst")])
 * (item [tz : the difference between Coordinated Universal Time
 * (UTC) and local standard time in seconds.])
 * )
 * @lisp
225
 * (seconds->list (current-second))
eg's avatar
eg committed
226 227 228 229 230 231 232 233 234
 *        => (:second 51 :minute 26 :hour 19
 *            :day 5 :month 11 :year 2004
 *            :week-day 5 :year-day 310
 *            :dst 0 :tz -3600)
 * @end lisp
doc>
|#
(define (seconds->list sec)
  (apply append (map (lambda (x)
235 236
                       (list (make-keyword (car x)) (cdr x)))
                     (struct->list (seconds->date sec)))))
eg's avatar
eg committed
237 238 239 240 241 242 243 244 245 246


#|
<doc EXT current-date
 * (current-date)
 *
 * Returns the current system date.
doc>
|#
(define (current-date)
247
  (seconds->date (current-second)))
eg's avatar
eg committed
248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305

#|
<doc EXT seconds->string
 * (seconds->string format n)
 *
 * Convert a date expressed in seconds using the string |format| as a
 * specification. Conventions for |format| are given below:
 * ,(itemize
 *  (item (bold "~~ ") [a literal ~])
 *  (item (bold "~a ") [locale's abbreviated weekday name (Sun...Sat)])
 *  (item (bold "~A ") [locale's full weekday name (Sunday...Saturday)])
 *  (item (bold "~b ") [locale's abbreviate month name (Jan...Dec)])
 *  (item (bold "~B ") [locale's full month day (January...December)])
 *  (item (bold "~c ") [locale's date and time
 * (e.g., ,(code "Fri Jul 14 20:28:42-0400 2000"))])
 *  (item (bold "~d ") [day of month, zero padded (01...31)])
 *  (item (bold "~D ") [date (mm/dd/yy)])
 *  (item (bold "~e ") [day of month, blank padded ( 1...31)])
 *  (item (bold "~f ") [seconds+fractional seconds, using locale's
 *         decimal separator (e.g. 5.2).])
 *  (item (bold "~h ") [same as ~b])
 *  (item (bold "~H ") [hour, zero padded, 24-hour clock (00...23)])
 *  (item (bold "~I ") [hour, zero padded, 12-hour clock (01...12)])
 *  (item (bold "~j ") [day of year, zero padded])
 *  (item (bold "~k ") [hour, blank padded, 24-hour clock (00...23)])
 *  (item (bold "~l ") [hour, blank padded, 12-hour clock (01...12)])
 *  (item (bold "~m ") [month, zero padded (01...12)])
 *  (item (bold "~M ") [minute, zero padded (00...59)])
 *  (item (bold "~n ") [new line])
 *  (item (bold "~p ") [locale's AM or PM])
 *  (item (bold "~r ") [time, 12 hour clock, same as ,(code "~I:~M:~S ~p")])
 *  (item (bold "~s ") [number of full seconds since "the epoch" (in UTC)])
 *  (item (bold "~S ") [second, zero padded (00...61)])
 *  (item (bold "~t ") [horizontal tab])
 *  (item (bold "~T ") [time, 24 hour clock, same as ,(code "~H:~M:~S")])
 *  (item (bold "~U ") [week number of year with Sunday as first day of week
 *         (00...53)])
 *  (item (bold "~V ") [weekISO 8601:1988 week number of year (01...53)
 *       (week 1 is the first week that has at least 4 days in the current year,
 *        and  with  Monday  as  the first day of the week)])
 *  (item (bold "~w ") [day of week (1...7, 1 is Monday)])
 *  (item (bold "~W ") [week number of year with Monday as first day of week
 *         (01...52)])
 *  (item (bold "~x ") [week number of year with Monday as first day of week
 *         (00...53)])
 *  (item (bold "~X ") [locale's date representation, for example: "07/31/00"])
 *  (item (bold "~y ") [last two digits of year (00...99)])
 *  (item (bold "~Y ") [year])
 *  (item (bold "~z ") [time zone in RFC-822 style])
 *  (item (bold "~Z ") [symbol time zone])
 * )
doc>
|#
(define (seconds->string format seconds)
  (unless (string? format)
    (error 'seconds->string "bad string ~S" format))
  ;; Convert the format string for C since conventions are different
  (let ((len (string-length format))
306 307
        (out (open-output-string))
        (sec (if (real? seconds) (inexact->exact (round seconds)) seconds)))
eg's avatar
eg committed
308 309
    (let Loop ((i 0))
      (when (< i len)
310 311 312 313 314 315 316 317 318 319 320 321 322 323 324
        (let ((cur-char (string-ref format i)))
          (case cur-char
            ((#\%) ;; "%" ==> "%%"
             (display "%%" out) (Loop (+ i 1)))
            ((#\~) (if (and (< i (- len 1)) (eq? (string-ref format (+ i 1)) #\~))
                       (begin
                         ;; "~~" => "~"
                         (display #\~ out)
                         (Loop (+ i 2)))
                       (begin
                         ;; "~c" => "%c" where c is not a %
                         (display #\% out)
                         (Loop (+ i 1)))))
            (else (display cur-char out)
                  (Loop (+ i 1)))))))
eg's avatar
eg committed
325
    ;; String is converted in the "OUT" string port
326
    (%seconds->string (get-output-string out) sec)))
eg's avatar
eg committed
327 328 329 330 331

#|
<doc EXT date->string
 * (date->string format d)
 *
332
 * Convert the date |d| using the string |format| as a
eg's avatar
eg committed
333 334 335 336 337 338 339
 * specification. Conventions for format are the same as the one
 * of ,(ref :mark "seconds->string").
doc>
|#
(define (date->string format date)
  (unless (string? format)
    (error 'date->string "bad string ~S" format))
340

eg's avatar
eg committed
341 342 343
  (seconds->string format (date->seconds date)))


344

eg's avatar
eg committed
345 346
(provide "date")