[cl-soap-cvs] CVS update: cl-soap/src/xsd.lisp - cl-soap-cvs@common-lisp.net - mailman3.common-lisp.net

19 Sep 2005

Update of /project/cl-soap/cvsroot/cl-soap/src
In directory common-lisp.net:/tmp/cvs-serv18986/src
Modified Files:
    xsd.lisp 
Log Message:
1st implementation of date,time&datetime conversions
Date: Mon Sep 19 18:27:04 2005
Author: scaekenberghe
Index: cl-soap/src/xsd.lisp
diff -u cl-soap/src/xsd.lisp:1.2 cl-soap/src/xsd.lisp:1.3

--- cl-soap/src/xsd.lisp:1.2	Fri Sep 16 09:51:15 2005
+++ cl-soap/src/xsd.lisp	Mon Sep 19 18:27:04 2005
@@ -1,6 +1,6 @@
 ;;;; -*- mode: lisp -*-
 ;;;;
-;;;; $Id: xsd.lisp,v 1.2 2005/09/16 07:51:15 scaekenberghe Exp $
+;;;; $Id: xsd.lisp,v 1.3 2005/09/19 16:27:04 scaekenberghe Exp $
 ;;;;
 ;;;; A partial implementation of the XML Schema Definition standard
 ;;;;
@@ -118,9 +118,115 @@
 (defun intern-xsd-type-name (name)
   (intern (string-upcase (actual-name name)) :keyword))
