[bknr-cvs] hans changed trunk/
BKNR Commits
bknr at bknr.net
Mon Oct 20 21:04:55 UTC 2008
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)
, at 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
More information about the Bknr-cvs
mailing list