Author: ksprotte Date: Mon Feb 11 07:30:08 2008 New Revision: 2463 Modified: branches/bos/projects/bos/web/tags.lisp Log: added again template-vars :sqm-x, :sqm-y. Also reindent/untabify Modified: branches/bos/projects/bos/web/tags.lisp ============================================================================== --- branches/bos/projects/bos/web/tags.lisp (original) +++ branches/bos/projects/bos/web/tags.lisp Mon Feb 11 07:30:08 2008 @@ -10,13 +10,13 @@ (defun language-options-1 (current-language) (loop for (language-symbol language-name) in (website-languages) - do (if (equal language-symbol current-language) - (html ((:option :value (format nil "/~a/index" language-symbol) :selected "selected") " " (:princ language-name) " ")) - (html ((:option :value (format nil "/~a/index" language-symbol)) " " (:princ language-name) " "))))) + do (if (equal language-symbol current-language) + (html ((:option :value (format nil "/~a/index" language-symbol) :selected "selected") " " (:princ language-name) " ")) + (html ((:option :value (format nil "/~a/index" language-symbol)) " " (:princ language-name) " "))))) (define-bknr-tag language-chooser (name) (html ((:select :name name) - (language-options-1 (current-website-language))))) + (language-options-1 (current-website-language))))) (define-bknr-tag language-options () (language-options-1 (current-website-language))) @@ -27,7 +27,7 @@ (define-bknr-tag process-payment (&key children) (with-template-vars (cartId transId email country) (let* ((contract (get-contract (parse-integer cartId))) - (sponsor (contract-sponsor contract))) + (sponsor (contract-sponsor contract))) (change-slot-values sponsor 'bknr.web::email email) (change-slot-values contract 'bos.m2::worldpay-trans-id transId) (sponsor-set-country sponsor country) @@ -40,13 +40,13 @@ (with-template-vars (gift email name address want-print) (let ((contract (find-store-object (parse-integer (get-template-var :contract-id))))) (when (equal want-print "no") - (contract-set-download-only-p contract t)) + (contract-set-download-only-p contract t)) (contract-issue-cert contract name :address address :language (session-variable :language)) (mail-worldpay-sponsor-data (get-template-var :request)) (bknr.web::redirect-request :target (if gift "index" - (format nil "profil_setup?name=~A&email=~A&sponsor-id=~A" - (uriencode-string name) (uriencode-string email) - (store-object-id (contract-sponsor contract)))))))) + (format nil "profil_setup?name=~A&email=~A&sponsor-id=~A" + (uriencode-string name) (uriencode-string email) + (store-object-id (contract-sponsor contract)))))))) (define-bknr-tag urkunde-per-post (&key contract-id min-amount message) (let ((contract (get-contract (parse-integer contract-id)))) @@ -60,81 +60,81 @@ (define-bknr-tag maybe-base (&key href) (when (and href - (not (equal "" href))) + (not (equal "" href))) (html ((:base "href" href))))) (define-bknr-tag buy-sqm (&key children) (handler-case (with-template-vars (numsqm numsqm1 action gift donationcert-yearly download-only) - (let* ((numsqm (parse-integer (or numsqm numsqm1))) - ;; Wer ueber dieses Formular bestellt, ist ein neuer - ;; Sponsor, also ein neues Sponsorenobjekt anlegen. Eine - ;; Profil-ID wird automatisch zugewiesen, sonstige Daten - ;; haben wir zu diesem Zeitpunkt noch nicht. - ;; Überweisung wird nur für die deutsche und dänische - ;; Website angeboten, was passenderweise durch die folgende - ;; Überprüfung auch sicher gestellt wurde. Sollte man aber - ;; eventuell noch mal prüfen und sicher stellen. - (manual-transfer (or (scan #?r"rweisen" action) - (scan #?r"rweisung" action) - (scan #?r"verf" action))) - (language (session-variable :language)) - (sponsor (make-sponsor :language language)) - (contract (make-contract sponsor numsqm - :download-only download-only - :expires (+ (if manual-transfer - bos.m2::*manual-contract-expiry-time* - bos.m2::*online-contract-expiry-time*) - (get-universal-time))))) - (destructuring-bind (price currency) - (case (make-keyword-from-string language) - (:da (list (* numsqm 24) "DKK")) - (t (list (* numsqm 3) "EUR"))) - (setf (get-template-var :worldpay-url) - (if manual-transfer - (format nil "ueberweisung?contract-id=~A&amount=~A&numsqm=~A~@[&donationcert-yearly=1~]" - (store-object-id contract) - price - numsqm - donationcert-yearly) - (format nil "https://select.worldpay.com/wcc/purchase?instId=~A&cartId=~A&amount=~A¤cy=~A&lang=~A&desc=~A&MC_sponsorid=~A&MC_password=~A&MC_donationcert-yearly=~A&MC_gift=~A~@[~A~]" - *worldpay-installation-id* - (store-object-id contract) - price - currency - language - (encode-urlencoded (format nil "~A ~A Samboja Lestari" - numsqm - (case (make-keyword-from-string language) - (:de "qm Regenwald in") - (:da "m2 Regnskov i") - (t "sqm rain forest in")))) - (store-object-id sponsor) - (sponsor-master-code sponsor) - (if donationcert-yearly "1" "0") - (if gift "1" "0") - (when *worldpay-test-mode* "&testMode=100")))))) - (mapc #'emit-template-node children)) + (let* ((numsqm (parse-integer (or numsqm numsqm1))) + ;; Wer ueber dieses Formular bestellt, ist ein neuer + ;; Sponsor, also ein neues Sponsorenobjekt anlegen. Eine + ;; Profil-ID wird automatisch zugewiesen, sonstige Daten + ;; haben wir zu diesem Zeitpunkt noch nicht. + ;; Überweisung wird nur für die deutsche und dänische + ;; Website angeboten, was passenderweise durch die folgende + ;; Überprüfung auch sicher gestellt wurde. Sollte man aber + ;; eventuell noch mal prüfen und sicher stellen. + (manual-transfer (or (scan #?r"rweisen" action) + (scan #?r"rweisung" action) + (scan #?r"verf" action))) + (language (session-variable :language)) + (sponsor (make-sponsor :language language)) + (contract (make-contract sponsor numsqm + :download-only download-only + :expires (+ (if manual-transfer + bos.m2::*manual-contract-expiry-time* + bos.m2::*online-contract-expiry-time*) + (get-universal-time))))) + (destructuring-bind (price currency) + (case (make-keyword-from-string language) + (:da (list (* numsqm 24) "DKK")) + (t (list (* numsqm 3) "EUR"))) + (setf (get-template-var :worldpay-url) + (if manual-transfer + (format nil "ueberweisung?contract-id=~A&amount=~A&numsqm=~A~@[&donationcert-yearly=1~]" + (store-object-id contract) + price + numsqm + donationcert-yearly) + (format nil "https://select.worldpay.com/wcc/purchase?instId=~A&cartId=~A&amount=~A¤cy=~A&lang=~A&desc=~A&MC_sponsorid=~A&MC_password=~A&MC_donationcert-yearly=~A&MC_gift=~A~@[~A~]" + *worldpay-installation-id* + (store-object-id contract) + price + currency + language + (encode-urlencoded (format nil "~A ~A Samboja Lestari" + numsqm + (case (make-keyword-from-string language) + (:de "qm Regenwald in") + (:da "m2 Regnskov i") + (t "sqm rain forest in")))) + (store-object-id sponsor) + (sponsor-master-code sponsor) + (if donationcert-yearly "1" "0") + (if gift "1" "0") + (when *worldpay-test-mode* "&testMode=100")))))) + (mapc #'emit-template-node children)) (bos.m2::allocation-areas-exhausted (e) (declare (ignore e)) (bknr.web::redirect-request :target "allocation-areas-exhausted")))) (define-bknr-tag mail-transfer () (with-query-params ((get-template-var :request) - country - contract-id - name vorname strasse plz ort) + country + contract-id + name vorname strasse plz ort) (let* ((contract (store-object-with-id (parse-integer contract-id))) - (download-only (< (contract-price contract) *mail-certificate-threshold*))) + (download-only (< (contract-price contract) *mail-certificate-threshold*))) (with-transaction (:prepare-before-mail) - (setf (contract-download-only contract) download-only) - (setf (sponsor-country (contract-sponsor contract)) country)) + (setf (contract-download-only contract) download-only) + (setf (sponsor-country (contract-sponsor contract)) country)) (contract-issue-cert contract (format nil "~A ~A" vorname name) - :address (format nil "~A ~A~%~A~%~A ~A" - vorname name - strasse - plz ort) - :language (session-variable :language)) + :address (format nil "~A ~A~%~A~%~A ~A" + vorname name + strasse + plz ort) + :language (session-variable :language)) (mail-manual-sponsor-data (get-template-var :request))))) (define-bknr-tag when-certificate (&key children) @@ -148,34 +148,36 @@ (define-bknr-tag save-profile (&key children) (let* ((sponsor (bknr-request-user (get-template-var :request))) - (contract (first (sponsor-contracts sponsor)))) + (contract (first (sponsor-contracts sponsor)))) (with-template-vars (email name password infotext anonymize) (when anonymize - (change-slot-values sponsor - 'full-name nil - 'info-text nil - 'email nil)) + (change-slot-values sponsor + 'full-name nil + 'info-text nil + 'email nil)) (when name - (change-slot-values sponsor 'full-name name)) + (change-slot-values sponsor 'full-name name)) (when email - (change-slot-values sponsor 'bknr.web::email email)) + (change-slot-values sponsor 'bknr.web::email email)) (when password - (set-user-password sponsor password)) + (set-user-password sponsor password)) (when infotext - (change-slot-values sponsor 'info-text infotext))) + (change-slot-values sponsor 'info-text infotext))) (setf (get-template-var :sponsor-id) (format nil "~D" (store-object-id sponsor))) (setf (get-template-var :contract-id) (format nil "~D" (store-object-id contract))) (setf (get-template-var :country) (sponsor-country sponsor)) (setf (get-template-var :infotext) (sponsor-info-text sponsor)) (setf (get-template-var :name) (user-full-name sponsor)) + (setf (get-template-var :sqm-x) (format nil "~,3f" (m2-utm-x (first (contract-m2s contract))))) + (setf (get-template-var :sqm-y) (format nil "~,3f" (m2-utm-y (first (contract-m2s contract))))) (setf (get-template-var :geo-coord) (multiple-value-bind (left top) - (contract-bounding-box contract) - (apply #'geometry:format-lon-lat nil - (geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ left) - (- +nw-utm-y+ top) +utm-zone+ t)))) + (contract-bounding-box contract) + (apply #'geometry:format-lon-lat nil + (geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ left) + (- +nw-utm-y+ top) +utm-zone+ t)))) (setf (get-template-var :numsqm) - (format nil "~D" - (apply #'+ (mapcar #'(lambda (contract) (length (contract-m2s contract))) (sponsor-contracts sponsor)))))) + (format nil "~D" + (apply #'+ (mapcar #'(lambda (contract) (length (contract-m2s contract))) (sponsor-contracts sponsor)))))) (mapc #'emit-template-node children)) (define-bknr-tag admin-login-page (&key children) @@ -185,7 +187,7 @@ (define-bknr-tag google-analytics-track () (html ((:script :type "text/javascript") - "var gaJsHost = (('https:' == document.location.protocol) ? 'https://ssl.' : 'http://www.'); + "var gaJsHost = (('https:' == document.location.protocol) ? 'https://ssl.' : 'http://www.'); document.write(unescape('%3Cscript src=%22' + gaJsHost + 'google-analytics.com/ga.js%22 type=%22text/javascript%22%3E%3C/script%3E'));") - ((:script :type "text/javascript") - (:princ #?"if (_gat) { var pageTracker = _gat._getTracker('$(*google-analytics-account*)'); pageTracker._initData(); pageTracker._trackPageview(); }")))) + ((:script :type "text/javascript") + (:princ #?"if (_gat) { var pageTracker = _gat._getTracker('$(*google-analytics-account*)'); pageTracker._initData(); pageTracker._trackPageview(); }"))))