[cl-soap-cvs] CVS update: cl-soap/src/xsd.lisp
Sven Van Caekenberghe
scaekenberghe at common-lisp.net
Mon Sep 19 16:27:07 UTC 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))))
More information about the Cl-soap-cvs
mailing list