Print out header fields as PDF metadata; Add simple markup->string function

-) Create DOCINFO pdfmark, with the metadata fields extracted
   from the \header block

-) Add scheme function markup->string that extracts and returns only the
   string part of a markup. As all header fields are possibly markups,
   we need to call this function on the header fields and use only
   the string representation (formatting and possibly some information
   lost!) as metadata.
   This function is very simply (for all known text markup functions,
   it extracts the text and ignores the formatting, all other markup
   functions are entirely ignored), so it might not work perfectly
   for complex markups.

-) Add possibility to override a header field with the same name, but
   a pdf prefix, to force a particular metadata string, which is not
   displayed in the pdf. E.g. if the \header block contains
       pdftitle = "Title for pdf file"
   then that pdftitle header field will be used for the document title
   in the PDF metadata instead of the title header field.

diff --git a/input/regression/pdfmark-metadata.ly b/input/regression/pdfmark-metadata.ly
new file mode 100644 (file)
index 0000000..16f47eb
--- /dev/null
+++ b/input/regression/pdfmark-metadata.ly
@@ -0,0 +1,19 @@
+\version "2.13.47"
+
+\header {
+  texidoc = "The PDF backend uses several header fields to store metadata
+in the resulting PDF file. Header fields with the prefix pdf override
+those without the prefix for PDF creation (not for visual display on the page).
+"
+
+  title = \markup { \italic "Title of " \bold \concat {"the" " " \abs-fontsize #27 "piece"} }
+  subtitle = \markup { \concat { "Subtitle" " of" " the" " " \natural "piece" }}
+  composer = \markup { \bold \concat {"The" " " "Genius" " " "Composer"}}
+  pdfcomposer = "Composer used for PDF"
+  arranger = \markup { The Arranger \circle f \draw-circle #3 #0.5  ##t }
+  copyright = "The Copyright"
+  keywords = "pdfmark, metadata, DOCINFO, lilypond"
+}
+\layout { ragged-right= ##t }
+
+\relative c' { g4 }

diff --git a/lily/book-scheme.cc b/lily/book-scheme.cc
index 55529de79c9839f2b67f5a40faa6157b4f1f04e9..339e2c282930e6c2c892c7c54f776844af354f35 100644 (file)
--- a/lily/book-scheme.cc
+++ b/lily/book-scheme.cc
@@ -148,6 +148,15 @@ LY_DEFINE (ly_book_paper, "ly:book-paper",
   return b->paper_ ? b->paper_->self_scm () : SCM_BOOL_F;
 }
 
+LY_DEFINE (ly_book_header, "ly:book-header",
+          1, 0, 0, (SCM book),
+          "Return header in @var{book}.")
+{
+  LY_ASSERT_SMOB (Book, book, 1);
+  Book *b = unsmob_book (book);
+  return b->header_ ? b->header_ : SCM_BOOL_F;
+}
+
 LY_DEFINE (ly_book_scores, "ly:book-scores",
           1, 0, 0, (SCM book),
           "Return scores in @var{book}.")

diff --git a/lily/paper-book-scheme.cc b/lily/paper-book-scheme.cc
index a821597be0c978dffc8e08434d68c923a00f7c3e..915844453025ece1d1883a41db0a4cbb73c72baa 100644 (file)
--- a/lily/paper-book-scheme.cc
+++ b/lily/paper-book-scheme.cc
@@ -72,3 +72,13 @@ LY_DEFINE (ly_paper_book_paper, "ly:paper-book-paper",
   Paper_book *pbook = unsmob_paper_book (pb);
   return pbook->paper_->self_scm ();
 }
+
+LY_DEFINE (ly_paper_book_header, "ly:paper-book-header",
+          1, 0, 0, (SCM pb),
+          "Return the header definition (@code{\\header})"
+          " in @code{Paper_book} object @var{pb}.")
+{
+  LY_ASSERT_SMOB (Paper_book, pb, 1);
+  Paper_book *pbook = unsmob_paper_book (pb);
+  return pbook->header_;
+}

diff --git a/scm/framework-ps.scm b/scm/framework-ps.scm
index 18038a61af164ce7963bbf7624859a9214f4dcdd..9cae54ffa851810152b4b886010b5f1ac7c1e261 100644 (file)
--- a/scm/framework-ps.scm
+++ b/scm/framework-ps.scm
@@ -379,6 +379,7 @@
           (pfas (map font-loader font-names)))
       pfas))
 
+
   (display "%%BeginProlog\n" port)
   (format
    port
@@ -398,6 +399,30 @@
   (display "%%EndProlog\n" port)
   (display "%%BeginSetup\ninit-lilypond-parameters\n%%EndSetup\n\n" port))
 
+;;; Create DOCINFO pdfmark containing metadata
+;;; header fields with pdf prefix override those without the prefix
+(define (handle-metadata header port)
+  (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 (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))
         (outputter (ly:make-paper-outputter
@@ -407,6 +432,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 +448,7 @@
     ;; don't do BeginDefaults PageMedia: A4
     ;; not necessary and wrong
     (write-preamble paper #t port)
+    (handle-metadata header port)
     (for-each
      (lambda (page)
        (set! page-number (1+ page-number))

diff --git a/scm/markup.scm b/scm/markup.scm
index 108751e22f590156d607365d69c0a44f0e9e6def..6bd9fd6236c687950ff450b09ee2184badda92e8 100644 (file)
--- a/scm/markup.scm
+++ b/scm/markup.scm
@@ -544,3 +544,63 @@ Uncovered - cheap-markup? is used."
           (car stencils))
       (ly:make-stencil '() '(0 . 0) '(0 . 0))))
 
+
+;;; convert a full markup object to an approximate pure string representation
+
+(define-public (markup->string m)
+  ;; markup commands with one markup argument, formatting ignored
+  (define markups-first-argument '(list
+    bold-markup box-markup caps-markup dynamic-markup finger-markup
+    fontCaps-markup huge-markup italic-markup large-markup larger-markup
+    medium-markup normal-size-sub-markup normal-size-super-markup
+    normal-text-markup normalsize-markup number-markup roman-markup
+    sans-markup simple-markup small-markup smallCaps-markup smaller-markup
+    sub-markup super-markup teeny-markup text-markup tiny-markup
+    typewriter-markup underline-markup upright-markup bracket-markup
+    circle-markup hbracket-markup parenthesize-markup rounded-box-markup
+
+    center-align-markup center-column-markup column-markup dir-column-markup
+    fill-line-markup justify-markup justify-string-markup left-align-markup
+    left-column-markup line-markup right-align-markup right-column-markup
+    vcenter-markup wordwrap-markup wordwrap-string-markup ))
+
+  ;; markup commands with markup as second argument, first argument
+  ;; specifies some formatting and is ignored
+  (define markups-second-argument '(list
+    abs-fontsize-markup fontsize-markup magnify-markup lower-markup
+    pad-around-markup pad-markup-markup pad-x-markup raise-markup
+    halign-markup hcenter-in-markup rotate-markup translate-markup
+    translate-scaled-markup with-url-markup scale-markup ))
+
+  ;; helper functions to handle string cons like string lists
+  (define (markup-cons->string-cons c)
+    (if (not (pair? c)) (markup->string c)
+      (cons (markup->string (car c)) (markup-cons->string-cons (cdr c)))))
+  (define (string-cons-join c)
+    (if (not (pair? c)) c
+        (string-join (list (car c) (string-cons-join (cdr c))) "")))
+
+  (cond
+    ((string? m) m)
+    ((null? m) "")
+
+    ;; handle \concat (string-join without spaces)
+    ((and (pair? m) (equal? (car m) concat-markup))
+        (string-cons-join (markup-cons->string-cons (cadr m))) )
+
+    ;; markup functions with the markup as first arg
+    ((member (car m) (primitive-eval markups-first-argument))
+        (markup->string (cadr m)))
+
+    ;; markup functions with markup as second arg
+    ((member (car m) (primitive-eval markups-second-argument))
+        (markup->string (cddr m)))
+
+    ;; ignore all other markup functions
+    ((markup-function? (car m)) "")
+
+    ;; handle markup lists
+    ((list? m)
+        (string-join (map markup->string m) " "))
+
+    (else "ERROR, unable to extract string from markup")))