X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fframework-ps.scm;h=ae97dbaf86ffada4614241493a3f11e6507dbd93;hb=f4c712ec8d705f02d42c5c00724de44554edd97e;hp=18038a61af164ce7963bbf7624859a9214f4dcdd;hpb=adc6cbf9a271370c1453bfca918f810d9f2906f1;p=lilypond.git

diff --git a/scm/framework-ps.scm b/scm/framework-ps.scm
index 18038a61af..ae97dbaf86 100644
--- a/scm/framework-ps.scm
+++ b/scm/framework-ps.scm
@@ -1,6 +1,6 @@
 ;;;; This file is part of LilyPond, the GNU music typesetter.
 ;;;;
-;;;; Copyright (C) 2004--2011 Han-Wen Nienhuys <hanwen@xs4all.nl>
+;;;; Copyright (C) 2004--2012 Han-Wen Nienhuys <hanwen@xs4all.nl>
 ;;;;
 ;;;; LilyPond is free software: you can redistribute it and/or modify
 ;;;; it under the terms of the GNU General Public License as published by
@@ -90,7 +90,7 @@
   (ly:outputter-dump-string
    outputter
    (string-append
-    (format "%%Page: ~a ~a\n" page-number page-number)
+    (format #f "%%Page: ~a ~a\n" page-number page-number)
     "%%BeginPageSetup\n"
     (if landscape?
 	"page-width output-scale lily-output-units mul mul 0 translate 90 rotate\n"
@@ -112,7 +112,7 @@
 	 (names (apply append (map extract-names fonts))))
     (apply string-append
 	   (map (lambda (f)
-		  (format
+		  (format #f
 		   (if load-fonts?
 		       "%%DocumentSuppliedResources: font ~a\n"
 		       "%%DocumentNeededResources: font ~a\n")
@@ -163,7 +163,7 @@
 		 "%%EndComments\n"))
 
 (define (procset file-name)
-  (format
+  (format #f
    "%%BeginResource: procset (~a) 1 0
 ~a
 %%EndResource
@@ -171,7 +171,7 @@
    file-name (cached-file-contents file-name)))
 
 (define (embed-document file-name)
-  (format "%%BeginDocument: ~a
+  (format #f "%%BeginDocument: ~a
 ~a
 %%EndDocument
 "
@@ -190,10 +190,10 @@
 (define-public (ps-embed-cff body font-set-name version)
   (let* ((binary-data
 	  (string-append
-	   (format "/~a ~s StartData " font-set-name (string-length body))
+	   (format #f "/~a ~s StartData " font-set-name (string-length body))
 	   body))
 	 (header
-	  (format
+	  (format #f
 	   "%%BeginResource: font ~a
 %!PS-Adobe-3.0 Resource-FontSet
 %%DocumentNeededResources: ProcSet (FontSetInit)
@@ -227,11 +227,11 @@
 	      (begin
 		(set! file-name (ly:string-substitute (ly:get-option 'datadir)
 						      "" file-name))
-		(format
+		(format #f
 		 "lilypond-datadir (~a) concatstrings (r) file .loadfont\n"
 		 file-name))
-	      (format "(~a) (r) file .loadfont\n" file-name))
-	  (format "% cannot find font file: ~a\n" file-name)))
+	      (format #f "(~a) (r) file .loadfont\n" file-name))
+	  (format #f "% cannot find font file: ~a\n" file-name)))
 
     (let* ((font (car font-name-filename))
 	   (name (cadr font-name-filename))
@@ -243,7 +243,7 @@
 		(cond
 		 ((internal-font? file-name)
 		  (ps-load-file (ly:find-file
-				 (format "~a.otf" file-name))))
+				 (format #f "~a.otf" file-name))))
 		 ((string? bare-file-name)
 		  (ps-load-file file-name))
 		 (else
@@ -263,7 +263,7 @@
 	    (dir-helper dir (cons e lst)))))
     (reverse (dir-helper (opendir dir-name) '())))
 
-  (define (handle-mac-font name filename)
+  (define (handle-mac-font name file-name)
     (let* ((dir-name (tmpnam))
 	   (files '())
 	   (status 0)
@@ -291,7 +291,7 @@
 	  (begin
 	    (set! embed "% failed\n")
 	    (ly:warning (_ "cannot extract file matching ~a from ~a")
-			name filename)))
+			name file-name)))
       embed))
 
   (define (font-file-as-ps-string name file-name font-index)
@@ -379,6 +379,7 @@
 	   (pfas (map font-loader font-names)))
       pfas))
 
+
   (display "%%BeginProlog\n" port)
   (format
    port
@@ -398,8 +399,49 @@
   (display "%%EndProlog\n" port)
   (display "%%BeginSetup\ninit-lilypond-parameters\n%%EndSetup\n\n" port))
 
+(define (ps-quote str)
+        (fold
+          (lambda (replacement-list result)
+                  (string-join
+                    (string-split
+                      result
+                      (car replacement-list))
+                    (cadr replacement-list)))
+          str
+          '((#\\ "\\\\") (#\( "\\(") (#\) "\\)"))))
+
+;;; Create DOCINFO pdfmark containing metadata
+;;; header fields with pdf prefix override those without the prefix
+(define (handle-metadata header port)
+  (define (metadata-encode val)
+    ;; First, call ly:encode-string-for-pdf to encode the string (latin1 or
+    ;; utf-16be), then escape all parentheses and backslashes
+    ;; FIXME guile-2.0: use (string->utf16 str 'big) instead
+
+    (ps-quote (ly:encode-string-for-pdf val)))
+  (define (metadata-lookup-output overridevar fallbackvar field)
+    (let* ((overrideval (ly:modules-lookup (list header) overridevar))
+	   (fallbackval (ly:modules-lookup (list header) fallbackvar))
+	   (val (if overrideval overrideval fallbackval)))
+      (if val
+	  (format port "/~a (~a)\n" field (metadata-encode (markup->string val))))))
+  (display "[ " port)
+  (metadata-lookup-output 'pdfcomposer 'composer "Author")
+  (format port "/Creator (LilyPond ~a)\n" (lilypond-version))
+  (metadata-lookup-output 'pdftitle 'title "Title")
+  (metadata-lookup-output 'pdfsubject 'subject "Subject")
+  (metadata-lookup-output 'pdfkeywords 'keywords "Keywords")
+  (metadata-lookup-output 'pdfmodDate 'modDate "ModDate")
+  (metadata-lookup-output 'pdfsubtitle 'subtitle "Subtitle")
+  (metadata-lookup-output 'pdfcomposer 'composer "Composer")
+  (metadata-lookup-output 'pdfarranger 'arranger "Arranger")
+  (metadata-lookup-output 'pdfpoet 'poet "Poet")
+  (metadata-lookup-output 'pdfcopyright 'copyright "Copyright")
+  (display "/DOCINFO pdfmark\n\n" port))
+
+
 (define-public (output-framework basename book scopes fields)
-  (let* ((filename (format "~a.ps" basename))
+  (let* ((filename (format #f "~a.ps" basename))
 	 (outputter (ly:make-paper-outputter
 		     ;; FIXME: better wrap open/open-file,
 		     ;; content-mangling is always bad.
@@ -407,6 +449,7 @@
 		     (open-file filename "wb")
 		     'ps))
 	 (paper (ly:paper-book-paper book))
+	 (header (ly:paper-book-header book))
 	 (systems (ly:paper-book-systems book))
 	 (page-stencils (map page-stencil (ly:paper-book-pages book)))
 	 (landscape? (eq? (ly:output-def-lookup paper 'landscape) #t))
@@ -422,6 +465,8 @@
     ;; don't do BeginDefaults PageMedia: A4
     ;; not necessary and wrong
     (write-preamble paper #t port)
+    (if (module? header)
+	(handle-metadata header port))
     (for-each
      (lambda (page)
        (set! page-number (1+ page-number))
@@ -486,7 +531,7 @@
 		     ;; FIXME: better wrap open/open-file,
 		     ;; content-mangling is always bad.
 		     ;; MINGW hack: need to have "b"inary for embedding CFFs
-		     (open-file (format "~a.eps" filename) "wb")
+		     (open-file (format #f "~a.eps" filename) "wb")
 		     'ps))
 	 (port (ly:outputter-port outputter))
 	 (rounded-bbox (to-rounded-bp-box bbox))
@@ -518,7 +563,7 @@
 	      (bbox (list (car xext) (car yext)
 			  (cdr xext) (cdr yext)))
 	      (filename (if (< 0 count)
-			    (format "~a-~a" basename count)
+			    (format #f "~a-~a" basename count)
 			    basename)))
 	 (set! count (1+ count))
 	 (dump-stencil-as-EPS-with-bbox paper
@@ -527,10 +572,10 @@
 					(ly:get-option 'include-eps-fonts)
 					bbox)
 	 (if do-pdf
-	     (postscript->pdf 0 0 (format "~a.eps" filename)))
+	     (postscript->pdf 0 0 (format #f "~a.eps" filename)))
 	 (if do-png
 	     (postscript->png (ly:get-option 'resolution) 0 0
-			      (format "~a.eps" filename)))))
+			      (format #f "~a.eps" filename)))))
      extents-system-pairs)))
 
 (define-public (clip-system-EPSes basename paper-book)
@@ -545,7 +590,7 @@
       (for-each
        (lambda (region)
 	 (clip-systems-to-region
-	  (format "~a-from-~a-to-~a-clip"
+	  (format #f "~a-from-~a-to-~a-clip"
 		  basename
 		  (rhythmic-location->file-string (car region))
 		  (rhythmic-location->file-string (cdr region)))
@@ -574,7 +619,7 @@
 		(if (pair? system-list)
 		    (clip-score-systems
 		     (if (> count 0)
-			 (format "~a-~a" basename count)
+			 (format #f "~a-~a" basename count)
 			 basename)
 		     system-list)))
 	      score-system-list)))
@@ -587,10 +632,10 @@
 			 (stack-stencils Y DOWN 0.0
 					 (map paper-system-stencil
 					      (reverse to-dump-systems)))
-			 (format "~a.preview" basename)
+			 (format #f "~a.preview" basename)
 			 #t)
     (postprocess-output book framework-ps-module
-			(format "~a.preview.eps" basename)
+			(format #f "~a.preview.eps" basename)
 			(cons "png" (ly:output-formats)))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;