X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fbackend-library.scm;h=3a4ccab817871d821b3e6641e1b0e4d044191e2f;hb=e13b4cde643ebb4df93e70fa9fde6b3f2d075221;hp=5258bcf516249978a06d25166fa46b6b50964dc4;hpb=e0fe5d924082970ba7280ccb148eadababf00983;p=lilypond.git diff --git a/scm/backend-library.scm b/scm/backend-library.scm index 5258bcf516..3a4ccab817 100644 --- a/scm/backend-library.scm +++ b/scm/backend-library.scm @@ -2,13 +2,16 @@ ;;;; ;;;; source file of the GNU LilyPond music typesetter ;;;; -;;;; (c) 2005--2006 Jan Nieuwenhuizen +;;;; (c) 2005--2009 Jan Nieuwenhuizen ;;;; Han-Wen Nienhuys ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; backend helpers. -(define-public (ly:system command) +(use-modules (scm ps-to-png) + (ice-9 optargs)) + +(define-public (ly:system command . rest) (let* ((status 0) (dev-null "/dev/null") (silenced (if (or (ly:get-option 'verbose) @@ -16,9 +19,15 @@ 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) @@ -26,6 +35,22 @@ ;; 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" @@ -51,24 +76,24 @@ (define-public (postscript->pdf paper-width paper-height name) (let* ((pdf-name (string-append - (basename (basename name ".ps") ".eps") + (dir-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 ))) + "-dEPSCrop" + (ly:format "-dDEVICEWIDTHPOINTS=~$\ + -dDEVICEHEIGHTPOINTS=~$" + paper-width paper-height))) - (cmd (format #f + (cmd (simple-format #f "~a\ ~a\ ~a\ ~a\ - -dCompatibilityLevel=1.4 \ + -dCompatibilityLevel=1.4\ -dNOPAUSE\ -dBATCH\ - -r1200 \ + -r1200\ -sDEVICE=pdfwrite\ -sOutputFile=~S\ -c .setpdfwrite\ @@ -76,9 +101,10 @@ " (search-gs) (if (ly:get-option 'verbose) "" "-q") - (if (ly:get-option 'gs-load-fonts) - " -dNOSAFER " - " -dSAFER ") + (if (or (ly:get-option 'gs-load-fonts) + (ly:get-option 'gs-load-lily-fonts)) + "-dNOSAFER" + "-dSAFER") paper-size-string pdf-name name))) @@ -87,75 +113,52 @@ (if (eq? PLATFORM 'windows) (begin (set! cmd (string-regexp-substitute "=" "#" cmd)) - (set! cmd (string-regexp-substitute "-dSAFER " "" cmd)))) - - (if (access? pdf-name W_OK) - (delete-file pdf-name)) + (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:system cmd) - )) - -(use-modules (scm ps-to-png)) + (ly:system cmd))) (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. - ;;(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") - (make-ps-images name #:resolution resolution - #:page-width paper-width + #: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) - ) - + #:pixmap-format (ly:get-option 'pixmap-format)) (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 (format "convert-to-~a" 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) - (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 '()) - (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) @@ -187,3 +190,26 @@ scope))) (apply string-append (map output-scope scopes))) +(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))