Guile 100 Prob #4 TAR files

Guile 100 Prob #4 TAR files

[Mike Gran]

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

Re: Guile 100 Prob #4 TAR files

[Mark H Weaver]

[-- 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:

Re: Guile 100 Prob #4 TAR files

[Jez]

[-- 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 --]

Re: Guile 100 Prob #4 TAR files

[Mike Gran]

> 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

Re: Guile 100 Prob #4 TAR files

[Jez]

[-- 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 --]

Re: Guile 100 Prob #4 TAR files

[Mike Gran]

> 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