+;;; Date, Time and DateTime conversions
+
+(defvar *xsd-timezone* nil)
+
+(defun lisp->xsd-datetime (universal-time)
+  "1999-05-31T13:20:00.000-05:00"
+  (multiple-value-bind (second minute hour date month year day daylight-p timezone)
+      (if *xsd-timezone*
+          (decode-universal-time universal-time *xsd-timezone*)
+        (decode-universal-time universal-time))
+    (declare (ignore day daylight-p))
+    (let ((sign (if (minusp timezone) #- #+))
+          (timezone-hour (floor (* (abs timezone) 60) 60))
+          (timezone-minute (rem (* (abs timezone) 60) 60)))
+      (format nil "~4,'0d-~2,'0d-~2,'0dT~2,'0d:~2,'0d:~2,'0d.000~c~2,'0d:~2,'0d" 
+              year month date hour minute second sign timezone-hour timezone-minute))))
+
+(defun xsd-datetime->lisp (string)
+  "1999-05-31T13:20:00.000-05:00"
+  (let* ((contains-millis (position #. string))
+         (contains-timezone (or (position #: string :start 18) (position #\Z string)))
+         (year (parse-integer string :start 0 :end 4))
+         (month (parse-integer string :start 5 :end 7))
+         (date (parse-integer string :start 8 :end 10))
+         (hour (parse-integer string :start 11 :end 13))
+         (minute (parse-integer string :start 14 :end 16))
+         (second (parse-integer string :start 17 :end 19))
+         timezone-sign
+         timezone-hour
+         timezone-minute)
+    (when contains-timezone
+      (if (position #\Z string)
+          (setf timezone-sign 1 
+                timezone-hour 0
+                timezone-minute 0)
+        (if contains-millis
+            (setf timezone-sign (ecase (char string 23) (#- -1) (#+ +1))
+                  timezone-hour (parse-integer string :start 24 :end 26)
+                  timezone-minute (parse-integer string :start 27 :end 29))
+          (setf timezone-sign (ecase (char string 19) (#- -1) (#+ +1))
+                timezone-hour (parse-integer string :start 20 :end 22)
+                timezone-minute (parse-integer string :start 23 :end 25)))))
+    (if (or *xsd-timezone* contains-timezone)
+        (encode-universal-time second minute hour date month year 
+                               (if contains-timezone 
+                                   (* timezone-sign (+ timezone-hour (/ timezone-minute 60)))
+                                 *xsd-timezone*))
+      (encode-universal-time second minute hour date month year))))
+
+(defun lisp->xsd-date (universal-time)
+  "1999-05-31"
+  (multiple-value-bind (second minute hour date month year)
+      (if *xsd-timezone*
+          (decode-universal-time universal-time *xsd-timezone*)
+        (decode-universal-time universal-time))
+    (declare (ignore second minute hour))
+    (format nil "~4,'0d-~2,'0d-~2,'0d" year month date)))
+
+(defun xsd-date->lisp (string)
+  "1999-05-31"
+  (let ((year (parse-integer string :start 0 :end 4))
+        (month (parse-integer string :start 5 :end 7))
+        (date (parse-integer string :start 8 :end 10)))
+    (if *xsd-timezone*
+        (encode-universal-time 0 0 0 date month year *xsd-timezone*)
+      (encode-universal-time 0 0 0 date month year))))
+
+(defun lisp->xsd-time (universal-time)
+  "13:20:00.000-05:00"
+  (multiple-value-bind (second minute hour date month year day daylight-p timezone)
+      (if *xsd-timezone*
+          (decode-universal-time universal-time *xsd-timezone*)
+        (decode-universal-time universal-time))
+    (declare (ignore year month date day daylight-p))
+    (let ((sign (if (minusp timezone) #- #+))
+          (timezone-hour (floor (* (abs timezone) 60) 60))
+          (timezone-minute (rem (* (abs timezone) 60) 60)))
+      (format nil "~2,'0d:~2,'0d:~2,'0d.000~c~2,'0d:~2,'0d" 
+              hour minute second sign timezone-hour timezone-minute))))
+
+(defun xsd-time->lisp (string)
+  "13:20:00.000-05:00"
+  (let* ((contains-millis (position #. string))
+         (contains-timezone (position #: string :start 7))
+         (hour (parse-integer string :start 0 :end 2))
+         (minute (parse-integer string :start 3 :end 5))
+         (second (parse-integer string :start 6 :end 8))
+         timezone-sign
+         timezone-hour
+         timezone-minute)
+    (when contains-timezone
+      (if contains-millis
+          (setf timezone-sign (ecase (char string 12) (#- -1) (#+ +1))
+                timezone-hour (parse-integer string :start 13 :end 15)
+                timezone-minute (parse-integer string :start 16 :end 18))
+        (setf timezone-sign (ecase (char string 8) (#- -1) (#+ +1))
+              timezone-hour (parse-integer string :start 9 :end 11)
+              timezone-minute (parse-integer string :start 12 :end 14))))
+    (if (or *xsd-timezone* contains-timezone)
+        (encode-universal-time second minute hour 1 1 0
+                               (if contains-timezone 
+                                   (* timezone-sign (+ timezone-hour (/ timezone-minute 60)))
+                                 *xsd-timezone*))
+      (encode-universal-time second minute hour 1 1 0))))
+
+;;; Primitive Types/Values Conversions
+
 (defun xsd-primitive->lisp (value type)
   "Convert the XSD string value to a Common Lisp value, interpreting it as type"
-  ;; more work needed here ;-)
   (ecase type
     ((:string :normalizedString :token) 
      value)
@@ -140,15 +246,14 @@
            ((string-equal value "false") nil)
            (t (= (parse-integer value) 1))))
     (:duration value)
-    (:date value)
-    (:time value)
-    (:dateTime value)
+    (:date (xsd-date->lisp value))
+    (:time (xsd-time->lisp value))
+    (:dateTime (xsd-datetime->lisp value))
     ((:base64Binary :hexBinary) 
      (error "~a not yet supported as primitive type" type))))
(defun lisp->xsd-primitive (value type)
   "Convert the Common Lisp value to a XSD string value, interpreting it as type" 
-  ;; more work needed here ;-)
   (ecase type
     ((:string :normalizedString :token) 
      value)
@@ -166,9 +271,9 @@
     (:boolean 
      (if value "true" "false"))
     (:duration value)
-    (:date value)
-    (:time value)
-    (:dateTime value)
+    (:date (lisp->xsd-date value))
+    (:time (lisp->xsd-time value))
+    (:dateTime (lisp->xsd-datetime value))
     ((:base64Binary :hexBinary) 
      (error "~a not yet supported as primitive type" type))))

    