X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fps-to-png.scm;h=d76f926a90203b02d006a082d99d25f8f2190c9d;hb=69d06539ea9a4a30269ca94547a79c47cf21cc30;hp=20c69b11482bc050a60bada301f085c50063a3b5;hpb=c21383ab66c2abe8e42eda7694eb05e876e6be2c;p=lilypond.git diff --git a/scm/ps-to-png.scm b/scm/ps-to-png.scm index 20c69b1148..d76f926a90 100644 --- a/scm/ps-to-png.scm +++ b/scm/ps-to-png.scm @@ -2,36 +2,59 @@ ;;;; ;;;; source file of the GNU LilyPond music typesetter ;;;; -;;;; (c) 2005 Jan Nieuwenhuizen +;;;; (c) 2005--2006 Jan Nieuwenhuizen (define-module (scm ps-to-png)) (use-modules (ice-9 optargs) (ice-9 regex) - (ice-9 rdelim) - (srfi srfi-1)) + (ice-9 rw) + (srfi srfi-1) + (srfi srfi-13) + (srfi srfi-14) + (lily) + ) ;; gettext wrapper for guile < 1.7.2 (if (defined? 'gettext) (define-public _ gettext) (define-public (_ x) x)) +(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 (read port) - (let ((s (read-delimited "" port))) - (if (eof-object? s) "" s))) +(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 (gulp-file nm len) -(define (dir-listing dir-name) - (define (dir-helper dir lst) - (let ((e (readdir dir))) - (if (eof-object? e) lst (dir-helper dir (cons e lst))))) - (reverse (dir-helper (opendir dir-name) '()))) + ;; string routines barf when strlen() != string-length,. + ;; which may happen as side effect of read-string!/partial. + + ; (gulp-port (open-file nm "r") len)) + (ly:gulp-file nm len)) -(define (dir-re dir re) - (filter (lambda (x) (string-match re x)) (dir-listing dir))) (define BOUNDING-BOX-RE "^%%BoundingBox: (-?[0-9]+) (-?[0-9]+) (-?[0-9]+) (-?[0-9]+)") @@ -46,72 +69,140 @@ ~S\ -c showpage\ -c quit 2>~S" - file-name bbox)) + file-name bbox)) (status (system cmd)) - (s (read (open-file bbox "r"))) + (s (gulp-file d bbox 10240)) (m (string-match BOUNDING_BOX_RE s))) - (display m) - (newline) + (if m (list->vector (map (lambda (x) (string->number (car x))) (vector->list m))) #f))) + +;; 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) + (let* ((status 0) + (percentage (* 100 (/ 1.0 factor))) + (old (string-append file ".old"))) + + (rename-file file old) + (my-system be-verbose + #t + (format #f "convert -scale \"~a%\" ~a ~a" percentage old file)) + (delete-file old) + )) + +(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)))) + + (if match + (string->number (match:substring match 1)) + 0))) + (define-public (make-ps-images ps-name . rest) (let-optional rest ((resolution 90) - (paper-size "a4") + page-width + page-height (rename-page-1? #f) - (verbose? #f)) - (let* ((base (basename (re-sub "\.e?ps" "" ps-name))) - (header (read (open-file ps-name "r"))) + (verbose? #f) + (aa-factor 1) + ) + + (let* ((base (basename (re-sub "[.]e?ps" "" ps-name))) (png1 (string-append base ".png")) (pngn (string-append base "-page%d.png")) - (pngn-re (re-sub "%d" "[0-9]*" pngn)) - (multi-page? (string-match "\n%%Pages: " header)) + (page-count (ps-page-count ps-name)) + + (multi-page? (> page-count 1)) (output-file (if multi-page? pngn png1)) - ;;png16m is because Lily produces color nowadays. - (cmd (format #f (if multi-page? - "gs\ - -dEPSCrop\ + + ;; png16m is because Lily produces color nowadays. + ;; can't use pngalpha device, since IE is broken. + ;; + (gs-variable-options + (if multi-page? + (format #f "-dDEVICEWIDTHPOINTS=~,2f -dDEVICEHEIGHTPOINTS=~,2f" page-width page-height) + "-dEPSCrop")) + + (cmd (format #f "~a\ + ~a\ + ~a\ -dGraphicsAlphaBits=4\ - -dNOPAUSE\ -dTextAlphaBits=4\ - -sDEVICE=png16m\ - -sOutputFile='~a'\ - -sPAPERSIZE=~a\ - -q\ - -r~S\ - '~a'\ - -c showpage\ - -c quit" - "gs\ - -s\ - -dGraphicsAlphaBits=4\ -dNOPAUSE\ - -dTextAlphaBits=4\ -sDEVICE=png16m\ - -sOutputFile='~a'\ - -sPAPERSIZE=~a\ - -q\ + -sOutputFile=~S\ -r~S\ - '~a'\ - -c quit") - output-file paper-size resolution ps-name)) - (foo (for-each delete-file (append (dir-re "." png1) - (dir-re "." pngn-re)))) - (bar (if verbose? - (begin - (format (current-error-port) (_ "Invoking `~a'...") cmd) - (newline (current-error-port))))) - (status (system cmd))) - (if (not (= status 0)) + ~S\ + -c quit" + (search-gs) + (if verbose? "" "-q") + gs-variable-options + output-file + (* aa-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 verbose? #f cmd)) + + (set! files + (if multi-page? + (map + (lambda (n) + (format "~a-page~a.png" base (1+ n))) + (iota page-count)) + (list (format "~a.png" base)))) + + (if (not (= 0 status)) (begin - (map delete-file - (append (dir-re "." png1) (dir-re "." pngn-re))) - (format (current-error-port) - (format #f (_ "~a exited with status: ~S") "GS" status)) + (map delete-file files) (exit 1))) + (if (and rename-page-1? multi-page?) - (rename (re-sub "%d" "1" pngn) png1)) - (append (dir-re "." png1) (dir-re "." pngn-re))))) + (begin + (rename-file (re-sub "%d" "1" pngn) png1) + (set! files + (cons png1 + (cdr files))) + )) + + (if (not (= 1 aa-factor)) + (for-each (lambda (f) (scale-down-image verbose? aa-factor f)) + files)) + + files)))