Revision: 4007 Author: hans URL: http://bknr.net/trac/changeset/4007

Certificate generation fixes

U trunk/projects/bos/cert-daemon/cert-daemon.sh U trunk/projects/bos/m2/m2-pdf.lisp U trunk/projects/bos/m2/m2.lisp U trunk/projects/bos/m2/make-certificate.lisp U trunk/thirdparty/cl-pdf/pdf-parser.lisp U trunk/thirdparty/cl-pdf/pdf.lisp

Modified: trunk/projects/bos/cert-daemon/cert-daemon.sh =================================================================== --- trunk/projects/bos/cert-daemon/cert-daemon.sh 2008-10-18 12:18:08 UTC (rev 4006) +++ trunk/projects/bos/cert-daemon/cert-daemon.sh 2008-10-20 21:04:54 UTC (rev 4007) @@ -10,32 +10,21 @@ echo "generating certs for contract $contract, language $language"

print_fdf_file=mail-spool/$contract-$language.fdf + print_m2s_pdf_file=mail-spool/$contract-m2s.pdf print_pdf_file=mail-spool/$contract.pdf + + download_m2s_pdf_file=download-spool/$contract-m2s.pdf download_fdf_file=download-spool/$contract-$language.fdf download_pdf_file=download-spool/$contract.pdf

- m2s_pdf_file=download-spool/$contract-m2s.pdf - - tmp1_file=/tmp/gen-cert-$$-1.pdf - tmp2_file=/tmp/gen-cert-$$-2.pdf - tmp3_file=/tmp/gen-cert-$$-3.pdf - tmp4_file=/tmp/gen-cert-$$-4.pdf - - trap "rm -f $tmp1_file $tmp2_file $tmp3_file $tmp4_file" EXIT - if [ $language = de -a -f $print_fdf_file ]; then - pdftk urkunde-print-$language.pdf fill_form $print_fdf_file output $tmp1_file flatten - pdftk $tmp1_file cat 1 output $tmp2_file - pdftk $tmp1_file cat 2 output $tmp3_file - pdftk $m2s_pdf_file background $tmp3_file output $tmp4_file - pdftk $tmp2_file $tmp4_file output $print_pdf_file + pdftk $print_m2s_pdf_file fill_form $print_fdf_file output $print_pdf_file $flatten echo generated $print_pdf_file fi

- pdftk urkunde-download-$language.pdf fill_form $download_fdf_file output $tmp1_file - pdftk $m2s_pdf_file background $tmp1_file output $download_pdf_file + pdftk $download_m2s_pdf_file fill_form $download_fdf_file output $download_pdf_file $flatten echo generated $download_pdf_file - rm -f $tmp1_file $tmp2_file $tmp3_file $tmp4_file $print_fdf_file $download_fdf_file + echo rm -f $print_m2s_pdf_file $print_fdf_file $download_m2s_pdf_file $download_fdf_file trap "" EXIT

}

Modified: trunk/projects/bos/m2/m2-pdf.lisp =================================================================== --- trunk/projects/bos/m2/m2-pdf.lisp 2008-10-18 12:18:08 UTC (rev 4006) +++ trunk/projects/bos/m2/m2-pdf.lisp 2008-10-20 21:04:54 UTC (rev 4007) @@ -8,68 +8,74 @@ (pdf:draw-left-text x y part font 8 300) (incf y 10))))

