unofficial mirror of guix-devel@gnu.org 
 help / color / mirror / code / Atom feed
* Some utility functions
@ 2019-01-01 21:48 Gábor Boskovits
  2019-01-02  7:39 ` Alex Vong
  2019-01-05 21:30 ` Ludovic Courtès
  0 siblings, 2 replies; 5+ messages in thread
From: Gábor Boskovits @ 2019-01-01 21:48 UTC (permalink / raw)
  To: Guix-devel

[-- Attachment #1: Type: text/plain, Size: 165 bytes --]

Hello guix,

I am not sure if I am duplicating functionality here, and also where
these should belong, so I will send them here for discussion.

Best regards,
g_bor

[-- Attachment #2: guix-utils.scm --]
[-- Type: text/x-scheme, Size: 2967 bytes --]

(define (file-size file)
  "Return the size of the regular file FILE in bytes."
  (stat:size (stat file)))

(define (rm-recursive dir)
  "Deletes the DIR directory recursively."
  (invoke "rm" "-r" dir))

(define (check-header file header)
  "Returns a boolean. The return value is true only if the first bytes of the
FILE match exactly the content of the bytevector HEADER."
  (call-with-input-file file
    (lambda (file)
      (equal? (get-bytevector-n file
				(bytevector-length header))
	      header))))

(define (strip-header file header-length)
  "Strips off the first HEADER-LENGTH bytes of the FILE."
  (let ((temp-file (mkstemp! (string-copy "temp-file.XXXXXX"))))
    (let ((content-length (- (file-size file) header-length)))
      (send-file temp-file file content-length header-length))
    (rename-file temp-file file)))

(define (prepend-header file header)
  "Prepends the content of the bytevector HEADER to FILE."
  (let ((temp-file (mkstemp! (string-copy "temp-file.XXXXXX"))))
    (put-bytevector temp-file header)
    (send-file temp-file file (file-size file) 0)
    (rename-file temp-file file)))

(define (reset-file-timestamp file)
  "Resets the access and modification times of FILE."
  (let ((s (lstat file)))
    (unless (eq? (stat:type s) 'symlink)
      (format #t "reset ~a~%" file)
      (utime file 0 0 0 0))))

(define (repack-zip file)
  "Resets the timestamps of the zip archive FILE."
  (let ((dir (mkdtemp! "zip-contents.XXXXXX")))
    (with-directory-excursion dir
      (invoke "unzip" file)
      (delete-file file)
      (for-each reset-file-timestamp
		(find-files dir #:directories? #t))
      (let ((files (find-files "." ".*" #:directories? #t)))
	(apply invoke "zip" "-0" "-X" file files)))
    (rm-recursive dir)))

(define (repack-jmod file)
  "Resets the timestamps of the .jmod FILE."
  (call-with-input-file file
    (lambda (file)
      (let ((header #vu8(#x4a #x4d #x01 #x00)))
	(if (check-header file header)
	    (let ((header-length (bytevector-length header)))
	      (strip-header file header-length)
	      (repack-zip file)
	      (prepend-header file header))
	    (throw 'jmod-error "bad magic"))))))

(define (reset-zip-timestamps dir)
  "Resets the timestamps of all zip achives under DIR."
  (for-each repack-zip
	    (find-files dir ".*.(zip|jar|diz)$")))

(define (reset-jmod-timestamps dir)
  "Resets the timestamps of all jmod files under DIR."
  (for-each repack-jmod
	    (find-files dir ".*.jmod$")))

(define (reset-achive-timestamps dir)
  "Resets the zip and jmod file timestamps of all files under DIR."
  (reset-zip-timestamps dir)
  (reset-jmod-timestamps dir))

(define (for-each-output procedure)
  "Executes the PROCEDURE with the output directory as the sole argument for
all outputs."
  (for-each (compose procedure cdr)
	    outputs))

(define (reset-achive-timepstamps)
  "Resets the zip and jmod file timestamps for all outputs."
  (for-each-output reset-archive-timestamps))


^ permalink raw reply	[flat|nested] 5+ messages in thread
end of thread, other threads:[~2019-01-08 16:30 UTC | newest]

Thread overview: 5+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2019-01-01 21:48 Some utility functions Gábor Boskovits
2019-01-02  7:39 ` Alex Vong
2019-01-05 21:30 ` Ludovic Courtès
2019-01-07  9:57   ` Gábor Boskovits
2019-01-08 16:30     ` Ludovic Courtès

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/guix.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).