Changeset 3374
- Timestamp:
- 06/29/08 16:21:30 (6 months ago)
- Files:
-
- trunk/projects/bos/m2/bos.m2.asd (modified) (1 diff)
- trunk/projects/bos/m2/cert-daemon.lisp (modified) (2 diffs)
- trunk/projects/bos/m2/m2-pdf.lisp (modified) (4 diffs)
- trunk/projects/bos/m2/m2.lisp (modified) (1 diff)
- trunk/projects/bos/m2/make-certificate.lisp (modified) (2 diffs)
- trunk/projects/bos/web/startup.lisp (modified) (1 diff)
- trunk/projects/bos/web/webserver.lisp (modified) (2 diffs)
Legend:
- Unmodified
- Added
- Removed
- Modified
- Copied
- Moved
trunk/projects/bos/m2/bos.m2.asd
r3166 r3374 21 21 "geo-utm" 22 22 "geometry")) 23 (:file "m2-pdf" :depends-on ("m2")) 23 24 (:file "contract-expiry" :depends-on ("m2")) 24 25 (:file "allocation" :depends-on ("m2")) trunk/projects/bos/m2/cert-daemon.lisp
r2967 r3374 12 12 (format nil "\"~A~{ ~A~}\"" program program-args) (process-exit-code process) error-message)))) 13 13 14 (defun fill-form (fdf-pathname pdf-pathname output-pathname)14 (defun fill-form (fdf-pathname pdf-pathname m2-pdf-pathname output-pathname) 15 15 (handler-case 16 ( progn16 (with-temporary-file (temporary-pdf-pathname :defaults #P"/tmp/.pdf") 17 17 (cond 18 18 ((namestring pdf-pathname) 19 19 (run-tool "pdftk" (list (namestring pdf-pathname) 20 20 "fill_form" (namestring fdf-pathname) 21 "output" (namestring output-pathname)21 "output" (namestring temporary-pdf-pathname) 22 22 "flatten")) 23 (run-tool "pdftk" (list (namestring m2-pdf-pathname) 24 "background" (namestring temporary-pdf-pathname) 25 "output" (namestring output-pathname))) 23 26 (format t "; generated ~A~%" output-pathname)) 24 27 (t … … 33 36 :key #'pathname-type)) 34 37 (handler-case 35 (destructuring-bind (id &optional (country "en")) (split "-" (pathname-name fdf-pathname)) 36 (let ((language-specific-template-pathname (merge-pathnames (make-pathname :name (format nil "~A-~A" (pathname-name template-pathname) country)) 37 template-pathname)) 38 (destructuring-bind (id &optional (country "en")) 39 (split "-" (pathname-name fdf-pathname)) 40 (let ((language-specific-template-pathname (merge-pathnames 41 (make-pathname :name (format nil "~A-~A" (pathname-name template-pathname) 42 country)) 43 template-pathname)) 44 (m2-pdf-pathname (merge-pathnames 45 (make-pathname :name (format nil "~A-m2s" id)) 46 fdf-pathname)) 38 47 (output-pathname (merge-pathnames (make-pathname :name id :type "pdf") fdf-pathname))) 39 (fill-form fdf-pathname (if (probe-file language-specific-template-pathname) 48 (fill-form fdf-pathname 49 (if (probe-file language-specific-template-pathname) 40 50 language-specific-template-pathname 41 51 template-pathname) 52 m2-pdf-pathname 42 53 output-pathname))) 43 54 (error (e) trunk/projects/bos/m2/m2-pdf.lisp
r2644 r3374 9 9 (incf y 10)))) 10 10 11 (defun contract-pdf (contract pdf-pathname)11 (defun make-m2-pdf (contract &key print) 12 12 (pdf:with-document () 13 13 (pdf:with-page () … … 23 23 (scale (/ 80 (max bb-width bb-height)))) 24 24 25 (draw-coordinate 1 00 160 (m2-lon-lat first-m2))25 (draw-coordinate 110 160 (m2-lon-lat first-m2)) 26 26 27 (draw-coordinate 180 40 (m2-lon-lat last-m2)) 27 (unless (eq first-m2 last-m2) 28 (draw-coordinate 190 40 (m2-lon-lat last-m2))) 28 29 29 30 (pdf:translate (+ 65.0 (if (>= bb-width bb-height) 0 … … 56 57 (pdf:line-to (1+ x) y) 57 58 (pdf:line-to x y) 58 (pdf: fill-and-stroke)))))))59 (pdf:close-fill-and-stroke))))))) 59 60 60 (with-open-file (f pdf-pathname:direction :output :if-exists :supersede)61 (with-open-file (f (contract-m2-pdf-pathname contract :print print) :direction :output :if-exists :supersede) 61 62 ;; cl-pdf does not really handle non-ascii characters in a very 62 63 ;; usable manner. In order to avoid having to deal with … … 68 69 f)) 69 70 t)) 71 70 72 #+(or) 71 ( contract-pdf (random-elt (class-instances 'contract)) "/tmp/out.pdf")73 (make-m2-pdf (random-elt (class-instances 'contract))) trunk/projects/bos/m2/m2.lisp
r3161 r3374 310 310 :type "fdf") 311 311 (if print *cert-mail-directory* *cert-download-directory*))) 312 313 (defmethod contract-m2-pdf-pathname ((contract contract) &key print) 314 (merge-pathnames (make-pathname :name (format nil "~D-m2s" (store-object-id contract)) 315 :type "pdf") 316 (if print bos.m2::*cert-mail-directory* bos.m2::*cert-download-directory*))) 312 317 313 318 (defmethod contract-pdf-pathname ((contract contract) &key print) trunk/projects/bos/m2/make-certificate.lisp
r2499 r3374 34 34 Download der Urkunde" 35 35 (let ((sponsor (contract-sponsor contract))) 36 (make-m2-pdf contract :print print) 36 37 (make-fdf-file (contract-fdf-pathname contract 37 38 :language language … … 42 43 :sponsor-id (sponsor-id sponsor) 43 44 :master-code (sponsor-master-code sponsor) 44 :sqm-count (length (contract-m2s contract)) 45 ;; :sqm-ids (with-output-to-string (s) 46 ;; (loop for group in (group-by (mapcar #'m2-num-string (contract-m2s contract)) *num-coords-per-line*) 47 ;; do (loop for nums on group 48 ;; do (princ (car nums) s) 49 ;; do (princ (if (cdr nums) #\Tab #\Newline) s)))) 50 ;; should later be called :sqm-coordinates 51 :sqm-ids 52 (flet ((format-point (stream x y) 53 (apply #'geometry:format-lon-lat stream 54 (geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ x) 55 (- +nw-utm-y+ y) +utm-zone+ t)))) 56 (destructuring-bind (left top width height) 57 (contract-bounding-box contract) 58 (with-output-to-string (out) 59 (format-point out left top) (terpri out) 60 (format-point out (+ left width) (+ top height)) (terpri out))))))) 45 :sqm-count (length (contract-m2s contract))))) trunk/projects/bos/web/startup.lisp
r3358 r3374 12 12 13 13 (defvar *port*) 14 (defvar *listeners*)15 14 (defvar *website-directory*) 16 15 (defvar *website-url*) trunk/projects/bos/web/webserver.lisp
r3294 r3374 185 185 (push (hunchentoot:create-folder-dispatcher-and-handler prefix destination) hunchentoot:*dispatch-table*)) 186 186 187 (defun publish-website (&key website-directory website-url (worldpay-test-mode t) (vhosts :wild))187 (defun publish-website (&key website-directory website-url (worldpay-test-mode t)) 188 188 (setf *website-directory* website-directory) 189 189 … … 265 265 :site-logo-url "/images/bos-logo.gif" 266 266 :style-sheet-urls '("/static/cms.css") 267 :javascript-urls '("/static/cms.js" "/static/tiny_mce/tiny_mce.js") 268 :vhosts vhosts) 267 :javascript-urls '("/static/cms.js" "/static/tiny_mce/tiny_mce.js")) 269 268 270 269 (publish-directory :prefix "/static/"
