typechecking tweaks.

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

diff --git a/scm/backend-library.scm b/scm/backend-library.scm
index e200b2dd4ad8a0f715d126f73546863a893ca9ca..eaefaf786752821a525cdfa406a353cbac0e18c9 100644 (file)
--- a/scm/backend-library.scm
+++ b/scm/backend-library.scm
@@ -2,8 +2,8 @@
 ;;;;
 ;;;;  source file of the GNU LilyPond music typesetter
 ;;;; 
 ;;;;
 ;;;;  source file of the GNU LilyPond music typesetter
 ;;;; 

-;;;; (c)  2005 Jan Nieuwenhuizen <janneke@gnu.org>
-;;;; Han-Wen Nienhuys <hanwen@cs.uu.nl>
+;;;; (c) 2005--2006 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;; Han-Wen Nienhuys <hanwen@xs4all.nl>

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


@@ -27,33 +27,67 @@
          (throw 'ly-file-failed)))))
 
 (define-public (sanitize-command-option str)
          (throw 'ly-file-failed)))))
 
 (define-public (sanitize-command-option str)

+  "Kill dubious shell quoting"
+  

   (string-append
    "\""
   (string-append
    "\""

-   (regexp-substitute/global #f "[^- 0-9,.a-zA-Z'\"\\]" str 'pre 'post)
+   (regexp-substitute/global #f "[^-_ 0-9,.a-zA-Z'\"\\]" str 'pre 'post)

    "\""))
 
    "\""))
 

-(define-public (postscript->pdf papersizename name)
-  (let* ((pdf-name (string-append (basename name ".ps") ".pdf" ))
+(define-public (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-public (search-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)
+  (let* ((pdf-name (string-append
+                   (basename (basename name ".ps") ".eps")
+                   ".pdf"))
+        (is-eps (string-match "\\.eps$" name))
+        (paper-size-string (if is-eps
+                               " -dEPSCrop "
+                               (format "-dDEVICEWIDTHPOINTS=~,2f \
+-dDEVICEHEIGHTPOINTS=~,2f "
+                                       paper-width paper-height )))
+

         (cmd (format #f
         (cmd (format #f

-                     "gs\
- -dSAFER\
+                     "~a\
+ ~a\
+ ~a\
+ ~a\

  -dCompatibilityLevel=1.4 \
  -dCompatibilityLevel=1.4 \

- -sPAPERSIZE=~a\
- -q\

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

+ -r1200 \

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

-                     (sanitize-command-option papersizename)
+                     (search-gs)
+                     (if (ly:get-option 'verbose) "" "-q")
+                     (if (ly:get-option 'gs-load-fonts)
+                         " -dNOSAFER "
+                         " -dSAFER ")
+                     paper-size-string

                      pdf-name
                      name)))
     ;; The wrapper on windows cannot handle `=' signs,
     ;; gs has a workaround with #.
     (if (eq? PLATFORM 'windows)
                      pdf-name
                      name)))
     ;; The wrapper on windows cannot handle `=' signs,
     ;; gs has a workaround with #.
     (if (eq? PLATFORM 'windows)

-       (set! cmd (string-regexp-substitute "=" "#" cmd)))
+       (begin
+         (set! cmd (string-regexp-substitute "=" "#" cmd))
+         (set! cmd (string-regexp-substitute "-dSAFER " "" cmd))))

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


@@ -62,50 +96,47 @@
     (ly:progress "\n")
     (ly:system cmd)))
 
     (ly:progress "\n")
     (ly:system cmd)))
 

-(define-public (postscript->png resolution papersizename name)
-  (let* ((prefix (ly:effective-prefix))
+(use-modules (scm ps-to-png))

 
 

-        ;; run the source, if  we are in the build-directory
-        (ps2png-source (if prefix
-                          (format "~a/scripts/lilypond-ps2png.py" prefix)
-                          "lilypond-ps2png"))
-        (cmd (format #f
-                     "~a --resolution=~S --papersize=~a~a ~S"
-                     (if (file-exists? ps2png-source)
-                         (format "python ~a" ps2png-source)
-                         "lilypond-ps2png")
-                     resolution
-                     (sanitize-command-option papersizename)
-                     (if (ly:get-option 'verbose) " --verbose " "")
-                     name)))
+(define-public (postscript->png resolution paper-width paper-height name)

     ;; 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" )))
     ;; 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")

-    (ly:system cmd)
+    (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)

-  (for-each
-   (lambda (f)
-     ((eval (string->symbol (string-append "convert-to-" f)) module)
-      paper-book 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 (format "convert-to-~a" f))
+                      module) paper-book filename)) completed)
+    (if (ly:get-option 'delete-intermediate-files)
+       (for-each (lambda (f)
+                   (delete-file (string-append base "." f))) 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))))
+           '("tex" "dvi" "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)


@@ -117,7 +148,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")
   "")