* Guile 100 Prob #4 TAR files @ 2013-04-02 5:37 Mike Gran 2013-05-04 23:24 ` Mark H Weaver 0 siblings, 1 reply; 6+ messages in thread From: Mike Gran @ 2013-04-02 5:37 UTC (permalink / raw) To: Guile User Challenge #4 in the Guile 100 Programs Project is to write script that can pack files into a tar-format archive. It is the fourth and final challenge in this month's theme, which is "/bin - reimplementing common Posix tools". Details are at http://www.lonelycactus.com/guile100/html/Problem-4.html The Guile 100 Programs Project is an attempt to collaboratively generate a set of examples of how to use the GNU Guile implementation of Scheme. To help ensure that each challenge has at least one completed implementation, an "official volunteer" will be chosen at random from those that have expressed interest in the project. If that official volunteer can complete the task in two weeks, he or she will receive a bounty of 100 USD. The official volunteer for this week's challenge will be chosen on Wednesday Mar 27. For more information, check out the project's website at http://www.lonelycactus.com/guile100 To request to join the project as a potential official volunteer, or to otherwise contact the project, e-mail guile100@lonelycactus.com Thanks, Mike Gran ^ permalink raw reply [flat|nested] 6+ messages in thread
* Re: Guile 100 Prob #4 TAR files 2013-04-02 5:37 Guile 100 Prob #4 TAR files Mike Gran @ 2013-05-04 23:24 ` Mark H Weaver 2013-05-04 23:44 ` Jez 2013-05-05 2:47 ` Mike Gran 0 siblings, 2 replies; 6+ messages in thread From: Mark H Weaver @ 2013-05-04 23:24 UTC (permalink / raw) To: Mike Gran; +Cc: Guile User [-- Attachment #1: Type: text/plain, Size: 1618 bytes --] Hi Mike, I've attached my solution to Guile 100 Problem #4: TAR files. It should work with Guile 2.0.5 or later. This program does more than you asked for. It aims to be a fully functional producer of USTAR archives, and follows the behavior of GNU tar with the --format=ustar option. In particular, directories, symlinks, fifos, and device files are handled as in GNU tar. The only missing feature I'm aware of is hard link detection. Some notable differences from your specification: * A footer (1024 null bytes) is placed at the end of the entire archive, not at the end of each file. USTAR readers stop reading the file when they find a footer. * All ASCII characters are supported. The set of characters you specified did not include tilde (~), which seemed problematic. If you really want the reduced set, see the commented-out expression in 'ustar-charset'. * The pathname is split into 'prefix' and 'name' fields following the behavior of GNU tar. In particular, the whole path is put into 'name' if it fits, which violates your requirement that 'name' may not contain '/'. See the comment above 'ustar-path-name-split' for details. * The checksum field actually has format number[7] followed by a space, i.e. six octal digits followed by a NULL and a space. Apart from the behavior of GNU tar, I consulted the following documents for guidance: https://en.wikipedia.org/wiki/Ustar http://www.freebsd.org/cgi/man.cgi?query=tar&sektion=5&manpath=FreeBSD+8-current http://cdrecord.berlios.de/private/man/star/star.4.html Comments and suggestions welcome. Mark [-- Attachment #2: USTAR archiver for Guile 2.0.5+ --] [-- Type: text/plain, Size: 12458 bytes --] #!/usr/bin/guile \ -e main -s !# ;;; Copyright (C) 2013 Mark H Weaver <mhw@netris.org> ;;; ;;; This program is free software: you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation, either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program. If not, see <http://www.gnu.org/licenses/>. (use-modules (srfi srfi-1) (ice-9 match) (ice-9 receive) (rnrs bytevectors) (rnrs io ports)) ;; 'file-name-separator-string' and 'file-name-separator?' are ;; included in Guile 2.0.9 and later. (define file-name-separator-string "/") (define (file-name-separator? c) (char=? c #\/)) (define (fmt-error fmt . args) (error (apply format #f fmt args))) ;; Like 'string-pad-right', but for bytevectors. However, unlike ;; 'string-pad-right', truncation is not allowed here. (define* (bytevector-pad bv len #:optional (byte 0) (start 0) (end (bytevector-length bv))) (when (< len (- end start)) (fmt-error "bytevector-pad: truncation would occur: len ~a, start ~a, end ~a, bv ~s" len start end bv)) (let ((result (make-bytevector len byte))) (bytevector-copy! bv start result 0 (- end start)) result)) (define (bytevector-append . bvs) (let* ((lengths (map bytevector-length bvs)) (total (fold + 0 lengths)) (result (make-bytevector total))) (fold (lambda (bv len pos) (bytevector-copy! bv 0 result pos len) (+ pos len)) 0 bvs lengths) result)) (define ustar-charset #; (char-set-union (ucs-range->char-set #x20 #x23) (ucs-range->char-set #x25 #x40) (ucs-range->char-set #x41 #x5B) (ucs-range->char-set #x5F #x60) (ucs-range->char-set #x61 #x7B)) char-set:ascii) (define (valid-ustar-char? c) (char-set-contains? ustar-charset c)) (define (ustar-string n str name) (unless (>= n (string-length str)) (fmt-error "~a is too long (max ~a): ~a" name n str)) (unless (string-every valid-ustar-char? str) (fmt-error "~a contains unsupported character(s): ~s in ~s" name (string-filter (negate valid-ustar-char?) str) str)) (bytevector-pad (string->utf8 str) n)) (define (ustar-0string n str name) (bytevector-pad (ustar-string (- n 1) str name) n)) (define (ustar-number n num name) (unless (and (integer? num) (exact? num) (not (negative? num))) (fmt-error "~a is not a non-negative exact integer: ~a" name num)) (unless (< num (expt 8 (- n 1))) (fmt-error "~a is too large (max ~a): ~a" name (expt 8 (- n 1)) num)) (bytevector-pad (string->utf8 (string-pad (number->string num 8) (- n 1) #\0)) n)) (define (checksum-bv bv) (let ((len (bytevector-length bv))) (let loop ((i 0) (sum 0)) (if (< i len) (loop (+ i 1) (+ sum (bytevector-u8-ref bv i))) sum)))) (define (checksum . bvs) (fold + 0 (map checksum-bv bvs))) (define nuls (make-bytevector 512 0)) ;; write a ustar record of exactly 512 bytes, starting with the ;; segment of BV between START (inclusive) and END (exclusive), and ;; padded at the end with nuls as needed. (define* (write-ustar-record port bv #:optional (start 0) (end (bytevector-length bv))) (when (< 512 (- end start)) (fmt-error "write-ustar-record: record too long: start ~s, end ~s, bv ~s" start end bv)) ;; We could have used 'bytevector-pad' here, ;; but instead use a method that avoids allocation. (put-bytevector port bv start end) (put-bytevector port nuls 0 (- 512 (- end start)))) ;; write 1024 zero bytes, which indicates the end of a ustar archive. (define (write-ustar-footer port) (put-bytevector port nuls) (put-bytevector port nuls)) (define (compose-path-name dir name) (if (or (string-null? dir) (file-name-separator? (string-ref dir (- (string-length dir) 1)))) (string-append dir name) (string-append dir "/" name))) ;; Like 'call-with-port', but also closes PORT if an error occurs. (define (call-with-port* port proc) (dynamic-wind (lambda () #f) (lambda () (proc port)) (lambda () (close port)))) (define (call-with-dirstream* dirstream proc) (dynamic-wind (lambda () #f) (lambda () (proc dirstream)) (lambda () (closedir dirstream)))) (define (files-in-directory dir) (call-with-dirstream* (opendir dir) (lambda (dirstream) (let loop ((files '())) (let ((name (readdir dirstream))) (cond ((eof-object? name) (reverse files)) ((member name '("." "..")) (loop files)) (else (loop (cons (compose-path-name dir name) files))))))))) ;; split the path into prefix and name fields for purposes of the ;; ustar header. If the entire path fits in the name field (100 chars ;; max), then leave the prefix empty. Otherwise, try to put the last ;; component into the name field and everything else into the prefix ;; field (155 chars max). If that fails, put as much as possible into ;; the prefix and the rest into the name field. This follows the ;; behavior of GNU tar when creating a ustar archive. (define (ustar-path-name-split path orig-path) (define (too-long) (fmt-error "~a: file name too long" orig-path)) (let ((len (string-length path))) (cond ((<= len 100) (values "" path)) ((> len 256) (too-long)) ((string-rindex path file-name-separator? (- len 101) (min (- len 1) 156)) => (lambda (i) (values (substring path 0 i) (substring path (+ i 1) len)))) (else (too-long))))) (define (write-ustar-header port path st) (let* ((type (stat:type st)) (perms (stat:perms st)) (mtime (stat:mtime st)) (uid (stat:uid st)) (gid (stat:gid st)) (uname (or (false-if-exception (passwd:name (getpwuid uid))) "")) (gname (or (false-if-exception (group:name (getgrgid gid))) "")) (size (case type ((regular) (stat:size st)) (else 0))) (type-flag (case type ((regular) "0") ((symlink) "2") ((char-special) "3") ((block-special) "4") ((directory) "5") ((fifo) "6") (else (fmt-error "~a: unsupported file type ~a" path type)))) (link-name (case type ((symlink) (readlink path)) (else ""))) (dev-major (case type ((char-special block-special) (quotient (stat:rdev st) 256)) (else 0))) (dev-minor (case type ((char-special block-special) (remainder (stat:rdev st) 256)) (else 0))) ;; Convert file name separators to slashes. (slash-path (string-map (lambda (c) (if (file-name-separator? c) #\/ c)) path)) ;; Make the path name relative. ;; TODO: handle drive letters on windows. (relative-path (if (string-every #\/ slash-path) "." (string-trim slash-path #\/))) ;; If it's a directory, add a trailing slash, ;; otherwise remove trailing slashes. (full-path (case type ((directory) (string-append relative-path "/")) (else (string-trim-right relative-path #\/))))) (receive (prefix name) (ustar-path-name-split full-path path) (let* ((%name (ustar-string 100 name "file name")) (%mode (ustar-number 8 perms "file mode")) (%uid (ustar-number 8 uid "user id")) (%gid (ustar-number 8 gid "group id")) (%size (ustar-number 12 size "file size")) (%mtime (ustar-number 12 mtime "modification time")) (%type-flag (ustar-string 1 type-flag "type flag")) (%link-name (ustar-string 100 link-name "link name")) (%magic (ustar-0string 6 "ustar" "magic field")) (%version (ustar-string 2 "00" "version number")) (%uname (ustar-0string 32 uname "user name")) (%gname (ustar-0string 32 gname "group name")) (%dev-major (ustar-number 8 dev-major "dev major")) (%dev-minor (ustar-number 8 dev-minor "dev minor")) (%prefix (ustar-string 155 prefix "directory name")) (%dummy-checksum (string->utf8 " ")) (%checksum (bytevector-append (ustar-number 7 (checksum %name %mode %uid %gid %size %mtime %dummy-checksum %type-flag %link-name %magic %version %uname %gname %dev-major %dev-minor %prefix) "checksum") (string->utf8 " ")))) (write-ustar-record port (bytevector-append %name %mode %uid %gid %size %mtime %checksum %type-flag %link-name %magic %version %uname %gname %dev-major %dev-minor %prefix)))))) (define (write-ustar-path port path) (let* ((path (if (string-every file-name-separator? path) file-name-separator-string (string-trim-right path file-name-separator?))) (st (lstat path)) (type (stat:type st)) (size (stat:size st))) (write-ustar-header port path st) (case type ((regular) (call-with-port* (open-file path "rb") (lambda (in) (let ((buf (make-bytevector 512))) (let loop ((left size)) (when (positive? left) (let* ((asked (min left 512)) (obtained (get-bytevector-n! in buf 0 asked))) (when (or (eof-object? obtained) (< obtained asked)) (fmt-error "~a: file appears to have shrunk" path)) (write-ustar-record port buf 0 obtained) (loop (- left obtained))))))))) ((directory) (for-each (lambda (path) (write-ustar-path port path)) (files-in-directory path)))))) (define (write-ustar-archive output-path paths) (catch #t (lambda () (call-with-port* (open-file output-path "wb") (lambda (out) (for-each (lambda (path) (write-ustar-path out path)) paths) (write-ustar-footer out)))) (lambda (key subr message args . rest) (false-if-exception (delete-file output-path)) (format (current-error-port) "ERROR: ~a\n" (apply format #f message args)) (exit 1)))) (define (main args) (match args ((program output-path paths ...) (write-ustar-archive output-path paths)) (_ (display "Usage: ustar <archive> <file> ...\n" (current-error-port)) (exit 1)))) ;;; Local Variables: ;;; mode: scheme ;;; eval: (put 'call-with-port* 'scheme-indent-function 1) ;;; eval: (put 'call-with-dirstream* 'scheme-indent-function 1) ;;; End: ^ permalink raw reply [flat|nested] 6+ messages in thread
* Re: Guile 100 Prob #4 TAR files 2013-05-04 23:24 ` Mark H Weaver @ 2013-05-04 23:44 ` Jez 2013-05-05 2:47 ` Mike Gran 2013-05-05 2:47 ` Mike Gran 1 sibling, 1 reply; 6+ messages in thread From: Jez @ 2013-05-04 23:44 UTC (permalink / raw) To: Guile User [-- Attachment #1: Type: text/plain, Size: 15157 bytes --] I actually submitted a pull request for this challenge earlier today: https://github.com/spk121/guile100/pull/1/files Not as fully-featured as Mark's, though. I just did what was spec'ed out, with the exception of moving the footer to the end of the archive rather than having it at the end of each file. Jez On Sat, May 4, 2013 at 7:24 PM, Mark H Weaver <mhw@netris.org> wrote: > Hi Mike, > > I've attached my solution to Guile 100 Problem #4: TAR files. It should > work with Guile 2.0.5 or later. > > This program does more than you asked for. It aims to be a fully > functional producer of USTAR archives, and follows the behavior of GNU > tar with the --format=ustar option. In particular, directories, > symlinks, fifos, and device files are handled as in GNU tar. The only > missing feature I'm aware of is hard link detection. > > Some notable differences from your specification: > > * A footer (1024 null bytes) is placed at the end of the entire archive, > not at the end of each file. USTAR readers stop reading the file when > they find a footer. > > * All ASCII characters are supported. The set of characters you > specified did not include tilde (~), which seemed problematic. > If you really want the reduced set, see the commented-out expression > in 'ustar-charset'. > > * The pathname is split into 'prefix' and 'name' fields following the > behavior of GNU tar. In particular, the whole path is put into 'name' > if it fits, which violates your requirement that 'name' may not > contain '/'. See the comment above 'ustar-path-name-split' for > details. > > * The checksum field actually has format number[7] followed by a space, > i.e. six octal digits followed by a NULL and a space. > > Apart from the behavior of GNU tar, I consulted the following documents > for guidance: > > https://en.wikipedia.org/wiki/Ustar > > http://www.freebsd.org/cgi/man.cgi?query=tar&sektion=5&manpath=FreeBSD+8-current > http://cdrecord.berlios.de/private/man/star/star.4.html > > Comments and suggestions welcome. > > Mark > > > > #!/usr/bin/guile \ > -e main -s > !# > ;;; Copyright (C) 2013 Mark H Weaver <mhw@netris.org> > ;;; > ;;; This program is free software: you can redistribute it and/or modify > ;;; it under the terms of the GNU General Public License as published by > ;;; the Free Software Foundation, either version 3 of the License, or > ;;; (at your option) any later version. > ;;; > ;;; This program is distributed in the hope that it will be useful, > ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of > ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the > ;;; GNU General Public License for more details. > ;;; > ;;; You should have received a copy of the GNU General Public License > ;;; along with this program. If not, see <http://www.gnu.org/licenses/>. > > (use-modules (srfi srfi-1) > (ice-9 match) > (ice-9 receive) > (rnrs bytevectors) > (rnrs io ports)) > > ;; 'file-name-separator-string' and 'file-name-separator?' are > ;; included in Guile 2.0.9 and later. > (define file-name-separator-string "/") > (define (file-name-separator? c) (char=? c #\/)) > > > (define (fmt-error fmt . args) > (error (apply format #f fmt args))) > > ;; Like 'string-pad-right', but for bytevectors. However, unlike > ;; 'string-pad-right', truncation is not allowed here. > (define* (bytevector-pad > bv len #:optional (byte 0) (start 0) (end (bytevector-length > bv))) > (when (< len (- end start)) > (fmt-error > "bytevector-pad: truncation would occur: len ~a, start ~a, end ~a, bv > ~s" > len start end bv)) > (let ((result (make-bytevector len byte))) > (bytevector-copy! bv start result 0 (- end start)) > result)) > > (define (bytevector-append . bvs) > (let* ((lengths (map bytevector-length bvs)) > (total (fold + 0 lengths)) > (result (make-bytevector total))) > (fold (lambda (bv len pos) > (bytevector-copy! bv 0 result pos len) > (+ pos len)) > 0 bvs lengths) > result)) > > (define ustar-charset > #; > (char-set-union (ucs-range->char-set #x20 #x23) > (ucs-range->char-set #x25 #x40) > (ucs-range->char-set #x41 #x5B) > (ucs-range->char-set #x5F #x60) > (ucs-range->char-set #x61 #x7B)) > char-set:ascii) > > (define (valid-ustar-char? c) > (char-set-contains? ustar-charset c)) > > (define (ustar-string n str name) > (unless (>= n (string-length str)) > (fmt-error "~a is too long (max ~a): ~a" name n str)) > (unless (string-every valid-ustar-char? str) > (fmt-error "~a contains unsupported character(s): ~s in ~s" > name > (string-filter (negate valid-ustar-char?) str) > str)) > (bytevector-pad (string->utf8 str) n)) > > (define (ustar-0string n str name) > (bytevector-pad (ustar-string (- n 1) str name) > n)) > > (define (ustar-number n num name) > (unless (and (integer? num) > (exact? num) > (not (negative? num))) > (fmt-error "~a is not a non-negative exact integer: ~a" name num)) > (unless (< num (expt 8 (- n 1))) > (fmt-error "~a is too large (max ~a): ~a" name (expt 8 (- n 1)) num)) > (bytevector-pad (string->utf8 (string-pad (number->string num 8) > (- n 1) > #\0)) > n)) > > (define (checksum-bv bv) > (let ((len (bytevector-length bv))) > (let loop ((i 0) (sum 0)) > (if (< i len) > (loop (+ i 1) (+ sum (bytevector-u8-ref bv i))) > sum)))) > > (define (checksum . bvs) > (fold + 0 (map checksum-bv bvs))) > > (define nuls (make-bytevector 512 0)) > > ;; write a ustar record of exactly 512 bytes, starting with the > ;; segment of BV between START (inclusive) and END (exclusive), and > ;; padded at the end with nuls as needed. > (define* (write-ustar-record > port bv #:optional (start 0) (end (bytevector-length bv))) > (when (< 512 (- end start)) > (fmt-error "write-ustar-record: record too long: start ~s, end ~s, bv > ~s" > start end bv)) > ;; We could have used 'bytevector-pad' here, > ;; but instead use a method that avoids allocation. > (put-bytevector port bv start end) > (put-bytevector port nuls 0 (- 512 (- end start)))) > > ;; write 1024 zero bytes, which indicates the end of a ustar archive. > (define (write-ustar-footer port) > (put-bytevector port nuls) > (put-bytevector port nuls)) > > (define (compose-path-name dir name) > (if (or (string-null? dir) > (file-name-separator? (string-ref dir (- (string-length dir) > 1)))) > (string-append dir name) > (string-append dir "/" name))) > > ;; Like 'call-with-port', but also closes PORT if an error occurs. > (define (call-with-port* port proc) > (dynamic-wind > (lambda () #f) > (lambda () (proc port)) > (lambda () (close port)))) > > (define (call-with-dirstream* dirstream proc) > (dynamic-wind > (lambda () #f) > (lambda () (proc dirstream)) > (lambda () (closedir dirstream)))) > > (define (files-in-directory dir) > (call-with-dirstream* (opendir dir) > (lambda (dirstream) > (let loop ((files '())) > (let ((name (readdir dirstream))) > (cond ((eof-object? name) > (reverse files)) > ((member name '("." "..")) > (loop files)) > (else > (loop (cons (compose-path-name dir name) files))))))))) > > ;; split the path into prefix and name fields for purposes of the > ;; ustar header. If the entire path fits in the name field (100 chars > ;; max), then leave the prefix empty. Otherwise, try to put the last > ;; component into the name field and everything else into the prefix > ;; field (155 chars max). If that fails, put as much as possible into > ;; the prefix and the rest into the name field. This follows the > ;; behavior of GNU tar when creating a ustar archive. > (define (ustar-path-name-split path orig-path) > (define (too-long) > (fmt-error "~a: file name too long" orig-path)) > (let ((len (string-length path))) > (cond ((<= len 100) (values "" path)) > ((> len 256) (too-long)) > ((string-rindex path > file-name-separator? > (- len 101) > (min (- len 1) 156)) > => (lambda (i) > (values (substring path 0 i) > (substring path (+ i 1) len)))) > (else (too-long))))) > > (define (write-ustar-header port path st) > (let* ((type (stat:type st)) > (perms (stat:perms st)) > (mtime (stat:mtime st)) > (uid (stat:uid st)) > (gid (stat:gid st)) > (uname (or (false-if-exception (passwd:name (getpwuid uid))) > "")) > (gname (or (false-if-exception (group:name (getgrgid gid))) > "")) > > (size (case type > ((regular) (stat:size st)) > (else 0))) > > (type-flag (case type > ((regular) "0") > ((symlink) "2") > ((char-special) "3") > ((block-special) "4") > ((directory) "5") > ((fifo) "6") > (else (fmt-error "~a: unsupported file type ~a" > path type)))) > > (link-name (case type > ((symlink) (readlink path)) > (else ""))) > > (dev-major (case type > ((char-special block-special) > (quotient (stat:rdev st) 256)) > (else 0))) > (dev-minor (case type > ((char-special block-special) > (remainder (stat:rdev st) 256)) > (else 0))) > > ;; Convert file name separators to slashes. > (slash-path (string-map (lambda (c) > (if (file-name-separator? c) #\/ c)) > path)) > > ;; Make the path name relative. > ;; TODO: handle drive letters on windows. > (relative-path (if (string-every #\/ slash-path) > "." > (string-trim slash-path #\/))) > > ;; If it's a directory, add a trailing slash, > ;; otherwise remove trailing slashes. > (full-path (case type > ((directory) (string-append relative-path "/")) > (else (string-trim-right relative-path #\/))))) > > (receive (prefix name) (ustar-path-name-split full-path path) > > (let* ((%name (ustar-string 100 name "file name")) > (%mode (ustar-number 8 perms "file mode")) > (%uid (ustar-number 8 uid "user id")) > (%gid (ustar-number 8 gid "group id")) > (%size (ustar-number 12 size "file size")) > (%mtime (ustar-number 12 mtime "modification time")) > (%type-flag (ustar-string 1 type-flag "type flag")) > (%link-name (ustar-string 100 link-name "link name")) > (%magic (ustar-0string 6 "ustar" "magic field")) > (%version (ustar-string 2 "00" "version number")) > (%uname (ustar-0string 32 uname "user name")) > (%gname (ustar-0string 32 gname "group name")) > (%dev-major (ustar-number 8 dev-major "dev major")) > (%dev-minor (ustar-number 8 dev-minor "dev minor")) > (%prefix (ustar-string 155 prefix "directory name")) > > (%dummy-checksum (string->utf8 " ")) > > (%checksum > (bytevector-append > (ustar-number 7 (checksum %name %mode %uid %gid %size %mtime > %dummy-checksum > %type-flag %link-name %magic > %version > %uname %gname %dev-major > %dev-minor > %prefix) > "checksum") > (string->utf8 " ")))) > > (write-ustar-record port > (bytevector-append > %name %mode %uid %gid %size %mtime > %checksum > %type-flag %link-name %magic %version > %uname %gname %dev-major %dev-minor > %prefix)))))) > > (define (write-ustar-path port path) > (let* ((path (if (string-every file-name-separator? path) > file-name-separator-string > (string-trim-right path file-name-separator?))) > (st (lstat path)) > (type (stat:type st)) > (size (stat:size st))) > (write-ustar-header port path st) > (case type > ((regular) > (call-with-port* (open-file path "rb") > (lambda (in) > (let ((buf (make-bytevector 512))) > (let loop ((left size)) > (when (positive? left) > (let* ((asked (min left 512)) > (obtained (get-bytevector-n! in buf 0 asked))) > (when (or (eof-object? obtained) > (< obtained asked)) > (fmt-error "~a: file appears to have shrunk" path)) > (write-ustar-record port buf 0 obtained) > (loop (- left obtained))))))))) > ((directory) > (for-each (lambda (path) (write-ustar-path port path)) > (files-in-directory path)))))) > > (define (write-ustar-archive output-path paths) > (catch #t > (lambda () > (call-with-port* (open-file output-path "wb") > (lambda (out) > (for-each (lambda (path) > (write-ustar-path out path)) > paths) > (write-ustar-footer out)))) > (lambda (key subr message args . rest) > (false-if-exception (delete-file output-path)) > (format (current-error-port) "ERROR: ~a\n" > (apply format #f message args)) > (exit 1)))) > > (define (main args) > (match args > ((program output-path paths ...) > (write-ustar-archive output-path paths)) > (_ (display "Usage: ustar <archive> <file> ...\n" (current-error-port)) > (exit 1)))) > > ;;; Local Variables: > ;;; mode: scheme > ;;; eval: (put 'call-with-port* 'scheme-indent-function 1) > ;;; eval: (put 'call-with-dirstream* 'scheme-indent-function 1) > ;;; End: > > [-- Attachment #2: Type: text/html, Size: 17815 bytes --] ^ permalink raw reply [flat|nested] 6+ messages in thread
* Re: Guile 100 Prob #4 TAR files 2013-05-04 23:44 ` Jez @ 2013-05-05 2:47 ` Mike Gran 2013-05-05 11:27 ` Jez 0 siblings, 1 reply; 6+ messages in thread From: Mike Gran @ 2013-05-05 2:47 UTC (permalink / raw) To: Jez, Guile User > From: Jez <jezreel@gmail.com> >I actually submitted a pull request for this challenge > earlier today: https://github.com/spk121/guile100/pull/1/files Great! You were the first entry to meet the spec. > Not as fully-featured as Mark's, though. I just did what was > spec'ed out, with the exception of moving the footer to the > end of the archive rather than having it at the end of each file. Yeah, sorry about that footer spec error. I found two possible corrections - you make an extra 512 byte block if a file ends exactly on a block boundary (like a zero byte file, for example) - For files archived from the current directory, you explicitly add the "." path to the archive. Most other tar programs don't do that. Not that speed was the point of this exercise, but, in creating an archive from 10000 6kB text files, this script was about 10x slower than GNU tar, and slightly slower than Mark's tar. -Mike ^ permalink raw reply [flat|nested] 6+ messages in thread
* Re: Guile 100 Prob #4 TAR files 2013-05-05 2:47 ` Mike Gran @ 2013-05-05 11:27 ` Jez 0 siblings, 0 replies; 6+ messages in thread From: Jez @ 2013-05-05 11:27 UTC (permalink / raw) To: Mike Gran; +Cc: Guile User [-- Attachment #1: Type: text/plain, Size: 1630 bytes --] > - you make an extra 512 byte block if a file ends exactly on a block boundary (like a zero byte file, for example) I couldn't reproduce this, actually. Are you using the most recent copy of the code? My initial push had that issue, but I think I fixed it in this commit<https://github.com/int3/guile100/commit/f39f4fa3e4fac55ba42403f83a05416237fbe0ee> . > - For files archived from the current directory, you explicitly add the "." path to the archive. Most other tar programs don't do that. Yeah, that definitely was happening. I've fixed it now. Cheers, Jez On Sat, May 4, 2013 at 10:47 PM, Mike Gran <spk121@yahoo.com> wrote: > > From: Jez <jezreel@gmail.com> > > > >I actually submitted a pull request for this challenge > > earlier today: https://github.com/spk121/guile100/pull/1/files > > Great! You were the first entry to meet the spec. > > > > Not as fully-featured as Mark's, though. I just did what was > > spec'ed out, with the exception of moving the footer to the > > end of the archive rather than having it at the end of each file. > > Yeah, sorry about that footer spec error. > > > I found two possible corrections > - you make an extra 512 byte block if a file ends exactly > on a block boundary (like a zero byte file, for example) > - For files archived from the current directory, you > explicitly add the "." path to the archive. Most other > tar programs don't do that. > > Not that speed was the point of this exercise, but, in > creating an archive from 10000 6kB text files, this script was > about 10x slower than GNU tar, and slightly slower than > Mark's tar. > > > -Mike > > [-- Attachment #2: Type: text/html, Size: 2428 bytes --] ^ permalink raw reply [flat|nested] 6+ messages in thread
* Re: Guile 100 Prob #4 TAR files 2013-05-04 23:24 ` Mark H Weaver 2013-05-04 23:44 ` Jez @ 2013-05-05 2:47 ` Mike Gran 1 sibling, 0 replies; 6+ messages in thread From: Mike Gran @ 2013-05-05 2:47 UTC (permalink / raw) To: Mark H Weaver; +Cc: Guile User > From: Mark H Weaver <mhw@netris.org> > > I've attached my solution to Guile 100 Problem #4: TAR files. It should > work with Guile 2.0.5 or later. > > This program does more than you asked for. It aims to be a fully > functional producer of USTAR archives, and follows the behavior of GNU > tar with the --format=ustar option. In particular, directories, > symlinks, fifos, and device files are handled as in GNU tar. The only > missing feature I'm aware of is hard link detection. Great! > > Some notable differences from your specification: > > * A footer (1024 null bytes) is placed at the end of the entire archive, > not at the end of each file. USTAR readers stop reading the file when > they find a footer. You're right that the footer isn't at the end of each file. > * The checksum field actually has format number[7] followed by a space, > i.e. six octal digits followed by a NULL and a space. This one's a bit controversial. OpenBSD tar uses 7 octal + NULL. The Posix description of ustar in pax doesn't mention the space, either. I made a few test cases and tried to break your script, but, I could find no easy flaw. Awesome. I was only testing regular files, though. Not that speed was the point of this exercise, but, in creating an archive from 10000 6kB text files, this script was about 8x slower than GNU tar, and slightly faster than Jez's solution. -Mike ^ permalink raw reply [flat|nested] 6+ messages in thread
end of thread, other threads:[~2013-05-05 11:27 UTC | newest] Thread overview: 6+ messages (download: mbox.gz follow: Atom feed -- links below jump to the message on this page -- 2013-04-02 5:37 Guile 100 Prob #4 TAR files Mike Gran 2013-05-04 23:24 ` Mark H Weaver 2013-05-04 23:44 ` Jez 2013-05-05 2:47 ` Mike Gran 2013-05-05 11:27 ` Jez 2013-05-05 2:47 ` Mike Gran
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).