Web: use free software and mention that we're part of GNU.

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

diff --git a/scm/backend-library.scm b/scm/backend-library.scm
index 689478f291c4c8c401be20108294e861f8f337ca..ec0a537bdda07495124f7a85280a40efbc76e2dd 100644 (file)
--- a/scm/backend-library.scm
+++ b/scm/backend-library.scm
@@ -1,14 +1,29 @@
-;;;; backend-library.scm -- helpers for the backends.
+;;;; This file is part of LilyPond, the GNU music typesetter.

 ;;;;
 ;;;;

-;;;;  source file of the GNU LilyPond music typesetter
-;;;; 
-;;;; (c) 2005--2006 Jan Nieuwenhuizen <janneke@gnu.org>
-;;;; Han-Wen Nienhuys <hanwen@cs.uu.nl>
+;;;; Copyright (C) 2005--2010 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;; Han-Wen Nienhuys <hanwen@xs4all.nl>
+;;;;
+;;;; LilyPond is free software: you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation, either version 3 of the License, or
+;;;; (at your option) any later version.
+;;;;
+;;;; LilyPond is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.

 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
 ;; backend helpers.
 
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
 ;; backend helpers.
 

-(define-public (ly:system command)
+(use-modules (scm ps-to-png)
+            (scm paper-system)
+            (ice-9 optargs))
+
+(define-public (ly:system command . rest)

   (let* ((status 0)
         (dev-null "/dev/null")
         (silenced (if (or (ly:get-option 'verbose)
   (let* ((status 0)
         (dev-null "/dev/null")
         (silenced (if (or (ly:get-option 'verbose)


@@ -16,9 +31,15 @@
                       command
                       (format #f "~a > ~a 2>&1 " command dev-null))))
     (if (ly:get-option 'verbose)
                       command
                       (format #f "~a > ~a 2>&1 " command dev-null))))
     (if (ly:get-option 'verbose)

-       (ly:message (_ "Invoking `~a'...") command))
-    
-    (set! status (system silenced))
+       (begin
+         (ly:message (_ "Invoking `~a'...") command))
+         (ly:progress "\n"))
+
+    (set! status
+         (if (pair? rest)
+             (system-with-env silenced (car rest))
+             (system silenced)))
+       

     (if (> status 0)
        (begin
          (ly:message (_ "`~a' failed (~a)") command status)
     (if (> status 0)
        (begin
          (ly:message (_ "`~a' failed (~a)") command status)


@@ -26,6 +47,22 @@
          ;; hmmm.  what's the best failure option? 
          (throw 'ly-file-failed)))))
 
          ;; hmmm.  what's the best failure option? 
          (throw 'ly-file-failed)))))
 

+(define-public (system-with-env cmd env)
+
+  "Execute CMD in fork, with ENV (a list of strings) as the environment"
+  (let*
+      ;; laziness: should use execle?
+      
+      ((pid (primitive-fork)))
+    (if (= 0 pid)
+       ;; child
+       (begin
+         (environ env)
+         (system cmd))
+       
+       ;; parent
+       (cdr (waitpid pid)))))
+

 (define-public (sanitize-command-option str)
   "Kill dubious shell quoting"
   
 (define-public (sanitize-command-option str)
   "Kill dubious shell quoting"
   


@@ -48,18 +85,27 @@
   
   ;; must be sure that we don't catch stuff from old GUBs.
   (search-executable '("gs")))
   
   ;; must be sure that we don't catch stuff from old GUBs.
   (search-executable '("gs")))

-
+  

 (define-public (postscript->pdf paper-width paper-height name)
 (define-public (postscript->pdf paper-width paper-height name)

-  (let* ((pdf-name (string-append (basename name ".ps") ".pdf"))
-        (cmd (format #f
+  (let* ((pdf-name (string-append
+                   (dir-basename name ".ps" ".eps")
+                   ".pdf"))
+        (is-eps (string-match "\\.eps$" name))
+        (paper-size-string (if is-eps
+                               "-dEPSCrop"
+                               (ly:format "-dDEVICEWIDTHPOINTS=~$\
+ -dDEVICEHEIGHTPOINTS=~$"
+                                       paper-width paper-height)))
+
+        (cmd (ly:format

                      "~a\
  ~a\
  ~a\
                      "~a\
  ~a\
  ~a\

- -dCompatibilityLevel=1.4 \
- -dDEVICEWIDTHPOINTS=~,2f -dDEVICEHEIGHTPOINTS=~,2f\
+ ~a\
+ -dCompatibilityLevel=1.4\

  -dNOPAUSE\
  -dBATCH\
  -dNOPAUSE\
  -dBATCH\

- -r1200 \
+ -r1200\

  -sDEVICE=pdfwrite\
  -sOutputFile=~S\
  -c .setpdfwrite\
  -sDEVICE=pdfwrite\
  -sOutputFile=~S\
  -c .setpdfwrite\


@@ -67,11 +113,11 @@
 "
                      (search-gs)
                      (if (ly:get-option 'verbose) "" "-q")
 "
                      (search-gs)
                      (if (ly:get-option 'verbose) "" "-q")

-                     (if (ly:get-option 'gs-font-load)
-                         " -dNOSAFER "
-                         " -dSAFER ")
-                     paper-width
-                     paper-height
+                     (if (or (ly:get-option 'gs-load-fonts)
+                             (ly:get-option 'gs-load-lily-fonts))
+                         "-dNOSAFER"
+                         "-dSAFER")
+                     paper-size-string

                      pdf-name
                      name)))
     ;; The wrapper on windows cannot handle `=' signs,
                      pdf-name
                      name)))
     ;; The wrapper on windows cannot handle `=' signs,


@@ -81,63 +127,48 @@
          (set! cmd (string-regexp-substitute "=" "#" cmd))
          (set! cmd (string-regexp-substitute "-dSAFER " "" cmd))))
 
          (set! cmd (string-regexp-substitute "=" "#" cmd))
          (set! cmd (string-regexp-substitute "-dSAFER " "" cmd))))
 

-    (if (access? pdf-name W_OK)
-       (delete-file pdf-name))
-

     (ly:message (_ "Converting to `~a'...") pdf-name)
     (ly:progress "\n")
     (ly:message (_ "Converting to `~a'...") pdf-name)
     (ly:progress "\n")

-    (ly:system cmd)
-    ))
-
-(use-modules (scm ps-to-png))
+    (ly:system cmd)))

 
 (define-public (postscript->png resolution paper-width paper-height name)
 
 (define-public (postscript->png resolution paper-width paper-height name)

+  (let* ((verbose (ly:get-option 'verbose))
+        (rename-page-1 #f))
+

     ;; Do not try to guess the name of the png file,
     ;; GS produces PNG files like BASE-page%d.png.
     ;; Do not try to guess the name of the png file,
     ;; GS produces PNG files like BASE-page%d.png.

-    ;;(ly:message (_ "Converting to `~a'...")
-    ;;     (string-append (basename name ".ps") "-page1.png" )))
-  (let ((verbose (ly:get-option 'verbose))
-       (rename-page-1 #f))
-

     (ly:message (_ "Converting to ~a...") "PNG")
     (ly:message (_ "Converting to ~a...") "PNG")

-    (make-ps-images name resolution paper-width paper-height rename-page-1 verbose
-                   (ly:get-option 'anti-alias-factor))
+    (make-ps-images name
+                   #:resolution resolution
+                   #:page-width paper-width
+                   #:page-height paper-height
+                   #:rename-page-1 rename-page-1
+                   #:be-verbose verbose
+                   #:anti-alias-factor (ly:get-option 'anti-alias-factor)
+                   #:pixmap-format (ly:get-option 'pixmap-format))

     (ly:progress "\n")))
 
 (define-public (postprocess-output paper-book module filename formats)
     (ly:progress "\n")))
 
 (define-public (postprocess-output paper-book module filename formats)

-  (let*
-      ((completed (completize-formats formats))
-       (base (string-regexp-substitute "\\.[a-z]+$" "" filename))
-       (intermediate (remove
-                     (lambda (x)
-                       (member x formats)) 
-                     completed)))
-    (for-each
-     (lambda (f)
-       ((eval (string->symbol (string-append "convert-to-" f)) module)
-       paper-book filename))
-     completed)
-
+  (let* ((completed (completize-formats formats))
+        (base (dir-basename filename ".ps" ".eps"))
+        (intermediate (remove (lambda (x) (member x formats)) completed)))
+    (for-each (lambda (f)
+               ((eval (string->symbol (format "convert-to-~a" f))
+                      module) paper-book filename)) completed)

     (if (ly:get-option 'delete-intermediate-files)
     (if (ly:get-option 'delete-intermediate-files)

-       (for-each
-        (lambda (f)
-          (delete-file (string-append base "." f)))
-        intermediate))
-    ))
+       (for-each (lambda (f)
+                   (if (file-exists? f) (delete-file f)))
+                 (map (lambda (x) (string-append base "." x)) intermediate)))))

 
 (define-public (completize-formats formats)
   (define new-fmts '())
 
 (define-public (completize-formats formats)
   (define new-fmts '())

-

   (if (member "png" formats)
       (set! formats (cons "ps" formats)))
   (if (member "pdf" formats)
       (set! formats (cons "ps" formats)))
   (if (member "png" formats)
       (set! formats (cons "ps" formats)))
   (if (member "pdf" formats)
       (set! formats (cons "ps" formats)))

-
-  (for-each
-   (lambda (x)
-     (if (member x formats) (set! new-fmts (cons x new-fmts))))
-   '("tex" "dvi" "ps" "pdf" "png"))
-
+  (for-each (lambda (x)
+             (if (member x formats) (set! new-fmts (cons x new-fmts))))
+           '("ps" "pdf" "png"))

   (uniq-list (reverse new-fmts)))
 
 (define (header-to-file file-name key value)
   (uniq-list (reverse new-fmts)))
 
 (define (header-to-file file-name key value)


@@ -149,7 +180,10 @@
              (if (equal? "-" file-name) "<stdout>" file-name))
   (if (equal? file-name "-")
       (display value)
              (if (equal? "-" file-name) "<stdout>" file-name))
   (if (equal? file-name "-")
       (display value)

-      (display value (open-file file-name "w")))
+      (let ((port (open-file file-name "w")))
+       (display value port)
+       (close-port port)))
+

   (ly:progress "\n")
   "")
 
   (ly:progress "\n")
   "")
 


@@ -166,3 +200,110 @@
       scope)))
   (apply string-append (map output-scope scopes)))
 
       scope)))
   (apply string-append (map output-scope scopes)))
 

+(define-public (relevant-book-systems book)
+  (let ((systems (ly:paper-book-systems book)))
+    ;; skip booktitles.
+    (if (and (not (ly:get-option 'include-book-title-preview))
+            (pair? systems)
+            (ly:prob-property (car systems) 'is-book-title #f))
+       (cdr systems)
+       systems)))
+
+(define-public (relevant-dump-systems systems)
+  (let ((to-dump-systems '()))
+    (for-each
+      (lambda (sys)
+       (if (or (paper-system-title? sys)
+               (not (pair? to-dump-systems))
+               (paper-system-title? (car to-dump-systems)))
+           (set! to-dump-systems (cons sys to-dump-systems))))
+      systems)
+    to-dump-systems))
+
+(define missing-stencil-list '())
+
+(define-public (backend-testing output-module)
+  (define (missing-stencil-expression name)
+    (begin
+      (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)))
+
+(define-public (remove-stencil-warnings output-module)
+  (for-each
+    (lambda (x)
+      (module-remove! output-module x))
+    missing-stencil-list))
+
+(define (filter-out pred? lst)
+  (filter (lambda (x) (not (pred? x))) lst))
+
+(define-public (font-name-split font-name)
+  "Return (FONT-NAME . DESIGN-SIZE) from FONT-NAME string or #f."
+  (let ((match (regexp-exec (make-regexp "(.*)-([0-9]*)") font-name)))
+    (if (regexp-match? match)
+       (cons (match:substring match 1) (match:substring match 2))
+       (cons font-name-designsize #f))))
+
+;; Example of a pango-physical-font
+;; ("Emmentaler-11" "/home/janneke/vc/lilypond/out/share/lilypond/current/fonts/otf/emmentaler-11.otf" 0)
+(define-public (pango-pf-font-name pango-pf)
+  "Return the font-name of the pango physical font PANGO-PF."
+  (list-ref pango-pf 0))
+(define-public (pango-pf-file-name pango-pf)
+  "Return the file-name of the pango physical font PANGO-PF."
+  (list-ref pango-pf 1))
+(define-public (pango-pf-fontindex pango-pf)
+  "Return the fontindex of the pango physical font PANGO-PF."
+  (list-ref pango-pf 2))
+
+(define (pango-font-name pango-font)
+  (let ((pf-fonts (ly:pango-font-physical-fonts pango-font)))
+    (if (pair? pf-fonts)
+       (pango-pf-font-name (car pf-fonts))
+       "")))
+
+(define-public (define-fonts paper define-font define-pango-pf)
+  "Return a string of all fonts used in PAPER, invoking the functions
+DEFINE-FONT DEFINE-PANGO-PF for producing the actual font definition."
+
+  (let* ((font-list (ly:paper-fonts paper))
+        (pango-fonts (filter ly:pango-font? font-list))
+        (other-fonts (filter-out ly:pango-font? font-list))
+        (other-font-names (map ly:font-name other-fonts))
+        (pango-only-fonts
+         (filter-out (lambda (x)
+                       (member (pango-font-name x) other-font-names))
+                     pango-fonts)))
+
+  (define (font-load-command font)
+    (let* ((font-name (ly:font-name font))
+          (designsize (ly:font-design-size font))
+          (magnification (* (ly:font-magnification font)))
+          (ops (ly:output-def-lookup paper 'output-scale))
+          (scaling (* ops magnification designsize)))
+      (if (equal? font-name "unknown")
+         (display (list font font-name)))
+      (define-font font font-name scaling)))
+
+  (define (pango-font-load-command pango-font)
+    (let* ((pf-fonts (ly:pango-font-physical-fonts pango-font))
+          (pango-pf (if (pair? pf-fonts) (car pf-fonts) '("" "" 0)))
+          (font-name (pango-pf-font-name pango-pf))
+          (scaling (ly:output-def-lookup paper 'output-scale)))
+      (if (equal? font-name "unknown")
+         (display (list pango-font font-name)))
+      (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)))))