duration un/parsing extension

Hi,

I extended duration un/parsing to include year and month (minutes having
precedence over months in ambiguous situations). I diff'd my code against 3.3.0
because that's CLSQL version I am still using. Below are the relevant parts of
the diffs. Let me know if you need more info or questions.

Alex

--- time.lisp	2005-09-18 02:13:12.000000000 +0200
+++ .../clsql/sql/time.lisp	2006-04-02 22:34:44.000000000 +0200
@@ -98,8 +98,10 @@
   (let ((second (duration-second duration))
         (minute (duration-minute duration))
         (hour (duration-hour duration))
-        (day (duration-day duration)))
-    (format nil "P~dD~dH~dM~dS" day hour minute second)))
+        (day (duration-day duration))
+	(month (duration-month duration))
+	(year (duration-year duration)))
+    (format nil "P~dY~dM~dD~dH~dM~dS" year month day hour minute second)))

@@ -995,6 +998,8 @@
         (minute (duration-minute duration))
         (hour (duration-hour duration))
         (day (duration-day duration))
+	(month (duration-month duration))
+	(year (duration-year duration))
         (return (null stream))
         (stream (or stream (make-string-output-stream))))
     (ecase precision
@@ -1006,10 +1011,20 @@
        (setf second 0))
       (:second
        t))
-    (if (= 0 day hour minute)
+    (if (= 0 year month day hour minute)
         (format stream "0 minutes")
         (let ((sent? nil))
+	  (when (< 0 year)
+	    (format stream "~d year~p" year year)
+	    (setf sent? t))
+	  (when (< 0 month)
+	    (when sent?
+	      (write-char #\Space stream))
+	    (format stream "~d month~p" month month)
+	    (setf sent? t))
           (when (< 0 day)
+	    (when sent?
+	      (write-char #\Space stream))
             (format stream "~d day~p" day day)
             (setf sent? t))
           (when (< 0 hour)
@@ -1039,11 +1054,16 @@
   (unless (= 0 year month)
     (multiple-value-bind (year-orig month-orig day-orig)
         (time-ymd date)
-      (setf date (make-time :year (+ year year-orig)
-                            :month (+ month month-orig)
-                            :day day-orig
-                            :second (time-second date)
-                            :usec usec))))
+      (multiple-value-bind (new-year new-month)
+	  (floor (+ month month-orig (* 12 (+ year year-orig))) 12)
+	(let ((new-date (make-time :year new-year
+				   :month new-month
+				   :day day-orig
+				   :second (time-second date)
+				   :usec usec)))
+	  (if destructive
+	      (setf (time-mjd date) (time-mjd new-date))
+	      (setq date new-date))))))
   (let ((mjd (time-mjd date))
         (sec (time-second date))
         (usec (time-usec date)))
@@ -1054,9 +1074,8 @@
                         (* 60 minute)
                         (* 60 60 hour))))
                1000000)
-      (declare (ignore sec-new))
       (multiple-value-bind (mjd-new sec-new)
-          (floor sec (* 60 60 24))
+          (floor sec-new (* 60 60 24))
         (if destructive
             (progn
               (setf (time-mjd date) (+ mjd mjd-new day)
@@ -1190,42 +1209,63 @@
 
 
 (defvar *iso-8601-duration-delimiters*
-  '((#\D . :days)
+  '((#\Y . :years)
+    (#\D . :days)
     (#\H . :hours)
-    (#\M . :minutes)
+    (#\M . :months/minutes)
     (#\S . :seconds)))
 
 (defun iso-8601-delimiter (elt)
   (cdr (assoc elt *iso-8601-duration-delimiters*)))
 
-(defun iso-8601-duration-subseq (string start)
-  (let* ((pos (position-if #'iso-8601-delimiter string :start start))
-	 (number (when pos (parse-integer (subseq string start pos)
-                                          :junk-allowed t))))
+(defun iso-8601-duration-subseq (string end)
+  (let* ((pos (position-if #'iso-8601-delimiter string :end end :from-end t))
+	 (pos2 (when pos
+		 (position-if-not #'digit-char-p string :end pos :from-end t)))
+	 (number (when pos2
+		   (parse-integer
+		    (subseq string (1+ pos2) pos) :junk-allowed t))))
     (when number
       (values number
-	      (1+ pos)
+	      (1+ pos2)
 	      (iso-8601-delimiter (aref string pos))))))
 
 (defun parse-iso-8601-duration (string)
   "return a wall-time from a duration string"
   (block parse
-    (let ((days 0) (secs 0) (hours 0) (minutes 0) (index 1))
+    (let ((years 0)
+	  (months 0)
+	  (days 0)
+	  (secs 0)
+	  (hours 0)
+	  (minutes 0)
+	  (index (length string))
+	  (months/minutes nil))
       (loop
        (multiple-value-bind (duration next-index duration-type)
            (iso-8601-duration-subseq string index)
          (case duration-type
+	   (:years
+	    (incf years duration))
+	   (:months/minutes
+	    (if months/minutes
+		(incf months duration)
+		(progn
+		  (setq months/minutes t)
+		  (incf minutes duration))))
+           (:days
+	    (setq months/minutes t)
+            (incf days duration))
            (:hours
+	    (setq months/minutes t)
             (incf hours duration))
-           (:minutes
-            (incf minutes duration))
            (:seconds
             (incf secs duration))
-           (:days
-            (incf days duration))
            (t
-            (return-from parse (make-duration :day days :hour hours
-                                              :minute minutes :second secs))))
+            (return-from parse
+	      (make-duration
+	       :year years :month months :day days :hour hours
+	       :minute minutes :second secs))))
          (setf index next-index))))))


__________________________________________________
Do You Yahoo!?
Tired of spam?  Yahoo! Mail has the best spam protection around 
http://mail.yahoo.com