me
/
guix
Archived
1
0
Fork 0
Code

utils: Restore the mtime/atime of patched files. 

* guix/build/utils.scm (set-file-time): New procedure.
  (patch-shebang): New `keep-mtime?' parameter; call `set-file-time'
  when it's true.
  (patch-makefile-SHELL): Likewise.
master
Ludovic Courtès 2012-12-31 01:17:43 +01:00
parent f678f6d913
commit bc5bf85fa2
1 changed files with 34 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
guix/build/utils.scm
View File

@ -43,6 +43,7 @@
substitute substitute
substitute* substitute*
dump-port dump-port
set-file-time
patch-shebang patch-shebang
patch-makefile-SHELL patch-makefile-SHELL
fold-port-matches fold-port-matches
@ -408,17 +409,29 @@ bytes transferred and the continuation of the transfer as a thunk."
(loop total (loop total
(get-bytevector-n! in buffer 0 buffer-size)))))))) (get-bytevector-n! in buffer 0 buffer-size))))))))
(define (set-file-time file stat)
"Set the atime/mtime of FILE to that specified by STAT."
(utime file
(stat:atime stat)
(stat:mtime stat)
(stat:atimensec stat)
(stat:mtimensec stat)))
(define patch-shebang (define patch-shebang
(let ((shebang-rx (make-regexp "^[[:blank:]]*([[:graph:]]+)(.*)$"))) (let ((shebang-rx (make-regexp "^[[:blank:]]*([[:graph:]]+)(.*)$")))
(lambda* (file (lambda* (file
#:optional (path (search-path-as-string->list (getenv "PATH")))) #:optional
(path (search-path-as-string->list (getenv "PATH")))
#:key (keep-mtime? #t))
"Replace the #! interpreter file name in FILE by a valid one found in "Replace the #! interpreter file name in FILE by a valid one found in
PATH, when FILE actually starts with a shebang. Return #t when FILE was PATH, when FILE actually starts with a shebang. Return #t when FILE was
patched, #f otherwise." patched, #f otherwise. When KEEP-MTIME? is true, the atime/mtime of
FILE are kept unchanged."
(define (patch p interpreter rest-of-line) (define (patch p interpreter rest-of-line)
(let* ((template (string-append file ".XXXXXX")) (let* ((template (string-append file ".XXXXXX"))
(out (mkstemp! template)) (out (mkstemp! template))
(mode (stat:mode (stat file)))) (st (stat file))
(mode (stat:mode st)))
(with-throw-handler #t (with-throw-handler #t
(lambda () (lambda ()
(format out "#!~a~a~%" (format out "#!~a~a~%"
@ -427,6 +440,8 @@ patched, #f otherwise."
(close out) (close out)
(chmod template mode) (chmod template mode)
(rename-file template file) (rename-file template file)
(when keep-mtime?
(set-file-time file st))
#t) #t)
(lambda (key . args) (lambda (key . args)
(format (current-error-port) (format (current-error-port)
@ -458,8 +473,9 @@ patched, #f otherwise."
file (basename cmd)) file (basename cmd))
#f)))))))))))) #f))))))))))))
(define (patch-makefile-SHELL file) (define* (patch-makefile-SHELL file #:key (keep-mtime? #t))
"Patch the `SHELL' variable in FILE, which is supposedly a makefile." "Patch the `SHELL' variable in FILE, which is supposedly a makefile.
When KEEP-MTIME? is true, the atime/mtime of FILE are kept unchanged."
;; For instance, Gettext-generated po/Makefile.in.in do not honor $SHELL. ;; For instance, Gettext-generated po/Makefile.in.in do not honor $SHELL.
@ -475,15 +491,19 @@ patched, #f otherwise."
name)) name))
shell)) shell))
(substitute* file (let ((st (stat file)))
(("^ *SHELL[[:blank:]]*=[[:blank:]]*([[:graph:]]*/)([[:graph:]]+)[[:blank:]]*" _ dir shell) (substitute* file
(let* ((old (string-append dir shell)) (("^ *SHELL[[:blank:]]*=[[:blank:]]*([[:graph:]]*/)([[:graph:]]+)[[:blank:]]*" _ dir shell)
(new (or (find-shell shell) old))) (let* ((old (string-append dir shell))
(unless (string=? new old) (new (or (find-shell shell) old)))
(format (current-error-port) (unless (string=? new old)
"patch-makefile-SHELL: ~a: changing `SHELL' from `~a' to `~a'~%" (format (current-error-port)
file old new)) "patch-makefile-SHELL: ~a: changing `SHELL' from `~a' to `~a'~%"
(string-append "SHELL = " new "\n"))))) file old new))
(string-append "SHELL = " new "\n"))))
(when keep-mtime?
(set-file-time file st))))
(define* (fold-port-matches proc init pattern port (define* (fold-port-matches proc init pattern port
#:optional (unmatched (lambda (_ r) r))) #:optional (unmatched (lambda (_ r) r)))