Merge branch 'master' of github.com:dlowe-net/local-time

.gitignore

@@ -1 +1,21 @@
-*.fasl
+*.fasl
+*.dfsl
+*.ppcf
+*.x86f
+*.fas
+*.lib
+doc/manual/
+doc/*.vr
+doc/*.tp
+doc/*.tps
+doc/*.toc
+doc/*.pg
+doc/*.log
+doc/*.ky
+doc/*.it
+doc/*.info
+doc/*.fn
+doc/*.fns
+doc/*.cp
+doc/*.cps
+doc/*.aux

doc/local-time.texinfo

@@ -545,6 +545,13 @@ The constant @var{+rfc-1123-format+} is bound to a description of the format def
 
 @end defvr
 
+@itindex +iso-week-date-format+
+@defvr Constant +iso-week-date-format+
+
+The constant @var{+iso-week-date-format+} is bound to a description of the ISO 8601 Week Date format.  An output with this format will look like this: @samp{2009-W53-5}.
+
+@end defvr
+
 @itindex parse-timestring
 @defun parse-timestring timestring &key (start 0) end (fail-on-error t) (offset 0)
 
@@ -587,6 +594,12 @@ FORMAT is a list containing one or more of strings, characters, and keywords.  S
 *microseconds
 @item :nsec
 *nanoseconds
+@item :iso-week-year
+*year for ISO week date (can be different from regular calendar year)
+@item :iso-week-number
+*ISO week number (i.e. 1 through 53)
+@item :iso-week-day
+*ISO compatible weekday number (i.e. monday=1, sunday=7)
 @item :ordinal-day
 day of month as an ordinal (e.g. 1st, 23rd)
 @item :long-weekday

src/local-time.lisp

@@ -154,6 +154,9 @@
   '(:short-weekday ", " (:day 2) #\space :short-month #\space (:year 4) #\space
     (:hour 2) #\: (:min 2) #\: (:sec 2) #\space :timezone)
   "Please note that you should use the +GMT-ZONE+ timezone to format a proper RFC 1123 timestring. See the RFC for the details about the possible values of the timezone field.")
+(defparameter +iso-week-date-format+
+  ;; 2009-W53-5
+  '((:iso-week-year 4) #\- #\W (:iso-week-number 2) #\- (:iso-week-day 1)))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defparameter +rotated-month-days-without-leap-day+
@@ -429,7 +432,7 @@ In other words:
 (defun transition-position (needle haystack &optional (start 0) (end (1- (length haystack))))
   (let ((middle (floor (+ end start) 2)))
     (cond
-      ((> start end)
+      ((>= start end)
        (if (minusp end)
            0
            end))
@@ -1112,6 +1115,18 @@ elements."
        1-based-month
        1-based-day))))
 
+(defun %timestamp-decode-iso-week (timestamp)
+  "Returns the year, week number, and day of week components of an ISO week date."
+  ;; Algorithm from http://en.wikipedia.org/wiki/Talk:ISO_week_date#Algorithms
+  (let* ((dn (timestamp-day-of-week timestamp))
+         (day-of-week (if (zerop dn) 7 dn)) ; ISO weekdays are Monday=1 and Sunday=7
+         (nearest-thursday (timestamp+ timestamp (- 4 day-of-week) :day))
+         (base-year (encode-timestamp 0 0 0 0 1 1 (timestamp-year nearest-thursday)))
+         (ordinal-day (- (day-of nearest-thursday) (day-of base-year))))
+    (values (timestamp-year base-year)
+            (nth-value 0 (floor (1+ (/ ordinal-day 7))))
+            day-of-week)))
+
 (defun %timestamp-decode-time (seconds)
   "Returns the hours, minutes, and seconds, given the number of seconds since midnight."
   (declare (type integer seconds))
@@ -1456,68 +1471,73 @@ elements."
   (multiple-value-bind (nsec sec minute hour day month year weekday daylight-p offset abbrev)
       (decode-timestamp timestamp :timezone timezone)
     (declare (ignore daylight-p))
-    (let ((*print-pretty* nil)
-          (*print-circle* nil))
-      (with-output-to-string (result nil :element-type 'base-char)
-        (dolist (fmt format)
-          (cond
-            ((or (eql fmt :gmt-offset)
-                 (eql fmt :gmt-offset-or-z))
-             (multiple-value-bind (offset-hours offset-secs)
-                 (floor offset +seconds-per-hour+)
-               (declare (fixnum offset-hours offset-secs))
-               (if (and (eql fmt :gmt-offset-or-z) (zerop offset))
-                   (princ #\Z result)
-                   (format result "~c~2,'0d:~2,'0d"
-                           (if (minusp offset-hours) #\- #\+)
-                           (abs offset-hours)
-                           (truncate (abs offset-secs)
-                                     +seconds-per-minute+)))))
-            ((eql fmt :short-year)
-             (princ (mod year 100) result))
-            ((eql fmt :long-month)
-             (princ (aref +month-names+ month) result))
-            ((eql fmt :short-month)
-             (princ (aref +short-month-names+ month) result))
-            ((eql fmt :long-weekday)
-             (princ (aref +day-names+ weekday) result))
-            ((eql fmt :short-weekday)
-             (princ (aref +short-day-names+ weekday) result))
-            ((eql fmt :timezone)
-             (princ abbrev result))
-            ((eql fmt :hour12)
-             (princ (1+ (mod (1- hour) 12)) result))
-            ((eql fmt :ampm)
-             (princ (if (< hour 12) "am" "pm") result))
-            ((eql fmt :ordinal-day)
-             (princ (ordinalize day) result))
-            ((or (stringp fmt) (characterp fmt))
-             (princ fmt result))
-            (t
-             (let ((val (ecase (if (consp fmt) (car fmt) fmt)
-                          (:nsec nsec)
-                          (:usec (floor nsec 1000))
-                          (:msec (floor nsec 1000000))
-                          (:sec sec)
-                          (:min minute)
-                          (:hour hour)
-                          (:day day)
-                          (:weekday weekday)
-                          (:month month)
-                          (:year year))))
-               (cond
-                 ((atom fmt)
-                  (princ val result))
-                 ((minusp val)
-                  (format result "-~v,vd"
-                          (second fmt)
-                          (or (third fmt) #\0)
-                          (abs val)))
-                 (t
-                  (format result "~v,vd"
-                          (second fmt)
-                          (or (third fmt) #\0)
-                          val)))))))))))
+    (multiple-value-bind (iso-year iso-week iso-weekday)
+        (%timestamp-decode-iso-week timestamp)
+      (let ((*print-pretty* nil)
+            (*print-circle* nil))
+        (with-output-to-string (result nil :element-type 'base-char)
+          (dolist (fmt format)
+            (cond
+              ((or (eql fmt :gmt-offset)
+                   (eql fmt :gmt-offset-or-z))
+               (multiple-value-bind (offset-hours offset-secs)
+                   (floor offset +seconds-per-hour+)
+                 (declare (fixnum offset-hours offset-secs))
+                 (if (and (eql fmt :gmt-offset-or-z) (zerop offset))
+                     (princ #\Z result)
+                     (format result "~c~2,'0d:~2,'0d"
+                             (if (minusp offset-hours) #\- #\+)
+                             (abs offset-hours)
+                             (truncate (abs offset-secs)
+                                       +seconds-per-minute+)))))
+              ((eql fmt :short-year)
+               (princ (mod year 100) result))
+              ((eql fmt :long-month)
+               (princ (aref +month-names+ month) result))
+              ((eql fmt :short-month)
+               (princ (aref +short-month-names+ month) result))
+              ((eql fmt :long-weekday)
+               (princ (aref +day-names+ weekday) result))
+              ((eql fmt :short-weekday)
+               (princ (aref +short-day-names+ weekday) result))
+              ((eql fmt :timezone)
+               (princ abbrev result))
+              ((eql fmt :hour12)
+               (princ (1+ (mod (1- hour) 12)) result))
+              ((eql fmt :ampm)
+               (princ (if (< hour 12) "am" "pm") result))
+              ((eql fmt :ordinal-day)
+               (princ (ordinalize day) result))
+              ((or (stringp fmt) (characterp fmt))
+               (princ fmt result))
+              (t
+               (let ((val (ecase (if (consp fmt) (car fmt) fmt)
+                            (:nsec nsec)
+                            (:usec (floor nsec 1000))
+                            (:msec (floor nsec 1000000))
+                            (:sec sec)
+                            (:min minute)
+                            (:hour hour)
+                            (:day day)
+                            (:weekday weekday)
+                            (:month month)
+                            (:year year)
+                            (:iso-week-year iso-year)
+                            (:iso-week-number iso-week)
+                            (:iso-week-day iso-weekday))))
+                 (cond
+                   ((atom fmt)
+                    (princ val result))
+                   ((minusp val)
+                    (format result "-~v,vd"
+                            (second fmt)
+                            (or (third fmt) #\0)
+                            (abs val)))
+                   (t
+                    (format result "~v,vd"
+                            (second fmt)
+                            (or (third fmt) #\0)
+                            val))))))))))))
 
 (defun format-timestring (destination timestamp &key
                           (format +iso-8601-format+)
@@ -1536,6 +1556,9 @@ FORMAT is a list containing one or more of strings, characters, and keywords. St
   :MSEC              *milliseconds
   :USEC              *microseconds
   :NSEC              *nanoseconds
+  :ISO-WEEK-YEAR     *year for ISO week date (can be different from regular calendar year)
+  :ISO-WEEK-NUMBER   *ISO week number (i.e. 1 through 53)
+  :ISO-WEEK-DAY      *ISO compatible weekday number (monday=1, sunday=7)
   :LONG-WEEKDAY      long form of weekday (e.g. Sunday, Monday)
   :SHORT-WEEKDAY     short form of weekday (e.g. Sun, Mon)
   :LONG-MONTH        long form of month (e.g. January, February)

src/package.lisp

@@ -77,6 +77,7 @@
            #:+rfc3339-format/date-only+
            #:+asctime-format+
            #:+rfc-1123-format+
+           #:+iso-week-date-format+
            #:astronomical-julian-date
            #:modified-julian-date
-           #:astronomical-modified-julian-date))
+           #:astronomical-modified-julian-date))

test/formatting.lisp

@@ -40,7 +40,39 @@
 
        "5th"
        (format-timestring nil test-timestamp
-                          :format '(:ordinal-day))))))
+                          :format '(:ordinal-day))
+
+       "2004-W53-6"
+       (format-timestring nil (encode-timestamp 0 0 0 0 1 1 2005)
+                          :format +iso-week-date-format+)
+
+       "2004-W53-7"
+       (format-timestring nil (encode-timestamp 0 0 0 0 2 1 2005)
+                          :format +iso-week-date-format+)
+
+       "2005-W52-6"
+       (format-timestring nil (encode-timestamp 0 0 0 0 31 12 2005)
+                          :format +iso-week-date-format+)
+
+       "2007-W01-1"
+       (format-timestring nil (encode-timestamp 0 0 0 0 1 1 2007)
+                          :format +iso-week-date-format+)
+
+       "2007-W52-7"
+       (format-timestring nil (encode-timestamp 0 0 0 0 30 12 2007)
+                          :format +iso-week-date-format+)
+
+       "2008-W01-1"
+       (format-timestring nil (encode-timestamp 0 0 0 0 31 12 2007)
+                          :format +iso-week-date-format+)
+
+       "2009-W53-5"
+       (format-timestring nil (encode-timestamp 0 0 0 0 1 1 2010)
+                          :format +iso-week-date-format+)
+
+       "2009-W01-3"
+       (format-timestring nil (encode-timestamp 0 0 0 0 31 12 2008)
+                          :format +iso-week-date-format+)))))
 
 (deftest test/formatting/format-timestring/2 ()
   (with-output-to-string (*standard-output*)