-(defun make-m2-pdf (contract &key print) - (pdf:with-document () - (pdf:with-page () - (pdf:in-text-mode - (destructuring-bind (bb-x bb-y bb-width bb-height) (contract-bounding-box contract) - (let* ((m2s (sort (copy-list (contract-m2s contract)) - (lambda (a b) - (if (= (m2-y a) (m2-y b)) - (- (m2-x a) (m2-x b)) - (- (m2-y b) (m2-y b)))))) - (first-m2 (first m2s)) - (last-m2 (first (last m2s))) - (scale (/ 80 (max bb-width bb-height)))) +(defun make-m2-pdf (contract &key print template) + (flet ((render-m2s () + (pdf:in-text-mode + (destructuring-bind (bb-x bb-y bb-width bb-height) (contract-bounding-box contract) + (let* ((m2s (sort (copy-list (contract-m2s contract)) + (lambda (a b) + (if (= (m2-y a) (m2-y b)) + (- (m2-x a) (m2-x b)) + (- (m2-y b) (m2-y b)))))) + (first-m2 (first m2s)) + (last-m2 (first (last m2s))) + (scale (/ 80 (max bb-width bb-height))))

- (draw-coordinate 110 160 (m2-lon-lat first-m2)) + (draw-coordinate 110 160 (m2-lon-lat first-m2))

- (unless (eq first-m2 last-m2) - (draw-coordinate 190 40 (m2-lon-lat last-m2))) + (unless (eq first-m2 last-m2) + (draw-coordinate 190 40 (m2-lon-lat last-m2)))

- (pdf:translate (+ 65.0 (if (>= bb-width bb-height) 0 - (* 0.5 (abs (- bb-width bb-height)) scale))) - (+ 65.0 (if (>= bb-height bb-width) 0 - (* 0.5 (abs (- bb-width bb-height)) scale)))) + (pdf:translate (+ 65.0 (if (>= bb-width bb-height) 0 + (* 0.5 (abs (- bb-width bb-height)) scale))) + (+ 65.0 (if (>= bb-height bb-width) 0 + (* 0.5 (abs (- bb-width bb-height)) scale))))

- (pdf:scale scale scale) + (pdf:scale scale scale)

- (pdf:set-line-width 0.05) - (pdf:set-gray-stroke 0.6) - (pdf:move-to 0 0) - (pdf:line-to 0 bb-height) - (pdf:line-to bb-width bb-height) - (pdf:line-to bb-width 0) - (pdf:close-and-stroke) - (pdf:stroke) + (pdf:set-line-width 0.05) + (pdf:set-gray-stroke 0.6) + (pdf:move-to 0 0) + (pdf:line-to 0 bb-height) + (pdf:line-to bb-width bb-height) + (pdf:line-to bb-width 0) + (pdf:close-and-stroke) + (pdf:stroke)

- (pdf:set-line-width 0.1) - (pdf:set-gray-stroke 0) - (pdf:set-gray-fill 0.6) - (pdf:set-line-join 2) + (pdf:set-line-width 0.1) + (pdf:set-gray-stroke 0) + (pdf:set-gray-fill 0.6) + (pdf:set-line-join 2)

- (dolist (m2 (contract-m2s contract)) - (let ((x (- (m2-x m2) bb-x)) - (y (- (m2-y m2) bb-y))) - (pdf:move-to x y) - (pdf:line-to x (1+ y)) - (pdf:line-to (1+ x) (1+ y)) - (pdf:line-to (1+ x) y) - (pdf:line-to x y) - (pdf:close-fill-and-stroke))))))) - - (with-open-file (f (contract-m2-pdf-pathname contract :print print) - :direction :output - :if-exists :supersede - :external-format :iso-8859-1) - ;; cl-pdf does not really handle non-ascii characters in a very - ;; usable manner. In order to avoid having to deal with - ;; embedding fonts and encoding, just work around the issue: - (princ (remove (code-char 194) - (with-output-to-string (s) - (let ((pdf:*compress-streams* nil)) - (pdf:write-document s)))) - f)) + (dolist (m2 (contract-m2s contract)) + (let ((x (- (m2-x m2) bb-x)) + (y (- (m2-y m2) bb-y))) + (pdf:move-to x y) + (pdf:line-to x (1+ y)) + (pdf:line-to (1+ x) (1+ y)) + (pdf:line-to (1+ x) y) + (pdf:line-to x y) + (pdf:close-fill-and-stroke))))))) + (save-pdf () + (pdf:write-document (contract-m2-pdf-pathname contract :print print)))) + (if template + (if print + (pdf:with-existing-document (template) + (pdf:with-existing-page (0) + (pdf:insert-original-page-content)) + (pdf:with-existing-page (1) + (pdf:insert-original-page-content) + (render-m2s)) + (save-pdf)) + (pdf:with-existing-document (template) + (pdf:with-existing-page (0) + (pdf:insert-original-page-content) + (render-m2s)) + (save-pdf))) + (pdf:with-document () + (pdf:with-page () + (render-m2s)) + (save-pdf))) t))

#+(or)

Modified: trunk/projects/bos/m2/m2.lisp =================================================================== --- trunk/projects/bos/m2/m2.lisp 2008-10-18 12:18:08 UTC (rev 4006) +++ trunk/projects/bos/m2/m2.lisp 2008-10-20 21:04:54 UTC (rev 4007) @@ -371,7 +371,8 @@ (warn "re-issuing cert for ~A" contract)) (contract-delete-certificate-files contract) (make-certificate contract name :address address :language language) - (unless (contract-download-only-p contract) + (when (and (equal language "de") + (not (contract-download-only-p contract))) (make-certificate contract name :address address :language language :print t)) (change-slot-values contract 'cert-issued t))

Modified: trunk/projects/bos/m2/make-certificate.lisp =================================================================== --- trunk/projects/bos/m2/make-certificate.lisp 2008-10-18 12:18:08 UTC (rev 4006) +++ trunk/projects/bos/m2/make-certificate.lisp 2008-10-20 21:04:54 UTC (rev 4007) @@ -33,7 +33,13 @@ verschickt und entsprechend eine andere Vorlage ausgewählt als für den Download der Urkunde" (let ((sponsor (contract-sponsor contract))) - (make-m2-pdf contract :print print) + (make-m2-pdf contract + :print print + :template (make-pathname :name (format nil "urkunde-~A-~A" + (if print "print" "download") + language) + :type "pdf" + :defaults *pdf-base-directory*)) (make-fdf-file (contract-fdf-pathname contract :language language :print print)

Modified: trunk/thirdparty/cl-pdf/pdf-parser.lisp =================================================================== --- trunk/thirdparty/cl-pdf/pdf-parser.lisp 2008-10-18 12:18:08 UTC (rev 4006) +++ trunk/thirdparty/cl-pdf/pdf-parser.lisp 2008-10-20 21:04:54 UTC (rev 4007) @@ -493,7 +493,10 @@ (defmacro with-existing-document ((file &key (creator "") author title subject keywords) &body body) `(let* ((*document* (read-pdf-file ,file)) (*root-page* (root-page *document*)) - (*page-number* 0)) + (*outlines-stack* (list (outline-root *document*))) + (*page* nil) + (*page-number* 0) + (*name-counter* 100)) (add-doc-info *document* :creator ,creator :author ,author :title ,title :subject ,subject :keywords ,keywords) ,@body))

Modified: trunk/thirdparty/cl-pdf/pdf.lisp =================================================================== --- trunk/thirdparty/cl-pdf/pdf.lisp 2008-10-18 12:18:08 UTC (rev 4006) +++ trunk/thirdparty/cl-pdf/pdf.lisp 2008-10-20 21:04:54 UTC (rev 4007) @@ -595,7 +595,6 @@ (*outlines-stack* (list (outline-root *document*))) (*page* nil) (*page-number* 0) - (*name-counter* 100) (*max-number-of-pages* ,max-number-of-pages)) (setf *root-page* (root-page *document*)) (catch 'max-number-of-pages-reached