[bknr-cvs] r2041 - branches/xml-class-rework/projects/bos/m2

[bknr at bknr.net]

Author: hhubner
Date: 2006-10-24 13:07:54 -0400 (Tue, 24 Oct 2006)
New Revision: 2041

Modified:
   branches/xml-class-rework/projects/bos/m2/mail-generator.lisp
Log:
Beautified vCard generator


Modified: branches/xml-class-rework/projects/bos/m2/mail-generator.lisp
===================================================================
--- branches/xml-class-rework/projects/bos/m2/mail-generator.lisp	2006-10-24 10:06:58 UTC (rev 2040)
+++ branches/xml-class-rework/projects/bos/m2/mail-generator.lisp	2006-10-24 17:07:54 UTC (rev 2041)
@@ -81,19 +81,12 @@
 
 Das Team von BOS Deutschland e.V.")))
 
-(defun ensure-list (thing)
-  (if (listp thing) thing (list thing)))
-
-(defun make-vcard (&key contract-id sponsor-id worldpay-transaction-id
-		   donationcert-yearly gift
-		   vorname nachname
-		   name
-		   address postcode country
-		   strasse ort
-		   email tel)
+(defun format-vcard (field-list)
   (with-output-to-string (s)
     (labels
-	((vcard-field (field-spec values)
+	((ensure-list (thing)
+	   (if (listp thing) thing (list thing)))
+	 (vcard-field (field-spec &rest values)
 	   (let* ((values (mapcar (lambda (value) (or value "")) (ensure-list values)))
 		  (encoded-values (mapcar (lambda (string) (cl-qprint:encode (iconv:iconv "UTF-8" "ISO-8859-1" (or string ""))
 									     :encode-newlines t)) values)))
@@ -102,31 +95,40 @@
 			     (unless (equal values encoded-values)
 			       '("CHARSET=ISO-8859-1" "ENCODING=QUOTED-PRINTABLE")))
 		     encoded-values))))
-      (vcard-field 'begin "VCARD")
-      (vcard-field 'version "2.1")
-      (vcard-field 'rev (format-date-time (get-universal-time) :xml-style t))
-      (vcard-field 'fn (if name name (format nil "~A ~A" vorname nachname)))
-      (when vorname
-	(vcard-field 'n (list nachname vorname nil nil nil)))
-      (when address
-	(vcard-field '(adr dom home)
-		     (list nil nil address nil nil postcode country)))
-      (when strasse
-	(vcard-field '(adr dom home)
-		     (list nil nil strasse ort nil postcode country)))
-      (when tel
-	(vcard-field '(tel work home)
-		     tel))
-      (vcard-field '(email pref internet) email)
-      (vcard-field '(url work) (format nil "~A/edit-sponsor/~A" *website-url* sponsor-id))
-      (vcard-field 'note (format nil "Contract ID: ~A~%Sponsor ID: ~A~%~@[WorldPay Transaction ID: ~A~%~]Donationcert yearly: ~A~%Gift: ~A~%"
-				      contract-id
-				      sponsor-id
-				      worldpay-transaction-id
-				      (if donationcert-yearly "Yes" "No")
-				      (if gift "Yes" "No")))
-      (vcard-field 'end "VCARD"))))
+      (dolist (field field-list)
+	(when field
+	  (apply #'vcard-field field))))))
 
+(defun make-vcard (&key contract-id sponsor-id worldpay-transaction-id
+		   donationcert-yearly gift
+		   vorname nachname
+		   name
+		   address postcode country
+		   strasse ort
+		   email tel)
+  (format-vcard
+   `((BEGIN "VCARD")
+     (VERSION "2.1")
+     (REV ,(format-date-time (get-universal-time) :xml-style t))
+     (FN ,(if name name (format nil "~A ~A" vorname nachname)))
+     ,(when vorname
+	`(N ,nachname ,vorname nil nil nil))
+     ,(when address
+	`((ADR DOM HOME) nil nil ,address nil nil ,postcode ,country))
+     ,(when strasse
+	`((ADR DOM HOME) nil nil ,strasse ,ort nil ,postcode ,country))
+     ,(when tel
+	`((TEL WORK HOME) ,tel))
+     ((EMAIL PREF INTERNET) ,email)
+     ((URL WORK) ,(format nil "~A/edit-sponsor/~A" *website-url* sponsor-id))
+     (NOTE ,(format nil "Contract ID: ~A~%Sponsor ID: ~A~%~@[WorldPay Transaction ID: ~A~%~]Donationcert yearly: ~A~%Gift: ~A~%"
+		    contract-id
+		    sponsor-id
+		    worldpay-transaction-id
+		    (if donationcert-yearly "Yes" "No")
+		    (if gift "Yes" "No")))
+     (END "VCARD"))))
+
 (defun worldpay-callback-request-to-vcard (request)
   (with-query-params (request cartId
 			      transId