Issue 4374 / 3: Add copy-binary-file procedure

[lilypond.git] / scm / backend-library.scm

diff --git a/scm/backend-library.scm b/scm/backend-library.scm
index 7f357376a37a88dfbb18f57c2716b2f16ab23685..712033849cc9cd0ab353ccb646120954a99ce316 100644 (file)
--- a/scm/backend-library.scm
+++ b/scm/backend-library.scm
@@ -1,6 +1,6 @@
 ;;;; This file is part of LilyPond, the GNU music typesetter.
 ;;;;
-;;;; Copyright (C) 2005--2012 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;; Copyright (C) 2005--2015 Jan Nieuwenhuizen <janneke@gnu.org>
 ;;;; Han-Wen Nienhuys <hanwen@xs4all.nl>
 ;;;;
 ;;;; LilyPond is free software: you can redistribute it and/or modify
@@ -82,6 +82,7 @@
                    "-dNOPAUSE"
                    "-dBATCH"
                    "-r1200"
+                   (if (ly:bigpdfs) "-dSubsetFonts=false")
                    "-sDEVICE=pdfwrite"
                    (string-append "-sOutputFile="
                                   (string-join
@@ -110,6 +111,59 @@
                     #:pixmap-format (ly:get-option 'pixmap-format))
     (ly:progress "\n")))
 
+(define-public (copy-binary-file from-name to-name)
+  (if (eq? PLATFORM 'windows)
+      ;; MINGW hack: MinGW Guile's copy-file is broken.
+      ;; It opens files by the text mode instead of the binary mode.
+      ;; (It is fixed from Guile 2.0.9.)
+      ;; By the text mode, copied binary files are broken.
+      ;; So, we open files by the binary mode and copy by ourselves.
+      (let ((port-from (open-file from-name "rb"))
+            (port-to (open-file to-name "wb")))
+        (let loop((c (read-char port-from)))
+          (if (eof-object? c)
+              (begin (close port-from)
+                     (close port-to))
+              (begin (write-char c port-to)
+                     (loop (read-char port-from))))))
+      ;; Cygwin and other platforms:
+      ;; Pass through to copy-file
+      (copy-file from-name to-name)))
+
+(define-public (make-tmpfile)
+  (let* ((tmpl
+          (string-append (cond
+                          ;; MINGW hack: TMP / TEMP may include
+                          ;; unusable characters (Unicode etc.).
+                          ((eq? PLATFORM 'windows) "./tmp-")
+                          ;; Cygwin can handle any characters
+                          ;; including Unicode.
+                          ((eq? PLATFORM 'cygwin) (string-append
+                                                   (or (getenv "TMP")
+                                                       (getenv "TEMP"))
+                                                   "/"))
+                          ;; Other platforms (POSIX platforms)
+                          ;; use TMPDIR or /tmp.
+                          (else (string-append
+                                 (or (getenv "TMPDIR")
+                                     "/tmp")
+                                 "/")))
+                          "lilypond-XXXXXX"))
+         (port-tmp (mkstemp! tmpl)))
+    (if (eq? PLATFORM 'windows)
+        ;; MINGW hack: MinGW Guile's mkstemp! is broken.
+        ;; It creates a file by the text mode instead of the binary mode.
+        ;; (It is fixed from Guile 2.0.9.)
+        ;; We need the binary mode for embeddings CFFs.
+        ;; So, we re-open the same file by the binary mode.
+        (let* ((filename (port-filename port-tmp))
+               (port (open-file filename "r+b")))
+          (close port-tmp)
+          port)
+        ;; Cygwin and other platforms:
+        ;; Pass through the return value of mkstemp!
+        port-tmp)))
+
 (define-public (postprocess-output paper-book module filename formats)
   (let* ((completed (completize-formats formats))
          (base (dir-basename filename ".ps" ".eps"))
@@ -151,8 +205,7 @@
 
 (define-public (output-scopes scopes fields basename)
   (define (output-scope scope)
-    (apply
-     string-append
+    (string-concatenate
      (module-map
       (lambda (sym var)
         (let ((val (if (variable-bound? var) (variable-ref var) "")))
@@ -160,7 +213,7 @@
               (header-to-file basename sym val))
           ""))
       scope)))
-  (apply string-append (map output-scope scopes)))
+  (string-concatenate (map output-scope scopes)))
 
 (define-public (relevant-book-systems book)
   (let ((systems (ly:paper-book-systems book)))
@@ -190,15 +243,14 @@
       (ly:warning (_ "missing stencil expression `~S'") name)
       ""))
 
-  (map (lambda (x)
-         (if (not (module-defined? output-module x))
-             (begin
-               (module-define! output-module x
-                               (lambda* (#:optional y . z)
-                                        (missing-stencil-expression x)))
-               (set! missing-stencil-list (append (list x)
-                                                  missing-stencil-list)))))
-       (ly:all-stencil-commands)))
+  (for-each (lambda (x)
+              (if (not (module-defined? output-module x))
+                  (begin
+                    (module-define! output-module x
+                                    (lambda* (#:optional y . z)
+                                             (missing-stencil-expression x)))
+                    (set! missing-stencil-list (cons x missing-stencil-list)))))
+            (ly:all-stencil-commands)))
 
 (define-public (remove-stencil-warnings output-module)
   (for-each
@@ -269,5 +321,5 @@ definition."
         (define-pango-pf pango-pf font-name scaling)))
 
     (string-append
-     (apply string-append (map font-load-command other-fonts))
-     (apply string-append (map pango-font-load-command pango-only-fonts)))))
+     (string-concatenate (map font-load-command other-fonts))
+     (string-concatenate (map pango-font-load-command pango-only-fonts)))))