X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fps-to-png.scm;h=d0f810fafbdf14370709f69911eb868770b85130;hb=HEAD;hp=caffb9aeda8d3dd717d607917684cddaf9a009b6;hpb=990bb7331e98449aaeb5b922145b9f1f4f81944a;p=lilypond.git diff --git a/scm/ps-to-png.scm b/scm/ps-to-png.scm index caffb9aeda..d0f810fafb 100644 --- a/scm/ps-to-png.scm +++ b/scm/ps-to-png.scm @@ -1,6 +1,6 @@ ;;;; This file is part of LilyPond, the GNU music typesetter. ;;;; -;;;; Copyright (C) 2005--2011 Jan Nieuwenhuizen +;;;; Copyright (C) 2005--2015 Jan Nieuwenhuizen ;;;; ;;;; LilyPond is free software: you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by @@ -27,80 +27,71 @@ (lily) ) -;; FIXME: use backend-library for duplicates and stubs; lilypond-ps2png.scm is no more - -(define-public _ gettext) - -(define PLATFORM - (string->symbol - (string-downcase - (car (string-tokenize (vector-ref (uname) 0) char-set:letter))))) - (define (re-sub re sub string) (regexp-substitute/global #f re string 'pre sub 'post)) -(define (search-executable names) - (define (helper path lst) - (if (null? (cdr lst)) - (car lst) - (if (search-path path (car lst)) (car lst) - (helper path (cdr lst))))) - - (let ((path (parse-path (getenv "PATH")))) - (helper path names))) - -(define (search-gs) - (search-executable '("gs-nox" "gs-8.15" "gs"))) - -(define (gulp-port port max-length) - (let ((str (make-string max-length))) - (read-string!/partial str port 0 max-length) - str)) - (define-public (gulp-file file-name . max-size) (ly:gulp-file file-name (if (pair? max-size) (car max-size)))) -;; copy of ly:system. ly:* not available via lilypond-ps2png.scm -(define (my-system be-verbose exit-on-error cmd) - (define status 0) - (if be-verbose - (begin - (format (current-error-port) (_ "Invoking `~a'...") cmd) - (newline (current-error-port)))) - (set! status (system cmd)) - (if (not (= status 0)) - (begin - (format (current-error-port) - (format #f (_ "~a exited with status: ~S") "GS" status)) - (if exit-on-error (exit 1)))) - status) - -(define (scale-down-image be-verbose factor file) - (define (with-pbm) - (let* ((status 0) - (old (string-append file ".old"))) - - (rename-file file old) - (my-system - be-verbose #t - (format #f - "pngtopnm \"~a\" | pnmscale -reduce ~a 2>/dev/null | pnmtopng -compression 9 2>/dev/null > \"~a\"" - old factor file)) - (delete-file old))) - - (with-pbm)) +(define (search-pngtopam) + (search-executable + (if (eq? PLATFORM 'windows) + '("pngtopam.exe" "pngtopnm.exe") + '("pngtopam" "pngtopnm")))) + +(define (search-pamscale) + (search-executable + (if (eq? PLATFORM 'windows) + '("pamscale.exe" "pnmscale.exe") + '("pamscale" "pnmscale")))) + +(define (search-pnmtopng) + (search-executable + (if (eq? PLATFORM 'windows) + '("pnmtopng.exe") + '("pnmtopng")))) + +(define (scale-down-image factor file) + (let* ((port-tmp1 (make-tmpfile)) + (tmp1-name (port-filename port-tmp1)) + (port-tmp2 (make-tmpfile)) + (tmp2-name (port-filename port-tmp2)) + ;; Netpbm commands (pngtopnm, pnmscale, pnmtopng) + ;; outputs only standard output instead of a file. + ;; So we need pipe and redirection. + ;; However, ly:system can't handle them. + ;; Therefore, we use ly:system-with-shell. + (cmd + (ly:format + "~a \"~a\" | ~a -reduce ~a | ~a -compression 9 > \"~a\"" + (search-pngtopam) tmp1-name + (search-pamscale) factor + (search-pnmtopng) + tmp2-name))) + + (close-port port-tmp1) + (close-port port-tmp2) + (ly:debug (_ "Copying `~a' to `~a'...") file tmp1-name) + (copy-binary-file file tmp1-name) + (ly:system-with-shell cmd) + (ly:debug (_ "Copying `~a' to `~a'...") tmp2-name file) + (copy-binary-file tmp2-name file) + (ly:debug (_ "Deleting `~a'...") tmp1-name) + (delete-file tmp1-name) + (ly:debug (_ "Deleting `~a'...") tmp2-name) + (delete-file tmp2-name))) (define-public (ps-page-count ps-name) (let* ((byte-count 10240) - (header (gulp-file ps-name byte-count)) - (first-null (string-index header #\nul)) - (match (string-match "%%Pages: ([0-9]+)" - (if (number? first-null) - (substring header 0 first-null) - header)))) + (header (gulp-file ps-name byte-count)) + (first-null (string-index header #\nul)) + (match (string-match "%%Pages: ([0-9]+)" + (if (number? first-null) + (substring header 0 first-null) + header)))) (if match (string->number (match:substring match 1)) 0))) -(define-public (make-ps-images ps-name . rest) +(define-public (make-ps-images base-name tmp-name is-eps . rest) (let-keywords* rest #f ((resolution 90) @@ -112,75 +103,73 @@ (anti-alias-factor 1)) (let* ((format-str (format #f "~a" pixmap-format)) - (extension (cond - ((string-contains format-str "png") "png") - ((string-contains format-str "jpg") "jpeg") - ((string-contains format-str "jpeg") "jpeg") - (else - (ly:error "Unknown pixmap format ~a" pixmap-format)))) - (base (dir-basename ps-name ".ps" ".eps")) - (png1 (format #f "~a.~a" base extension)) - (pngn (format #f "~a-page%d.~a" base extension)) - (page-count (ps-page-count ps-name)) - (multi-page? (> page-count 1)) - (output-file (if multi-page? pngn png1)) - - (gs-variable-options - (if (string-suffix-ci? ".eps" ps-name) - "-dEPSCrop" - (format #f "-dDEVICEWIDTHPOINTS=~,2f -dDEVICEHEIGHTPOINTS=~,2f" - page-width page-height))) - (cmd (ly:format "~a\ - ~a\ - ~a\ - -dGraphicsAlphaBits=4\ - -dTextAlphaBits=4\ - -dNOPAUSE\ - -sDEVICE=~a\ - -sOutputFile=~S\ - -r~a\ - ~S\ - -c quit" - (search-gs) - (if be-verbose "" "-q") - gs-variable-options - pixmap-format - output-file - (* anti-alias-factor resolution) ps-name)) - (status 0) - (files '())) - - ;; The wrapper on windows cannot handle `=' signs, - ;; gs has a workaround with #. - (if (eq? PLATFORM 'windows) - (begin - (set! cmd (re-sub "=" "#" cmd)) - (set! cmd (re-sub "-dSAFER " "" cmd)))) - - (set! status (my-system be-verbose #f cmd)) + (extension (cond + ((string-contains format-str "png") "png") + ((string-contains format-str "jpg") "jpeg") + ((string-contains format-str "jpeg") "jpeg") + (else + (ly:error "Unknown pixmap format ~a" pixmap-format)))) + (png1 (format #f "~a.~a" base-name extension)) + (pngn (format #f "~a-page%d.~a" base-name extension)) + (page-count (ps-page-count tmp-name)) + (multi-page? (> page-count 1)) + + ;; Escape `%' (except `page%d') for ghostscript + (base-name-gs (string-join + (string-split base-name #\%) + "%%")) + (png1-gs (format #f "~a.~a" base-name-gs extension)) + (pngn-gs (format #f "~a-page%d.~a" base-name-gs extension)) + (output-file (if multi-page? pngn-gs png1-gs)) + + (*unspecified* (if #f #f)) + (cmd + (remove (lambda (x) (eq? x *unspecified*)) + (list + (search-gs) + (if (ly:get-option 'verbose) *unspecified* "-q") + (if (or (ly:get-option 'gs-load-fonts) + (ly:get-option 'gs-load-lily-fonts) + (eq? PLATFORM 'windows)) + "-dNOSAFER" + "-dSAFER") + + (if is-eps + "-dEPSCrop" + (ly:format "-dDEVICEWIDTHPOINTS=~$" page-width)) + (if is-eps + *unspecified* + (ly:format "-dDEVICEHEIGHTPOINTS=~$" page-height)) + "-dGraphicsAlphaBits=4" + "-dTextAlphaBits=4" + "-dNOPAUSE" + "-dBATCH" + (ly:format "-sDEVICE=~a" pixmap-format) + "-dAutoRotatePages=/None" + (string-append "-sOutputFile=" output-file) + (ly:format "-r~a" (* anti-alias-factor resolution)) + (string-append "-f" tmp-name)))) + (files '())) + + (ly:system cmd) (set! files - (if multi-page? - (map - (lambda (n) - (format #f "~a-page~a.png" base (1+ n))) - (iota page-count)) - (list (format #f "~a.png" base)))) - - (if (not (= 0 status)) - (begin - (map delete-file files) - (exit 1))) + (if multi-page? + (map + (lambda (n) + (format #f "~a-page~a.png" base-name (1+ n))) + (iota page-count)) + (list (format #f "~a.png" base-name)))) (if (and rename-page-1 multi-page?) - (begin - (rename-file (re-sub "%d" "1" pngn) png1) - (set! files - (cons png1 - (cdr files))) - )) + (begin + (rename-file (re-sub "%d" "1" pngn) png1) + (set! files + (cons png1 + (cdr files))) + )) (if (not (= 1 anti-alias-factor)) - (for-each - (lambda (f) (scale-down-image be-verbose anti-alias-factor f)) files)) + (for-each + (lambda (f) (scale-down-image anti-alias-factor f)) files)) files)))