3 ;;;; source file of the GNU LilyPond music typesetter
5 ;;;; (c) 2005--2006 Jan Nieuwenhuizen <janneke@gnu.org>
7 (define-module (scm ps-to-png))
19 ;; gettext wrapper for guile < 1.7.2
20 (if (defined? 'gettext)
21 (define-public _ gettext)
22 (define-public (_ x) x))
27 (car (string-tokenize (vector-ref (uname) 0) char-set:letter)))))
29 (define (re-sub re sub string)
30 (regexp-substitute/global #f re string 'pre sub 'post))
32 (define (search-executable names)
33 (define (helper path lst)
36 (if (search-path path (car lst)) (car lst)
37 (helper path (cdr lst)))))
39 (let ((path (parse-path (getenv "PATH"))))
43 (search-executable '("gs-nox" "gs-8.15" "gs")))
45 (define (gulp-port port max-length)
46 (let ((str (make-string max-length)))
47 (read-string!/partial str port 0 max-length)
50 (define-public (gulp-file file-name . max-size)
51 (ly:gulp-file file-name (if (pair? max-size) (car max-size))))
53 (define BOUNDING-BOX-RE
54 "^%%BoundingBox: (-?[0-9]+) (-?[0-9]+) (-?[0-9]+) (-?[0-9]+)")
56 (define (unused-found-broken-get-bbox file-name)
57 (let* ((bbox (string-append file-name ".bbox"))
58 ;; -sOutputFile does not work with bbox?
68 (s (gulp-file bbox 10240))
69 (m (string-match BOUNDING_BOX_RE s)))
73 (map (lambda (x) (string->number (car x))) (vector->list m)))
77 ;; copy of ly:system. ly:* not available via lilypond-ps2png.scm
78 (define (my-system be-verbose exit-on-error cmd)
82 (format (current-error-port) (_ "Invoking `~a'...") cmd)
83 (newline (current-error-port))))
84 (set! status (system cmd))
85 (if (not (= status 0))
87 (format (current-error-port)
88 (format #f (_ "~a exited with status: ~S") "GS" status))
89 (if exit-on-error (exit 1))))
92 (define (scale-down-image be-verbose factor file)
95 (old (string-append file ".old")))
97 (rename-file file old)
101 "pngtopnm ~a | pnmscale -reduce ~a 2>/dev/null | pnmtopng -compression 9 2>/dev/null > ~a"
107 (define-public (ps-page-count ps-name)
108 (let* ((byte-count 10240)
109 (header (gulp-file ps-name byte-count))
110 (first-null (string-index header #\nul))
111 (match (string-match "%%Pages: ([0-9]+)"
112 (if (number? first-null)
113 (substring header 0 first-null)
115 (if match (string->number (match:substring match 1)) 0)))
117 (define-public (make-ps-images ps-name . rest)
125 (pixmap-format 'png16m)
126 (anti-alias-factor 1))
128 (let* ((format-str (format "~a" pixmap-format))
130 ((string-contains format-str "png") "png")
131 ((string-contains format-str "jpg") "jpeg")
132 ((string-contains format-str "jpeg") "jpeg")
134 (ly:error "Unknown pixmap format ~a" pixmap-format))))
135 (base (basename (re-sub "[.]e?ps" "" ps-name)))
136 (png1 (format "~a.~a" base extension))
137 (pngn (format "~a-page%d.~a" base extension))
138 (page-count (ps-page-count ps-name))
139 (multi-page? (> page-count 1))
140 (output-file (if multi-page? pngn png1))
144 (format #f "-dDEVICEWIDTHPOINTS=~,2f -dDEVICEHEIGHTPOINTS=~,2f"
145 page-width page-height)
150 -dGraphicsAlphaBits=4\
159 (if be-verbose "" "-q")
163 (* anti-alias-factor resolution) ps-name))
167 ;; The wrapper on windows cannot handle `=' signs,
168 ;; gs has a workaround with #.
169 (if (eq? PLATFORM 'windows)
171 (set! cmd (re-sub "=" "#" cmd))
172 (set! cmd (re-sub "-dSAFER " "" cmd))))
174 (set! status (my-system be-verbose #f cmd))
180 (format "~a-page~a.png" base (1+ n)))
182 (list (format "~a.png" base))))
184 (if (not (= 0 status))
186 (map delete-file files)
189 (if (and rename-page-1 multi-page?)
191 (rename-file (re-sub "%d" "1" pngn) png1)
197 (if (not (= 1 anti-alias-factor))
199 (lambda (f) (scale-down-image be-verbose anti-alias-factor f)) files))