Changeset 2644

Show
Ignore:
Timestamp:
03/03/08 09:54:57 (10 months ago)
Author:
hans
Message:

CCL fixes to prevent geo coordinate converter come up with complex numbers. Format fixes for coordinate printing.

Files:

Legend:

Unmodified
Added
Removed
Modified
Copied
Moved

  • trunk/projects/bos/m2/bos.m2.asd

    r2559 r2644  
    22 
    33(asdf:defsystem :bos.m2 
    4   :depends-on (:bknr.datastore :bknr.modules :cl-smtp :cl-mime :iconv :kmrcl :iterate :arnesi) 
     4  :depends-on (:bknr.datastore :bknr.modules :cl-smtp :cl-mime :iconv :kmrcl :iterate :arnesi :cl-pdf) 
    55  :components ((:file "packages") 
    66               (:file "geo-utm" :depends-on ("packages")) 

  • trunk/projects/bos/m2/geo-utm.lisp

    r2409 r2644  
    3737      (setq alpha 
    3838            (* (/ (+ sm-a sm-b) 2.0) 
    39                (+ (+ 1.0 (/ (expt n 2.0) 4.0)) 
    40                   (/ (expt n 4.0) 64.0)))) 
     39               (+ (+ 1.0 (/ (expt n 2) 4.0)) 
     40                  (/ (expt n 4) 64.0)))) 
    4141      (setq beta 
    4242            (+ 
    43              (+ (/ (* (- 3.0) n) 2.0) (/ (* 9.0 (expt n 3.0)) 16.0)) 
    44              (/ (* (- 3.0) (expt n 5.0)) 32.0))) 
     43             (+ (/ (* (- 3.0) n) 2.0) (/ (* 9.0 (expt n 3)) 16.0)) 
     44             (/ (* (- 3.0) (expt n 5)) 32.0))) 
    4545      (setq gamma 
    46             (+ (/ (* 15.0 (expt n 2.0)) 16.0) 
    47                (/ (* (- 15.0) (expt n 4.0)) 32.0))) 
     46            (+ (/ (* 15.0 (expt n 2)) 16.0) 
     47               (/ (* (- 15.0) (expt n 4)) 32.0))) 
    4848      (setq delta 
    49             (+ (/ (* (- 35.0) (expt n 3.0)) 48.0) 
    50                (/ (* 105.0 (expt n 5.0)) 256.0))) 
    51       (setq epsilon (/ (* 315.0 (expt n 4.0)) 512.0)) 
     49            (+ (/ (* (- 35.0) (expt n 3)) 48.0) 
     50               (/ (* 105.0 (expt n 5)) 256.0))) 
     51      (setq epsilon (/ (* 315.0 (expt n 4)) 512.0)) 
    5252      (setq result 
    5353            (* alpha 
    …… 
    7171      (setq alpha_ 
    7272            (* (/ (+ sm-a sm-b) 2.0) 
    73                (+ (+ 1 (/ (expt n 2.0) 4)) (/ (expt n 4.0) 64)))) 
     73               (+ (+ 1 (/ (expt n 2) 4)) (/ (expt n 4) 64)))) 
    7474      (setq y_ (/ y alpha_)) 
    7575      (setq beta_ 
    7676            (+ 
    77              (+ (/ (* 3.0 n) 2.0) (/ (* (- 27.0) (expt n 3.0)) 32.0)) 
    78              (/ (* 269.0 (expt n 5.0)) 512.0))) 
     77             (+ (/ (* 3.0 n) 2.0) (/ (* (- 27.0) (expt n 3)) 32.0)) 
     78             (/ (* 269.0 (expt n 5)) 512.0))) 
    7979      (setq gamma_ 
    80             (+ (/ (* 21.0 (expt n 2.0)) 16.0) 
    81                (/ (* (- 55.0) (expt n 4.0)) 32.0))) 
     80            (+ (/ (* 21.0 (expt n 2)) 16.0) 
     81               (/ (* (- 55.0) (expt n 4)) 32.0))) 
    8282      (setq delta_ 
    83             (+ (/ (* 151.0 (expt n 3.0)) 96.0) 
    84                (/ (* (- 417.0) (expt n 5.0)) 128.0))) 
    85       (setq epsilon_ (/ (* 1097.0 (expt n 4.0)) 512.0)) 
     83            (+ (/ (* 151.0 (expt n 3)) 96.0) 
     84               (/ (* (- 417.0) (expt n 5)) 128.0))) 
     85      (setq epsilon_ (/ (* 1097.0 (expt n 4)) 512.0)) 
    8686      (setq result 
    8787            (+ 
    …… 
    9999        (setq ep2 
    100100              (/ (- (expt sm-a 2.0) (expt sm-b 2.0)) 
    101                  (expt sm-b 2.0))) 
    102         (setq nu2 (* ep2 (expt (cos phi) 2.0))) 
    103         (setq n (/ (expt sm-a 2.0) (* sm-b (sqrt (+ 1 nu2))))) 
     101                 (expt sm-b 2))) 
     102        (setq nu2 (* ep2 (expt (cos phi) 2))) 
     103        (setq n (/ (expt sm-a 2) (* sm-b (sqrt (+ 1 nu2))))) 
    104104        (setq %t (tan phi)) 
    105105        (setq t2 (* %t %t)) 
    106         (setq tmp (- (* (* t2 t2) t2) (expt %t 6.0))) 
     106        (setq tmp (- (* (* t2 t2) t2) (expt %t 6))) 
    107107        (setq l (- lambda lambda0)) 
    108108        (setq l3coef (+ (- 1.0 t2) nu2)) 
    …… 
    124124          (+ 
    125125           (+ (* (* n (cos phi)) l) 
    126               (* (* (* (/ n 6.0) (expt (cos phi) 3.0)) l3coef) 
    127                  (expt l 3.0))) 
    128            (* (* (* (/ n 120.0) (expt (cos phi) 5.0)) l5coef) 
    129               (expt l 5.0))) 
    130           (* (* (* (/ n 5040.0) (expt (cos phi) 7.0)) l7coef) 
    131              (expt l 7.0))) 
     126              (* (* (* (/ n 6.0) (expt (cos phi) 3)) l3coef) 
     127                 (expt l 3))) 
     128           (* (* (* (/ n 120.0) (expt (cos phi) 5)) l5coef) 
     129              (expt l 5))) 
     130          (* (* (* (/ n 5040.0) (expt (cos phi) 7)) l7coef) 
     131             (expt l 7))) 
    132132         (+ 
    133133          (+ 
    134134           (+ 
    135135            (+ (arc-length-of-meridian phi) 
    136                (* (* (* (/ %t 2.0) n) (expt (cos phi) 2.0)) 
    137                   (expt l 2.0))) 
    138             (* (* (* (* (/ %t 24.0) n) (expt (cos phi) 4.0)) l4coef) 
    139                (expt l 4.0))) 
    140            (* (* (* (* (/ %t 720.0) n) (expt (cos phi) 6.0)) l6coef) 
    141               (expt l 6.0))) 
    142           (* (* (* (* (/ %t 40320.0) n) (expt (cos phi) 8.0)) l8coef) 
    143              (expt l 8.0)))))))) 
     136               (* (* (* (/ %t 2.0) n) (expt (cos phi) 2)) 
     137                  (expt l 2))) 
     138            (* (* (* (* (/ %t 24.0) n) (expt (cos phi) 4)) l4coef) 
     139               (expt l 4))) 
     140           (* (* (* (* (/ %t 720.0) n) (expt (cos phi) 6)) l6coef) 
     141              (expt l 6))) 
     142          (* (* (* (* (/ %t 40320.0) n) (expt (cos phi) 8)) l8coef) 
     143             (expt l 8)))))))) 
    144144 
    145145(defun map-xyto-lat-lon (x y lambda0) 
    …… 
    149149        (setq phif (footpoint-latitude y)) 
    150150        (setq ep2 
    151               (/ (- (expt sm-a 2.0) (expt sm-b 2.0)) 
    152                  (expt sm-b 2.0))) 
     151              (/ (- (expt sm-a 2) (expt sm-b 2)) 
     152                 (expt sm-b 2))) 
    153153        (setq cf (cos phif)) 
    154         (setq nuf2 (* ep2 (expt cf 2.0))) 
    155         (setq nf (/ (expt sm-a 2.0) (* sm-b (sqrt (+ 1 nuf2))))) 
     154        (setq nuf2 (* ep2 (expt cf 2))) 
     155        (setq nf (/ (expt sm-a 2) (* sm-b (sqrt (+ 1 nuf2))))) 
    156156        (setq nfpow nf) 
    157157        (setq tf (tan phif)) 
    …… 
    201201          (+ 
    202202           (+ (+ phif (* (* x2frac x2poly) (* x x))) 
    203               (* (* x4frac x4poly) (expt x 4.0))) 
    204            (* (* x6frac x6poly) (expt x 6.0))) 
    205           (* (* x8frac x8poly) (expt x 8.0))) 
     203              (* (* x4frac x4poly) (expt x 4))) 
     204           (* (* x6frac x6poly) (expt x 6))) 
     205          (* (* x8frac x8poly) (expt x 8))) 
    206206         (+ 
    207207          (+ 
    208208           (+ (+ lambda0 (* x1frac x)) 
    209               (* (* x3frac x3poly) (expt x 3.0))) 
    210            (* (* x5frac x5poly) (expt x 5.0))) 
    211           (* (* x7frac x7poly) (expt x 7.0)))))))) 
     209              (* (* x3frac x3poly) (expt x 3))) 
     210           (* (* x5frac x5poly) (expt x 5))) 
     211          (* (* x7frac x7poly) (expt x 7)))))))) 
    212212 
    213213(defun lon-lat-to-utm-x-y (lon lat) 
    …… 
    224224 
    225225(defun utm-x-y-to-lon-lat (x y zone southhemi-p) 
    226   "Returns two values LON and LAT." 
     226  "Returns list (LON LAT)." 
    227227  (let ((x (float x 0d0)) 
    228228        (y (float y 0d0)) 

  • trunk/projects/bos/m2/geometry.lisp

    r2632 r2644  
    286286 
    287287(defun format-decimal-degree (degree) 
    288   (format-mixed-radix-number nil (* 60 60 degree) '(60 60 360) '(" ~,2FÂŽÂŽ" " ~DÂŽ" "~D°"))) 
     288  (format-mixed-radix-number nil (* 60 60 degree) '(60 60 360) '("~,2FÂŽÂŽ" "~DÂŽ" "~D°"))) 
    289289 
    290290(defun format-lon-lat (stream lon lat) 
    291   (format stream "~A ~:[S~;N~], ~A ~:[W~;E~]" 
     291  (format stream "~A~:[S~;N~], ~A~:[W~;E~]" 
    292292          (format-decimal-degree (abs lat)) 
    293293          (plusp lat) 

  • trunk/projects/bos/m2/m2-pdf.lisp

    r2629 r2644  
    2727            (draw-coordinate 180 40 (m2-lon-lat last-m2)) 
    2828 
    29             (pdf:translate (+ 65.0 (if (> bb-width bb-height) 0 
     29            (pdf:translate (+ 65.0 (if (>= bb-width bb-height) 0 
    3030                                       (* 0.5 (abs (- bb-width bb-height)) scale))) 
    31                            (+ 65.0 (if (> bb-height bb-width) 0 
     31                           (+ 65.0 (if (>= bb-height bb-width) 0 
    3232                                       (* 0.5 (abs (- bb-width bb-height)) scale)))) 
    3333 

  • trunk/projects/bos/web/allocation-area-handlers.lisp

    r2599 r2644  
    144144       (redirect (format nil "/map-browser/~A/~A?heading=~A&chosen-url=~A&" 
    145145                         x y 
    146                          (uriencode-string "Choose lower right point of allocation area") 
    147                          (uriencode-string (format nil "~A?left=~A&top=~A&" 
     146                         (encode-urlencoded "Choose lower right point of allocation area") 
     147                         (encode-urlencoded (format nil "~A?left=~A&top=~A&" 
    148148                                                   (hunchentoot:request-uri) 
    149149                                                   x y))))) 
    …… 
    166166    (redirect (format nil "/map-browser/~A/~A?heading=~A&chosen-url=~A&" 
    167167                      start-x start-y 
    168                       (uriencode-string "Choose upper left point of allocation area") 
    169                       (uriencode-string (format nil "~A?" (hunchentoot:request-uri))))))) 
     168                      (encode-urlencoded "Choose upper left point of allocation area") 
     169                      (encode-urlencoded (format nil "~A?" (hunchentoot:request-uri))))))) 
    170170 
    171171(defmethod handle-form ((handler create-allocation-area-handler) (action (eql :upload))) 

  • trunk/projects/bos/web/kml-handlers.lisp

    r2479 r2644  
    66(defun kml-format-color (color &optional (opacity 255)) 
    77  (format nil "~2,'0X~{~2,'0X~}" opacity (reverse color))) 
    8  
    9 (defun utf-8-text (string) 
    10   ;; cxml::utf8-string-to-rod did not what we want, so we use 
    11   ;; utf-8-string-to-bytes instead 
    12   (cxml:text (utf-8-string-to-bytes string))) 
    138 
    149(defun contract-description (contract language) 
    …… 
    2520               (with-element "tr" 
    2621                 (with-element "td" (text "Name:")) 
    27                  (with-element "td" (utf-8-text (if name name "[anonymous]")))) 
     22                 (with-element "td" (if name name "[anonymous]"))) 
    2823               (with-element "tr" 
    2924                 (with-element "td" (text "Land:")) 
    …… 
    3126               (with-element "tr" 
    3227                 (with-element "td" (text "gesponsort:")) 
    33                  (with-element "td" (utf-8-text (format nil "~D m²" (length (contract-m2s contract)))))) 
     28                 (with-element "td" (format nil "~D m²" (length (contract-m2s contract))))) 
    3429               (with-element "tr" 
    3530                 (with-element "td" (text "seit:")) 
    3631                 (with-element "td" (text (format-date-time (contract-date contract) :show-time nil))))) 
    3732             (when (sponsor-info-text sponsor) 
    38                (utf-8-text (sponsor-info-text sponsor)))))))) 
     33               (sponsor-info-text sponsor))))))) 
    3934 
    4035(defclass contract-kml-handler (object-handler) 
    …… 
    5045              (name (user-full-name (contract-sponsor c)))) 
    5146          (with-element "Placemark" 
    52             (with-element "name" (utf-8-text (format nil "~A ~Dm²" 
    53                                                     (if name name "anonymous") 
    54                                                     (length (contract-m2s c))))) 
    55             (with-element "description" (utf-8-text (contract-description c :de))) 
     47            (with-element "name" (format nil "~A ~Dm²" 
     48                                         (if name name "anonymous") 
     49                                         (length (contract-m2s c)))) 
     50            (with-element "description" (contract-description c :de)) 
    5651            (with-element "Style" 
    5752              (attribute "id" "#region") 
    …… 
    7065          (when (eq c contract) 
    7166            (with-element "Placemark" 
    72               (with-element "name" (utf-8-text (format nil "~A ~Dm²" 
    73                                                       (if name name "anonymous") 
    74                                                       (length (contract-m2s c))))) 
    75               (with-element "description" (utf-8-text (contract-description c :de))) 
     67              (with-element "name" (format nil "~A ~Dm²" 
     68                                           (if name name "anonymous") 
     69                                           (length (contract-m2s c)))) 
     70              (with-element "description" (contract-description c :de)) 
    7671              (with-element "Point" 
    7772                (with-element "coordinates" 

  • trunk/projects/bos/web/map-handlers.lisp

    r2484 r2644  
    6969          operation-strings)) 
    7070 
    71 ;; trunk-reorg adaption 
    7271(defmethod handle-object ((handler image-tile-handler) tile) 
    7372  ;; xxx parse url another time - the parse result of 
    …… 
    7574  (destructuring-bind (x y &rest operation-strings) (decoded-handler-path handler) 
    7675    (declare (ignore x y)) 
    77     (let ((changed-time (image-tile-changed-time tile)) 
    78           (ims (hunchentoot:header-in :if-modified-since))) 
    79       (format t "Warning: not setting last-modified of *ent* to changed-time") 
    80       #+(or) 
    81       (format t "; image-tile-handler handle-object: changed-time: ~A if-modified-since: ~A~%" (format-date-time changed-time) ims) 
    82       (if (or (not ims) 
    83               (> changed-time (date-to-universal-time ims))) 
    84           (let ((image (image-tile-image tile (apply #'parse-operations operation-strings)))) 
    85             (emit-image-to-browser image :png 
    86                                    :date changed-time 
    87                                    :max-age 60) 
    88             (cl-gd:destroy-image image)) 
    89           (with-http-response () 
    90             (with-http-body () 
    91               ;; do nothing 
    92               )))))) 
     76    (let ((changed-time (image-tile-changed-time tile))) 
     77      (hunchentoot:handle-if-modified-since changed-time) 
     78      (let ((image (image-tile-image tile (apply #'parse-operations operation-strings)))) 
     79        (emit-image-to-browser image :png 
     80                               :date changed-time 
     81                               :max-age 60) 
     82        (cl-gd:destroy-image image))))) 
    9383 
    9484(defclass enlarge-tile-handler (image-tile-handler) 

  • trunk/projects/bos/web/news-tags.lisp

    r2484 r2644  
    3434 
    3535(define-bknr-tag news-item () 
    36   (let ((news-item (find-store-object (parse-integer (nth-value 1 (parse-url (get-template-var :request)))))) 
     36  (let ((news-item (find-store-object (parse-integer (nth-value 1 (parse-url))))) 
    3737        (language (hunchentoot:session-value :language))) 
    3838    (html ((:h1 :class "extra") 

  • trunk/projects/bos/web/packages.lisp

    r2560 r2644  
    22 
    33(defpackage :bos.web 
     4  (:nicknames :web :worldpay-test) 
    45  (:use :cl 
    56        :date-calc 
    …… 
    2324        :bos.m2 
    2425        :bos.m2.config) 
    25   (:nicknames :web :worldpay-test) 
    2626  (:shadowing-import-from :cl-interpol #:quote-meta-chars)     
    2727  (:export)) 

  • trunk/projects/bos/web/poi-handlers.lisp

    r2484 r2644  
    9696                     (cmslink (format nil "map-browser/~A/~A?chosen-url=~A" 
    9797                                      (first (poi-area poi)) (second (poi-area poi)) 
    98                                       (uriencode-string (format nil "~A?action=save&" (hunchentoot:request-uri)))) 
     98                                      (encode-urlencoded (format nil "~A?action=save&" (hunchentoot:request-uri)))) 
    9999                       "[relocate]")) 
    100100                    (t 
    101101                     (cmslink (format nil "map-browser/?chosen-url=~A" 
    102                                       (uriencode-string (format nil "~A?action=save&" (hunchentoot:request-uri)))) 
     102                                      (encode-urlencoded (format nil "~A?action=save&" (hunchentoot:request-uri)))) 
    103103                       "[choose]"))))) 
    104104        (:tr (:td "icon") 
    …… 
    365365      (setf (hunchentoot:header-out :expires) "-1") 
    366366      (with-http-body () 
    367         (let ((*standard-output* *html-stream*)) 
    368           (princ "<script language=\"JavaScript\">") (terpri) 
    369           (princ (make-poi-javascript (or (hunchentoot:session-value :language) *default-language*))) (terpri) 
    370           (princ "parent.poi_fertig(pois, anzahlSponsoren, anzahlVerkauft);") (terpri) 
    371           (format t "parent.last_sponsors([~{~A~^,~%~}]);" (mapcar #'contract-js (last-paid-contracts))) 
    372           (princ "</script>") (terpri))))) 
     367        (html 
     368         ((:script :language "JavaScript") 
     369          (:princ (make-poi-javascript (or (hunchentoot:session-value :language) *default-language*))) 
     370          (:princ "parent.poi_fertig(pois, anzahlSponsoren, anzahlVerkauft);") 
     371          (:princ (format nil "parent.last_sponsors([~{~A~^,~%~}]);" (mapcar #'contract-js (last-paid-contracts))))))))) 
    373372 
    374373(defclass poi-image-handler (object-handler) 

  • trunk/projects/bos/web/reports-xml-handler.lisp

    r2481 r2644  
    1111(defvar *year*) 
    1212(defvar *month-names* '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")) 
     13 
     14(defmethod cxml:unparse-attribute ((value (eql nil))) 
     15  "false") 
     16 
     17(defmethod cxml:unparse-attribute ((value (eql t))) 
     18  "true") 
    1319 
    1420(defmacro defreport (name arguments &body body) 

  • trunk/projects/bos/web/sponsor-handlers.lisp

    r2502 r2644  
    3939(defmethod handle-object-form ((handler edit-sponsor-handler) action (sponsor (eql nil))) 
    4040  (with-query-params (id key count) 
     41    (format t "id ~A key ~A count ~A~%" id key count) 
    4142    (when id 
    42       (redirect #?"/edit-sponsor/$(id)") 
    43       (return-from handle-object-form)) 
    44     (when (or key count) 
     43      (redirect #?"/edit-sponsor/$(id)")) 
     44    (if (or key count) 
    4545      (let ((regex (format nil "(?i)~A" key)) 
    4646            (found 0)) 
    …… 
    6767                 (return)))) 
    6868           (:tr ((:th :colspan "7") (:princ-safe (format nil "~A sponsor~:p ~A" found (if count "shown" "found")))))))) 
    69       (return-from handle-object-form))) 
    70   (with-bos-cms-page (:title "Find or Create Sponsor") 
    71     (html 
    72      ((:form :name "form") 
    73       ((:table) 
    74        (:tr ((:td :colspan "2") 
    75              (:h2 "Search for sponsor"))) 
    76        (:tr (:td "Sponsor- or Contract-ID") 
    77             (:td (text-field "id" :size 7))) 
    78        (:tr (:td "Email-Adress or name") 
    79             (:td (text-field "key"))) 
    80        (:tr (:td "Show new sponsors (enter count)") 
    81             (:td (text-field "count" :size 4))) 
    82        (:tr (:td (submit-button "search" "search"))) 
    83        (:tr (:td "") (:td ((:a :class "cmslink" 
    84                                :href "/reports-xml/all-contracts?download=contracts.xls") 
    85                            "Download complete sponsor DB in XML format"))) 
    86        (:tr ((:th :colspan "2" :align "left") 
    87              (:h2 "Create sponsor"))) 
    88        (:tr (:td "Date (DD.MM.YYYY)") 
    89             (:td (text-field "date" :size 10 :value (format-date-time (get-universal-time) :show-time nil)))) 
    90        (:tr (:td "Number of square meters") 
    91             (:td (text-field "numsqm" :size 5))) 
    92        (:tr (:td "Country code (2 chars)") 
    93             (:td (text-field "country" :size 2 :value "DE"))) 
    94        (:tr (:td "Email-Address") 
    95             (:td (text-field "email" :size 40))) 
    96        (:tr (:td "Language for communication and certificate") 
    97             (:td (language-selector "en"))) 
    98        (:tr (:td "Name for certificate") 
    99             (:td (text-field "name" :size 20))) 
    100        (:tr (:td "Postal address for certificate") 
    101             (:td (textarea-field "address" :rows 5 :cols 40))) 
    102        (:tr (:td "Issue donation cert at the end of the year") 
    103             (:td (checkbox-field "donationcert-yearly" "" :checked nil))) 
    104        (:tr (:td (submit-button "create" "create" :formcheck "javascript:return check_complete_sale()")))))))) 
     69      (with-bos-cms-page (:title "Find or Create Sponsor") 
     70        (html 
     71         ((:form :name "form") 
     72          ((:table) 
     73           (:tr ((:td :colspan "2") 
     74                 (:h2 "Search for sponsor"))) 
     75           (:tr (:td "Sponsor- or Contract-ID") 
     76                (:td (text-field "id" :size 7))) 
     77           (:tr (:td "Email-Adress or name") 
     78                (:td (text-field "key"))) 
     79           (:tr (:td "Show new sponsors (enter count)") 
     80                (:td (text-field "count" :size 4))) 
     81           (:tr (:td (submit-button "search" "search"))) 
     82           (:tr (:td "") (:td ((:a :class "cmslink" 
     83                                   :href "/reports-xml/all-contracts?download=contracts.xls") 
     84                               "Download complete sponsor DB in XML format"))) 
     85           (:tr ((:th :colspan "2" :align "left") 
     86                 (:h2 "Create sponsor"))) 
     87           (:tr (:td "Date (DD.MM.YYYY)") 
     88                (:td (text-field "date" :size 10 :value (format-date-time (get-universal-time) :show-time nil)))) 
     89           (:tr (:td "Number of square meters") 
     90                (:td (text-field "numsqm" :size 5))) 
     91           (:tr (:td "Country code (2 chars)") 
     92                (:td (text-field "country" :size 2 :value "DE"))) 
     93           (:tr (:td "Email-Address") 
     94                (:td (text-field "email" :size 40))) 
     95           (:tr (:td "Language for communication and certificate") 
     96                (:td (language-selector "en"))) 
     97           (:tr (:td "Name for certificate") 
     98                (:td (text-field "name" :size 20))) 
     99           (:tr (:td "Postal address for certificate") 
     100                (:td (textarea-field "address" :rows 5 :cols 40))) 
     101           (:tr (:td "Issue donation cert at the end of the year") 
     102                (:td (checkbox-field "donationcert-yearly" "" :checked nil))) 
     103           (:tr (:td (submit-button "create" "create" :formcheck "javascript:return check_complete_sale()")))))))))) 
    105104 
    106105(defun date-to-universal (date-string) 
    …… 
    262261                      (find-store-object (parse-integer sponsor-id-or-x) :class 'sponsor)) 
    263262                     (t 
    264                       (when (eq (find-class 'sponsor) (class-of bknr.web:*user*)) 
    265                        bknr.web:*user*))))) 
     263                      (and (typep (bknr-session-user) 'sponsor) 
     264                           (bknr-session-user)))))) 
    266265      (with-http-response (:content-type "text/html; charset=UTF-8") 
    267266        (with-http-body () 
    268           (let ((*standard-output* *html-stream*)) 
    269            (princ "<script language=\"JavaScript\">") (terpri) 
    270             (princ "var profil;") (terpri) 
     267          (html 
     268           ((:script :language "JavaScript") 
     269            (:princ "var profil;") 
    271270            (when (and sponsor (find-if #'contract-paidp (sponsor-contracts sponsor))) 
    272               (princ (make-m2-javascript sponsor)) (terpri)) 
    273             (princ "parent.qm_fertig(profil);") (terpri) 
    274             (princ "</script>") (terpri))))))) 
     271              (html (:princ (make-m2-javascript sponsor)))) 
     272            (:princ "parent.qm_fertig(profil);")))))))) 
    275273 
    276274(defclass sponsor-login-handler (page-handler) 
    …… 
    284282      (setf (hunchentoot:header-out :expires) "-1") 
    285283      (with-http-body () 
    286         (format *html-stream* "<script>~%parent.set_loginstatus('~A');~%</script>~%" 
    287                 (cond 
    288                   ((eq (find-class 'sponsor) (class-of bknr.web:*user*)) 
    289                    "logged-in") 
    290                   (__sponsorid 
    291                    "login-failed") 
    292                   (t 
    293                    "not-logged-in"))))))) 
     284        (html 
     285         ((:script :language "JavaScript") 
     286          (:princ (format nil  "parent.set_loginstatus('~A');" 
     287                          (cond 
     288                            ((typep (bknr-session-user) 'sponsor) 
     289                             "logged-in") 
     290                            (__sponsorid 
     291                             "login-failed") 
     292                            (t 
     293                             "not-logged-in")))))))))) 
    294294 
    295295(defclass cert-regen-handler (editor-only-handler edit-object-handler) 

  • trunk/projects/bos/web/startup.lisp

    r2484 r2644  
    4747  (when *webserver* 
    4848    (hunchentoot:stop-server *webserver*)) 
    49   (setf *hunchentoot-default-external-format* (flex:make-external-format :utf-8 :eol-style :lf)) 
     49  (setf hunchentoot:*hunchentoot-default-external-format* (flex:make-external-format :utf-8 :eol-style :lf)) 
    5050  (setq *webserver* (hunchentoot:start-server :port *port*))) 

  • trunk/projects/bos/web/tags.lisp

    r2590 r2644  
    4343        (contract-set-download-only-p contract t)) 
    4444      (contract-issue-cert contract name :address address :language (hunchentoot:session-value :language)) 
    45       (mail-worldpay-sponsor-data (get-template-var :request)) 
     45      (mail-worldpay-sponsor-data) 
    4646      (bknr.web::redirect-request :target (if gift "index" 
    4747                                              (format nil "profil_setup?name=~A&email=~A&sponsor-id=~A" 
    48                                                       (uriencode-string name) (uriencode-string email) 
     48                                                      (encode-urlencoded name) (encode-urlencoded email) 
    4949                                                      (store-object-id (contract-sponsor contract)))))))) 
    5050 
    …… 
    135135                                            plz ort) 
    136136                           :language (hunchentoot:session-value :language)) 
    137       (mail-manual-sponsor-data (get-template-var :request))))) 
     137      (mail-manual-sponsor-data)))) 
    138138 
    139139(define-bknr-tag when-certificate (&key children) 
    140   (let ((sponsor (bknr-request-user (get-template-var :request)))) 
     140  (let ((sponsor (bknr-session-user))) 
    141141    (when (some #'contract-pdf-pathname (sponsor-contracts sponsor)) 
    142142      (mapc #'emit-template-node children)))) 
    …… 
    147147 
    148148(define-bknr-tag save-profile (&key children) 
    149   (let* ((sponsor (bknr-request-user (get-template-var :request))) 
     149  (let* ((sponsor (bknr-session-user)) 
    150150         (contract (first (sponsor-contracts sponsor)))) 
    151151    (with-template-vars (email name password infotext anonymize) 
    …… 
    182182 
    183183(define-bknr-tag admin-login-page (&key children) 
    184   (if (editor-p (bknr-request-user (get-template-var :request))) 
     184  (if (editor-p (bknr-session-user)) 
    185185      (html (:head ((:meta :http-equiv "refresh" :content "0; url=/admin")))) 
    186186      (mapc #'emit-template-node children))) 

  • trunk/projects/bos/web/web-macros.lisp

    r2479 r2644  
    33(enable-interpol-syntax) 
    44 
    5 (defmacro with-bos-cms-page ((&key title response) &rest body) 
     5(defmacro with-bos-cms-page ((&key title (response hunchentoot:+http-ok+)) &rest body) 
    66  `(with-bknr-page (:title ,title :response ,response) 
    77    ,@body)) 
    …… 
    1515         (setf (hunchentoot:header-out :content-disposition) 
    1616               (format nil "attachment; filename=~A" download)))) 
    17     (with-http-body () 
    18       (let ((*xml-sink* (make-character-stream-sink xhtml-generator:*html-sink* :canonical nil))) 
    19         (with-xml-output *xml-sink* 
    20           (with-element ,root-element 
    21             ,@body)))))) 
     17    (with-output-to-string (s) 
     18      (let ((*xml-sink* (make-character-stream-sink s :canonical nil))) 
     19        (with-xml-output *xml-sink* 
     20          (with-element ,root-element 
     21            ,@body)))))) 
    2222 
    2323(defmacro with-xml-error-handler (() &body body) 

  • trunk/projects/bos/web/web-utils.lisp

    r2484 r2644  
    99(defmethod website-show-page ((website bos-website) fn title) 
    1010  (html 
    11    (princ "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">" *html-stream*) 
    12    (princ #\Newline *html-stream*) 
    1311   (:html 
    1412    (:head 
    …… 
    2826         "local time is " (:princ-safe (format-date-time)) 
    2927         " - " 
    30          (if (and (equal 'bknr-request (type-of *req*)) 
    31                   (bknr-request-user *req*)) 
    32              (html "logged in as " (html-link (bknr-request-user *req*))) 
     28         (if (bknr-session-user) 
     29             (html "logged in as " (html-link (bknr-session-user))) 
    3330             (html "not logged in")) 
    3431         " - current content language is " 
    …… 
    6158 
    6259(defun decode-ismap-query-string () 
    63   (let ((coord-string (caar (request-query req)))) 
     60  (let ((coord-string (caar (query-params)))) 
    6461    (when (and coord-string (scan #?r"^\d*,\d*$" coord-string)) 
    6562      (mapcar #'parse-integer (split "," coord-string))))) 

  • trunk/projects/bos/web/webserver.lisp

    r2488 r2644  
    112112  (with-query-params (logout) 
    113113    (when logout 
    114       (bknr.web::drop-session *session*))) 
     114      (hunchentoot:remove-session hunchentoot:*session*))) 
    115115  (let ((language (hunchentoot:session-value :language))) 
    116116    (redirect #?"/infosystem/$(language)/satellitenkarte.htm"))) 
    …… 
    169169        (call-next-method)))) 
    170170 
    171 ;; trunk-reorg adaption 
    172 ;; (defmethod authorize :after ((authorizer bos-authorizer) 
    173 ;;                           (req http-request) 
    174 ;;                           (ent net.aserve::entity)) 
    175 ;;   (let ((new-language (or (language-from-url (hunchentoot:request-uri)) 
    176 ;;                        (query-param "language"))) 
    177 ;;      (current-language (gethash :language (bknr-session-variables *session*)))) 
    178 ;;     (when (or (not current-language) 
    179 ;;            (and new-language 
    180 ;;                 (not (equal new-language current-language)))) 
    181 ;;       (setf (gethash :language (bknr-session-variables *session*)) 
    182 ;;          (or new-language 
    183 ;;              (find-browser-prefered-language) 
    184 ;;              *default-language*))))) 
     171(defmethod authorize :after ((authorizer bos-authorizer)) 
     172  (let ((new-language (or (languagen-from-url (hunchentoot:request-uri)) 
     173                          (query-param "language"))) 
     174        (current-language (hunchentoot:session-value :language))) 
     175    (when (or (not current-language) 
     176              (and new-language 
     177                   (not (equal new-language current-language)))) 
     178      (setf (hunchentoot:session-value :language) 
     179            (or new-language 
     180                (find-browser-prefered-language) 
     181                *default-language*))))) 
    185182 
    186183;;; TODOreorg 
    …… 
    203200                                        ("/edit-poi-image" edit-poi-image-handler) 
    204201                                        ("/edit-sponsor" edit-sponsor-handler) 
     202                                        ("/contract-kml" contract-kml-handler) 
     203                                        ("/contract-image" contract-image-handler) 
    205204                                        ("/contract" contract-handler) 
    206205                                        ("/reports-xml" reports-xml-handler)                                     
    …… 
    217216                                        ("/allocation-area-gfx" allocation-area-gfx-handler) 
    218217                                        ("/allocation-cache" allocation-cache-handler) 
    219                                         ("/contract-image" contract-image-handler) 
    220218                                        ("/certificate" certificate-handler) 
    221219                                        ("/cert-regen" cert-regen-handler) 
    …… 
    230228                                        ("/statistics" statistics-handler) 
    231229                                        ("/rss" rss-handler) 
    232                                         ("/contract-kml" contract-kml-handler) 
    233230                                        #+(or) 
    234231                                        ("/" redirect-handler