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

27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91
;;;; ======================================================================
;;;;
;;;;			TIME functions
;;;;
;;;; ======================================================================

#|
<doc EXT time? 
 * (time? obj)
 *
 * Return |t| if |obj| is a time object, othererwise returns |f|.
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
 * the number of seconds elapsed since the Epoch. 
 * @lisp
 * (time->seconds (current-time))  ==>  1138983411.09337
 * @end lisp
doc>
|#
(define (time->seconds time)
  (if (time? time)
      (+ (%fast-struct-ref time %time 'second 0)
	 (/ (%fast-struct-ref time %time 'micro-second 1)  1e6))
      (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
 * (seconds->time (+ 10 (time->seconds (current-time)))
 *          ==>  a time object representing 10 seconds in the future
 * @end lisp
doc>
|#
(define (seconds->time x)
  (if (and (number? x) (positive? x))
      (cond
	((real? x)
	 (let ((n (inexact->exact (round (* x 1e6)))))
	   (make-struct %time (quotient n 1000000) (remainder n 1000000))))
	((integer? x)
	 (make-struct %time  x 0))
	(else
	 (error 'seconds->time "cannot convert ~S to a time" x)))
      (error 'seconds->time "bad number ~S" x)))


;;;; ======================================================================
;;;;
;;;;			DATE functions
;;;;
;;;; ======================================================================
eg's avatar
eg committed
92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116
#|
<doc EXT make-date
 * (make-date :key second minute hour day month year)
 * 
 * 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)
		        (day 1) (month 1) (year 1970))
  (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)
 *
 * Return |t| if |obj| is a date, and otherwise returns |f|.
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 124 125 126 127 128 129 130 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 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224
;; ======================================================================
;;	date writer
;; ======================================================================
(struct-type-change-writer!
   %date
   (lambda (s port)
     (format port "#[date ~A-~A-~A ~A:~A:~A]"
	     (struct-ref s 'year) (struct-ref s 'month) (struct-ref s 'day)
	     (struct-ref s 'hour) (struct-ref s 'minute) (struct-ref s 'second))))


#|
<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>
|#
(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))

(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))

(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))

(define (date-dst d)		(%fast-struct-ref d %date 'date-dst 8))
(define (date-tz d)		(%fast-struct-ref d %date 'date-tz 9))


#|
<doc EXT seconds->list
 * (seconds->list sec)
 * 
 * Returns a keyword list for the date given by |sec| (a date based on the 
 * Epoch). The keyed values returned are
 * ,(itemize 
 * (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 235 236 237 238 239 240 241 242 243 244 245 246
 *        => (: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)
		       (list (make-keyword (car x)) (cdr x)))
		     (struct->list (seconds->date sec)))))


#|
<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 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325
    (let Loop ((i 0))
      (when (< i len)
	(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)))))))
    ;; 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 340 341 342 343
 * 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))
  
  (seconds->string format (date->seconds date)))


344

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