X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fframework-ps.scm;h=a9c5de2823dfc32271cf484f0f4d2dcc40f073b6;hb=HEAD;hp=6e03a3b967d186cb79c2012e5317ac03a7755a2a;hpb=264fa8be61f503a1c9952b70633018e752afd226;p=lilypond.git diff --git a/scm/framework-ps.scm b/scm/framework-ps.scm index 6e03a3b967..a9c5de2823 100644 --- a/scm/framework-ps.scm +++ b/scm/framework-ps.scm @@ -214,6 +214,8 @@ (define-fonts paper ps-define-font ps-define-pango-pf) (output-variables paper))) +(define never-embed-font-list (list)) + (define (cff-font? font) (let* ((cff-string (ly:otf-font-table-data font "CFF "))) (> (string-length cff-string) 0))) @@ -241,9 +243,12 @@ (footer "\n%%EndData %%EndResource %%EndResource\n")) - (string-append header - binary-data - footer))) + (begin + (set! never-embed-font-list + (append never-embed-font-list (list font-set-name))) + (string-append header + binary-data + footer)))) (define check-conflict-and-embed-cff (let ((font-list '())) @@ -304,7 +309,8 @@ (define (ps-load-file file-name) (if (string? file-name) - (if (string-contains file-name (ly:get-option 'datadir)) + (if (and (not (ly:get-option 'font-export-dir)) + (string-contains file-name (ly:get-option 'datadir))) (begin (set! file-name (ly:string-substitute (ly:get-option 'datadir) "" file-name)) @@ -328,7 +334,7 @@ ((and (string? bare-file-name) (eq? (ly:get-font-format bare-file-name font-index) 'CFF) (is-collection-font? bare-file-name)) - (ly:warning (_ "Font ~a cannot be loaded via Ghostscript because it is an OpenType/CFF (OTC) font.") + (ly:warning (_ "Font ~a cannot be loaded via Ghostscript because it is an OpenType/CFF Collection (OTC) font.") name) (load-font font-name-filename)) ((and (string? bare-file-name) @@ -338,18 +344,26 @@ name) (load-font font-name-filename)) (else - (cons name - (if (mac-font? bare-file-name) - (handle-mac-font name bare-file-name) - (cond - ((and font (cff-font? font)) - (ps-load-file (ly:find-file - (format #f "~a.otf" file-name)))) - ((string? bare-file-name) - (ps-load-file file-name)) - (else - (ly:warning (_ "cannot embed ~S=~S") name file-name) - "")))))))) + (begin + (if (or (and font (cff-font? font)) + (and (string? bare-file-name) + (not (eq? (ly:get-font-format + bare-file-name + font-index) 'TrueType)))) + (set! never-embed-font-list + (append never-embed-font-list (list name)))) + (cons name + (if (mac-font? bare-file-name) + (handle-mac-font name bare-file-name) + (cond + ((and font (cff-font? font)) + (ps-load-file (ly:find-file + (format #f "~a.otf" file-name)))) + ((string? bare-file-name) + (ps-load-file file-name)) + (else + (ly:warning (_ "cannot embed ~S=~S") name file-name) + ""))))))))) (define (dir-join a b) (if (equal? a "") @@ -400,7 +414,9 @@ (cond ((eq? font-format (string->symbol "Type 1")) ;; Type 1 (PFA and PFB) fonts - (ly:type1->pfa file-name)) + (begin (set! never-embed-font-list + (append never-embed-font-list (list name))) + (ly:type1->pfa file-name))) ((eq? font-format 'TrueType) ;; TrueType fonts (TTF) and TrueType Collection (TTC) (ly:ttf->pfa file-name font-index)) @@ -479,18 +495,83 @@ (pfas (map font-loader font-names))) pfas)) + (define (font-export name body) + (let* ((filename (format #f "~a/~a.font.ps" + (ly:get-option 'font-export-dir) + name)) + (port-excl + (catch + 'system-error + (lambda () + ;; Exclusive file create: + ;; When the file already exists, it raises system-error. + (open filename (logior O_WRONLY O_CREAT O_EXCL))) + (lambda stuff + ;; Catch the system-error + (let ((errno (system-error-errno stuff))) + (cond + ;; If the file already exists, return #f. + ((= errno EEXIST) + (begin + (ly:debug + (_ "Font file `~a' already exists, skipping.") + filename) + #f)) + ;; If the cause is something else, re-throw the error. + (#t + (throw 'system-error (cdr stuff))))))))) + (if port-excl + ;; MinGW hack: need to have "b"inary for fonts + (let ((port (open-file filename "wb"))) + (close port-excl) + (ly:debug (_ "Exporting font file `~a'.") filename) + (format port "%%BeginFont: ~a\n" name) + (display body port) + (display "%%EndFont\n" port) + (close-port port))))) (display "%%BeginProlog\n" port) (format port "/lilypond-datadir where {pop} {userdict /lilypond-datadir (~a) put } ifelse" (ly:get-option 'datadir)) + (set! never-embed-font-list (list)) + (if (ly:get-option 'font-export-dir) + (let ((dirname (format #f "~a" (ly:get-option 'font-export-dir)))) + (ly:debug + (_ "Making font export directory `~a'.") dirname) + (catch + 'system-error + (lambda () + ;; mkdir: + ;; When the directory already exists, it raises system-error. + (mkdir dirname)) + (lambda stuff + ;; Catch the system-error + (if (= EEXIST (system-error-errno stuff)) + ;; If the directory already exists, avoid error. + (ly:debug + (_ "Font export directory `~a' already exists.") dirname) + ;; If the cause is something else, re-throw the error. + (throw 'system-error (cdr stuff))))))) (if load-fonts? (for-each (lambda (f) (format port "\n%%BeginFont: ~a\n" (car f)) (display (cdr f) port) - (display "%%EndFont\n" port)) + (display "%%EndFont\n" port) + (if (ly:get-option 'font-export-dir) + (font-export (car f) (cdr f)))) (load-fonts paper))) + (if (ly:get-option 'gs-never-embed-fonts) + (begin + (display "\nsystemdict /DEVICE known\n" port) + (display " { systemdict /DEVICE get (pdfwrite) eq {\n" port) + (display ".setpdfwrite << /NeverEmbed [" port) + (display (string-concatenate + (map (lambda (f) (string-append " /" f)) + never-embed-font-list)) port) + (display " ] >> setdistillerparams\n" port) + (display " } if } if\n" port))) (if (ly:bigpdfs) (display (procset "encodingdefs.ps") port)) (display (setup-variables paper) port) @@ -518,8 +599,14 @@ (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 - + ;; + ;; NOTE: with guile-2.0+ ly:encode-string-for-pdf is not really needed and + ;; could be replaced with the following code: + ;; + ;; (let* ((utf16be-bom #vu8(#xFE #xFF))) + ;; (string-append (bytevector->string utf16be-bom "ISO-8859-1") + ;; (bytevector->string (string->utf16 val 'big) "ISO-8859-1"))) + ;; (ps-quote (ly:encode-string-for-pdf val))) (define (metadata-lookup-output overridevar fallbackvar field) (let* ((overrideval (ly:modules-lookup (list header) overridevar)) @@ -779,6 +866,22 @@ mark {ly~a_stream} /CLOSE pdfmark #t ))) +(define-public (output-crop-framework basename book scopes fields) + (let* ((paper (ly:paper-book-paper book)) + (systems (relevant-book-systems book))) + (dump-stencil-as-EPS paper + (stack-stencils Y DOWN 0.0 + (map paper-system-stencil + (reverse (reverse systems)))) + (format #f "~a.cropped" basename) + #t) + (postprocess-output book framework-ps-module + (cons "png" (ly:output-formats)) + (format #f "~a.cropped" basename) + (format #f "~a.cropped.eps" basename) + #t + ))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (output-width-height defs)