Add '-dcrop' option to ps and svg backends

[lilypond.git] / scm / ps-to-png.scm

diff --git a/scm/ps-to-png.scm b/scm/ps-to-png.scm
index 9c977b6463fd20d3a535ddcb353e567992736958..d0f810fafbdf14370709f69911eb868770b85130 100644 (file)
--- a/scm/ps-to-png.scm
+++ b/scm/ps-to-png.scm
@@ -27,41 +27,59 @@
  (lily)
  )
 
-;; FIXME: use backend-library for duplicates and stubs; lilypond-ps2png.scm is no more
-
-(define-public _ gettext)
-
 (define (re-sub re sub string)
   (regexp-substitute/global #f re string 'pre sub 'post))
 
 (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)
-  (ly:debug (_ "Invoking `~a'...\n") cmd)
-  (set! status (system cmd))
-  (if (not (= status 0))
-      (begin
-        (ly:error (_ "~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)
@@ -127,6 +145,7 @@
                     "-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))))
@@ -152,5 +171,5 @@
 
      (if (not (= 1 anti-alias-factor))
          (for-each
-          (lambda (f) (scale-down-image be-verbose anti-alias-factor f)) files))
+          (lambda (f) (scale-down-image anti-alias-factor f)) files))
      files)))