andrius
/
gash
mirror of https://git.savannah.gnu.org/git/gash.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

tar: Support symlinks. 

* gash/ustar.scm (read-ustar-file): Support symlinks.
* gash/shell-utils.scm (display-file): Display them.
This commit is contained in:
Jan Nieuwenhuizen 2018-11-03 20:10:23 +01:00
parent 005061d712
commit 63f2d4b5f8
2 changed files with 8 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
gash/shell-utils.scm
View File

@ -342,8 +342,11 @@ TERMINAL-WIDTH. Use COLUMN-GAP spaces between two subsequent columns."
(format #t "~8d" size) (format #t "~8d" size)
(display " ") (display " ")
(display date) (display date)
(display " ")) (display " ")
(display file-name)) (display file-name)
(when (eq? (stat:type st) 'symlink)
(display " -> ")
(display (readlink file-name)))))
(define (multi-opt options name) (define (multi-opt options name)
(let ((opt? (lambda (o) (and (eq? (car o) name) (cdr o))))) (let ((opt? (lambda (o) (and (eq? (car o) name) (cdr o)))))

5
gash/ustar.scm
View File

@ -485,9 +485,10 @@
(if (file-exists? file-name) (delete-file file-name)) (if (file-exists? file-name) (delete-file file-name))
(with-output-to-file file-name thunk)) (with-output-to-file file-name thunk))
((directory) (mkdir-p file-name)) ((directory) (mkdir-p file-name))
((symlink) (throw 'todo "symlink"))) ((symlink) (symlink (ustar-header-link-name header) file-name )))
(thunk)) (thunk))
(when extract? (when (and extract?
(not (eq? (ustar-header-type header) 'symlink)))
(chmod file-name (ustar-header-mode header)) (chmod file-name (ustar-header-mode header))
(let ((mtime (ustar-header-mtime header))) (let ((mtime (ustar-header-mtime header)))
(utime file-name mtime mtime))))) (utime file-name mtime mtime)))))