From eab591fe423ef0eeb03d8bbedf7d43185d2fbc74 Mon Sep 17 00:00:00 2001 From: Reinhold Kainhofer Date: Mon, 27 Dec 2010 15:49:30 +0100 Subject: [PATCH] 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. --- input/regression/pdfmark-metadata.ly | 19 +++++++++ lily/book-scheme.cc | 9 +++++ lily/paper-book-scheme.cc | 10 +++++ scm/framework-ps.scm | 27 +++++++++++++ scm/markup.scm | 60 ++++++++++++++++++++++++++++ 5 files changed, 125 insertions(+) create mode 100644 input/regression/pdfmark-metadata.ly diff --git a/input/regression/pdfmark-metadata.ly b/input/regression/pdfmark-metadata.ly new file mode 100644 index 0000000000..16f47ebb99 --- /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 55529de79c..339e2c2829 100644 --- 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 a821597be0..9158444530 100644 --- 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 18038a61af..9cae54ffa8 100644 --- 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 108751e22f..6bd9fd6236 100644 --- 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"))) -- 2.39.5