invoke-error-stop-signal
report-invoke-error
+ invoke/quiet
+
+ make-desktop-entry-file
+
locale-category->string))
\f
(invoke-error-term-signal c)
(invoke-error-stop-signal c))))
+(define (open-pipe-with-stderr program . args)
+ "Run PROGRAM with ARGS in an input pipe, but, unlike 'open-pipe*', redirect
+both its standard output and standard error to the pipe. Return two value:
+the pipe to read PROGRAM's data from, and the PID of the child process running
+PROGRAM."
+ ;; 'open-pipe*' doesn't attempt to capture stderr in any way, which is why
+ ;; we need to roll our own.
+ (match (pipe)
+ ((input . output)
+ (match (primitive-fork)
+ (0
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (close-port input)
+ (dup2 (fileno output) 1)
+ (dup2 (fileno output) 2)
+ (apply execlp program program args))
+ (lambda ()
+ (primitive-exit 127))))
+ (pid
+ (close-port output)
+ (values input pid))))))
+
+(define (invoke/quiet program . args)
+ "Invoke PROGRAM with ARGS and capture PROGRAM's standard output and standard
+error. If PROGRAM succeeds, print nothing and return the unspecified value;
+otherwise, raise a '&message' error condition that includes the status code
+and the output of PROGRAM."
+ (let-values (((pipe pid)
+ (apply open-pipe-with-stderr program args)))
+ (let loop ((lines '()))
+ (match (read-line pipe)
+ ((? eof-object?)
+ (close-port pipe)
+ (match (waitpid pid)
+ ((_ . status)
+ (unless (zero? status)
+ (let-syntax ((G_ (syntax-rules () ;for xgettext
+ ((_ str) str))))
+ (raise (condition
+ (&message
+ (message (format #f (G_ "'~a~{ ~a~}' exited \
+with status ~a; output follows:~%~%~{ ~a~%~}")
+ program args
+ (or (status:exit-val status)
+ status)
+ (reverse lines)))))))))))
+ (line
+ (loop (cons line lines)))))))
+
\f
;;;
;;; Text substitution (aka. sed).
(x x)))
(define patch-shebang
- (let ((shebang-rx (make-regexp "^[[:blank:]]*([[:graph:]]+)[[:blank:]]*([[:graph:]]*)(.*)$")))
+ (let ((shebang-rx (make-regexp "^[[:blank:]]*(/[[:graph:]]+)[[:blank:]]*([[:graph:]]*)(.*)$")))
(lambda* (file
#:optional
(path (search-path-as-string->list (getenv "PATH")))
(&wrap-error (program prog)
(type 'no-interpreter-found)))))))))
+(define* (make-desktop-entry-file destination #:key
+ (type "Application") ; One of "Application", "Link" or "Directory".
+ (version "1.1")
+ name
+ (generic-name name)
+ (no-display #f)
+ comment
+ icon
+ (hidden #f)
+ only-show-in
+ not-show-in
+ (d-bus-activatable #f)
+ try-exec
+ exec
+ path
+ (terminal #f)
+ actions
+ mime-type
+ (categories "Application")
+ implements
+ keywords
+ (startup-notify #t)
+ startup-w-m-class
+ #:rest all-args)
+ "Create a desktop entry file at DESTINATION.
+You must specify NAME.
+
+Values can be booleans, numbers, strings or list of strings.
+
+Additionally, locales can be specified with an alist where the key is the
+locale. The #f key specifies the default. Example:
+
+ #:name '((#f \"I love Guix\") (\"fr\" \"J'aime Guix\"))
+
+produces
+
+ Name=I love Guix
+ Name[fr]=J'aime Guix
+
+For a complete description of the format, see the specifications at
+https://specifications.freedesktop.org/desktop-entry-spec/desktop-entry-spec-latest.html."
+ (define (escape-semicolon s)
+ (string-join (string-split s #\;) "\\;"))
+ (define* (parse key value #:optional locale)
+ (set! value (match value
+ (#t "true")
+ (#f "false")
+ ((? number? n) n)
+ ((? string? s) (escape-semicolon s))
+ ((? list? value)
+ (catch 'wrong-type-arg
+ (lambda () (string-join (map escape-semicolon value) ";"))
+ (lambda args (error "List arguments can only contain strings: ~a" args))))
+ (_ (error "Value must be a boolean, number, string or list of strings"))))
+ (format #t "~a=~a~%"
+ (if locale
+ (format #f "~a[~a]" key locale)
+ key)
+ value))
+
+ (define key-error-message "This procedure only takes key arguments beside DESTINATION")
+
+ (unless name
+ (error "Missing NAME key argument"))
+ (unless (member #:type all-args)
+ (set! all-args (append (list #:type type) all-args)))
+ (mkdir-p (dirname destination))
+
+ (with-output-to-file destination
+ (lambda ()
+ (format #t "[Desktop Entry]~%")
+ (let loop ((args all-args))
+ (match args
+ (() #t)
+ ((_) (error key-error-message))
+ ((key value . ...)
+ (unless (keyword? key)
+ (error key-error-message))
+ (set! key
+ (string-join (map string-titlecase
+ (string-split (symbol->string
+ (keyword->symbol key))
+ #\-))
+ ""))
+ (match value
+ (((_ . _) . _)
+ (for-each (lambda (locale-subvalue)
+ (parse key
+ (if (and (list? (cdr locale-subvalue))
+ (= 1 (length (cdr locale-subvalue))))
+ ;; Support both proper and improper lists for convenience.
+ (cadr locale-subvalue)
+ (cdr locale-subvalue))
+ (car locale-subvalue)))
+ value))
+ (_
+ (parse key value)))
+ (loop (cddr args))))))))
+
\f
;;;
;;; Locales.
HCoop / jackhill / guix / guix.git / blobdiff