;;; Copyright (c) 2014 ;; Michele La Monaca (install-scheme@lamonaca.net) ;;; All rights reserved. (define (install-usage) #<<<< Usage: (install [-p] [-g GROUP] [-m MODE] [-o OWNER] SRC DST) (install [-p] [-g GROUP] [-m MODE] [-o OWNER] SRC ... DIR) (install [-g GROUP] [-m MODE] [-o OWNER] -d DIR ...) -g Set group ownership, instead of process' current group. -m Set permission mode instead of rwxr-xr-x (755). The mode must be expressed in octal notation. -o Set ownership (super-user only). -p Preserve timestamps. Apply modification time of SRC files to corresponding destination files. << ) (define-syntax install (syntax-rules (/# -? -d -g -m -o -p) ((_ -?) (display (install-usage))) ((_ #f p1 p2 p3 #f /# -d arg ...) (install #t p1 p2 p3 #f /# arg ...)) ((_ p0 #f p2 p3 p4 /# -g ** arg ...) (install p0 ** p2 p3 p4 /# arg ...)) ((_ p0 p1 #f p3 p4 /# -m ** arg ...) (install p0 p1 ** p3 p4 /# arg ...)) ((_ p0 p1 p2 #f p4 /# -o ** arg ...) (install p0 p1 p2 ** p4 /# arg ...)) ((_ #f p1 p2 p3 #f /# -p arg ...) (install #f p1 p2 p3 #t /# arg ...)) ((_ #t p1 p2 p3 p4 /# dir1 dir2 ...) (install-directory (list dir1 dir2 ...) mode: (or p2 755) owner: p3 group: p1)) ((_ #f p1 p2 p3 p4 /# arg1 arg2 ... argN) (install-file (list arg1 arg2 ...) argN mode: (or p2 755) owner: p3 group: p1 preserve-time: p4)) ((_ p0 p1 p2 p3 p4 /# arg ...) (syntax-error 'install "invalid syntax")) ((_ arg ...) (install #f #f #f #f #f /# arg ...)))) (define (change-file-owner-or-group target own grp) (if (not (eq? (build-platform) 'mingw32)) (let ((o (if own (if (string? own) (list-ref (user-information own) 2) own) (current-user-id))) (g (if grp (if (string? grp) (list-ref (user-information grp) 3) grp) (current-group-id)))) (change-file-owner target o g)))) (define (change-file-or-dir-mode target mode) (let ((mode (string->number (string-append "#o" (number->string mode))))) (if (and mode (<= 0 mode #o7777)) (if (not (eq? (build-platform) 'mingw32)) (change-file-mode target mode)) (error 'change-file-or-dir-mode "invalid mode")))) (cond-expand (mingw32 (foreign-declare "#include ") (define rename-file** (foreign-lambda* bool ((c-string old) (c-string new)) "C_return(MoveFileEx(old, new, MOVEFILE_REPLACE_EXISTING));\n")) (define (rename-file* old new) (or (rename-file** old new) (error 'rename-file* "unable to rename file"))) (define file=? (foreign-lambda* bool ((c-string file1) (c-string file2)) #<<" HANDLE h1 = CreateFile(file1, 0, FILE_SHARE_READ | FILE_SHARE_WRITE, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); HANDLE h2 = CreateFile(file2, 0, FILE_SHARE_READ | FILE_SHARE_WRITE, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); int ret = 0; if (h1 != INVALID_HANDLE_VALUE && h2 != INVALID_HANDLE_VALUE) { BY_HANDLE_FILE_INFORMATION fInfo1, fInfo2; if (GetFileInformationByHandle(h1, &fInfo1) && GetFileInformationByHandle(h2, &fInfo2)) { /* http://msdn.microsoft.com/en-us/library/aa363788%28v=vs.85%29.aspx */ ret = fInfo1.dwVolumeSerialNumber == fInfo2.dwVolumeSerialNumber && fInfo1.nFileIndexHigh == fInfo2.nFileIndexHigh && fInfo1.nFileIndexLow == fInfo2.nFileIndexLow; } CloseHandle(h1); CloseHandle(h2); } C_return(ret); " ))) (else (define rename-file* rename-file) (define (file=? file1 file2) (handle-exceptions e #f (let ((st1 (file-stat file1)) (st2 (file-stat file2))) (and (= (vector-ref st1 0) (vector-ref st2 0)) ;; same inode (= (vector-ref st1 9) (vector-ref st2 9)))))))) ;; same device (define (install-directory dirs #!key owner group (mode 755)) (let loop ((dirs (if (string? dirs) (list dirs) dirs))) (if (pair? dirs) (let ((dir (car dirs))) (if (and (file-exists? dir) (not (eq? 'directory (file-type dir)))) (error 'install-file (string-append "`"dir "' exists but is not a directory"))) (create-directory dir #t) (change-file-or-dir-mode dir mode) (if (or owner group) (change-file-owner-or-group dir owner group)) (loop (cdr dirs)))))) (define (install-file files target #!key owner group (mode 755) preserve-time) (if (string? files) (set! files (list files)) (if (and (> (length files) 1) (not (directory? target))) (error 'install-file "destination is not a directory"))) (let loop ((sources files)) (if (pair? sources) (let* ((target-is-dir? (directory? target)) (src (car sources)) (dst (if target-is-dir? (make-pathname target (pathname-strip-directory src)) target))) (cond ((not (file-exists? src)) (error 'install-file (string-append "`" src "' does not exist"))) ((if (eq? (build-platform) 'mingw32) (string=? src "nul") (file=? src "/dev/null")) (if target-is-dir? (error 'install-file (string-append (if (eq? (build-platform) 'mingw32) "`nul'" "`/dev/null'") " inappropriate file type")) (file-close (file-open dst (+ open/wronly open/trunc open/creat))))) ((not (eq? 'regular-file (file-type src))) (error 'install-file (string-append "`" src "' not a regular file"))) ((and (file-exists? dst) (file=? src dst)) (error 'install-file (string-append "`" src "' and `" dst "' are the same file"))) (else (receive (fd t) (file-mkstemp (string-append dst "#XXXXXX")) (file-close fd) (handle-exceptions ex (begin (delete-file* t) (error ((condition-property-accessor 'exn 'location) ex) ((condition-property-accessor 'exn 'message) ex))) (begin (file-copy src t 'clobber) (if preserve-time (set! (file-modification-time t) (file-modification-time src))) (change-file-or-dir-mode t mode) (if (or owner group) (change-file-owner-or-group t owner group)) (rename-file* t dst) (loop (cdr sources)))))))))))