s c h e m a t i c s : c o o k b o o k

#!/usr/bin/scheme-sh

; Unpack a tarfile and make sure that it ends up in a single directory
; with a name derived from the tarball (create this if necessary).
; Example: "untar foo-1.0.tar.gz" will always put the files in foo-1.0/
; Written by Luke Gorrie <luke at synap dot  se> in February 2006.
;
; Obfuscated by Todd Coram <todd at maplefish dot com> on February 7, 2006.
;    Todd also added support for plain old .tar!
;
; "Transliterated" ;) from bash to Scheme
; by Anton van Straaten <anton at appsolutions.com> on February 9, 2006.

(define (main args)
  (match args
    ((list _ file)
     (match-let* ((basefile (file-name-from-path file))
                  ; we will make sure everything goes into the 'wantdir' directory
                  ((list wantdir ext) (split-filename basefile)))

       ; argument validation
       (or (file-exists? file) (die "abort: file does not exist"))
       (if (-d wantdir) (die "abort: ~a already exists" wantdir))

       ; detect compression scheme
       (let ((compression
              (case (string->symbol ext)
                ((tar)        "")
                ((tar.gz tgz) "z")
                ((tar.bz2)    "j")
                (else (die "Unrecognized file format"))))
             (tmpdir (or (make-temporary-dir "untar.~a")
                         (die "Can't mkdir ~a" tmpdir))))
         ;
         ; Extract & move & cleanup
         ;
         (try-pk (exn:break?
                  (if (-d tmpdir)
                      (run (rm -rf ,tmpdir))))
           (|| (tar ,($ 'Cxf compression) ,tmpdir ,file)
               ((rm -rf ,tmpdir) (exit 1)))
           (cond
             ((equal? (run (ls -1 ,tmpdir)) (list wantdir))
              ; The archive unpacked the way we want
              (&& (mv ,($ tmpdir '/ wantdir) ".") (rmdir ,tmpdir)))
             (else 
               ; "Messy" unpack. Put it under the desired directory.
               (printf "untar: creating ~a\n" wantdir)
               (run (mv ,tmpdir ,wantdir))))))))
    (else (die "Usage: untar filename(.tar|.tar.gz|.tgz|.tar.bz2)"))))

(module init mzscheme
  (require (lib "file.ss")
           (lib "process.ss")
           (lib "plt-match.ss")
           (lib "list.ss" "srfi" "1"))

  (provide (all-from (lib "file.ss"))
           (all-from (lib "process.ss"))
           (all-from (lib "plt-match.ss"))
           (all-from (lib "list.ss" "srfi" "1"))
           run && || $ -d die
           make-temporary-dir split-filename
           intersperse
           try-pk)

  ; run one or more shell commands, specified as s-exps.
  ; Returns the output of the last command as a list of lines.
  (define-syntax run
    (syntax-rules ()
      ((_ cmd ...)
       (begin (exec-cmd `cmd #t) ...))))

  ; run a sequence of shell commands, specified as s-exps,
  ; returning if any of the commands returns a non-zero error code.
  (define-syntax &&
    (syntax-rules ()
      ((_ cmd ...)
       (and (zero? (exec-cmd `cmd #f)) ...))))

  ; run a sequence of shell commands, specified as s-exps,
  ; stopping once a command returns a success code (zero)
  (define-syntax ||
    (syntax-rules ()
      ((_ cmd ...)
       (or (zero? (exec-cmd `cmd #f)) ...))))

  ; appends a list of arbitrary arguments into a string
  (define ($ . args)
    (apply string-append
     (map
      (lambda (s)
        (cond
          ((symbol?  s) (symbol->string s))
          ((string?  s) s)
          ((number?  s) (number->string s))
          ((boolean? s) (if s "true" "false"))
          ((path?    s) (path->string s))
          (else "ERROR!")))
      args)))

  (define (exec-cmd cmd capture-output?)
    (if (and (pair? cmd)
             (pair? (car cmd)))
        (for-each exec-cmd cmd)
        (let ((cmd-str (process-cmd cmd)))
          ;(debug-out cmd-str)
          (if capture-output?
              (system/output cmd-str)
              (system/exit-code cmd-str)))))

  (define (intersperse l delim)
    (reverse (reverse-intersperse l delim)))

  ; intersperses delim into list l, and returns in reverse order
  (define (reverse-intersperse l delim)
    (if (null? l) l
        (fold
         (lambda (x l)
           (cons x (cons " " l)))
         (list (car l))
         (cdr l))))

  ; bit of a cheat: using make-temporary-file to make a temporary dir
  (define (make-temporary-dir template)
    (try-pk (exn:fail:filesystem? #f)
      (let ((path (make-temporary-file template)))
        (delete-file path)
        (make-directory path)
        path)))

  ; keep those crazy bashers from complaining about verbosity
  (define -d directory-exists?)

  (define split-filename
    (let ((rx #rx"(.+?)\\.(.*)"))
      (lambda (filename)
        (let* ((filename (if (path? filename) (path->string filename) filename))
               (pieces (regexp-match rx filename)))
          (and pieces (cdr pieces))))))

  (define (quote-string s)
    (string-append "\"" s "\""))

  (define (process-cmd cmd)
    (fold string-append ""
     (reverse-intersperse
      (map
       (lambda (s)
         (cond
           ((symbol?  s) (symbol->string s))
           ((string?  s) (quote-string s))
           ((number?  s) (number->string s))
           ((boolean? s) (if s "true" "false"))
           ((path?    s) (path->string s))
           (else "ERROR!")))
       cmd)
      " ")))

  (define (die s . vals) 
    (apply fprintf (current-error-port) s vals) (newline)
    (exit 1))

  ; "try" with a single predicate and a "naked" handler (not a closure)
  (define-syntax try-pk
    (syntax-rules ()
      ((_ (pred handler ...) body ...)
       (with-handlers ((pred (lambda (exn) handler ...)))
         body ...))))

  ; from http://schemecookbook.org/Cookbook/FileReadingLines
  (define (fold-lines proc init . port+mode)
    (let while ((accum init))
      (let ((line (apply read-line port+mode)))
        (if (eof-object? line) accum
            (while (proc line accum))))))

  (define (read-all-lines port)
    (reverse (fold-lines cons '() port)))

  ;; from http://schemecookbook.org/Cookbook/ProcessCaptureOutput

  ;; system/output : string -> (U string #f)
  ;;
  ;; Synchronously run the given command through the shell and
  ;; capture standard output.
  ;;
  ;; Returns the standard output or #f if the command failed
  ;;
  ;; If the command blocks for any reason (e.g. waiting for
  ;; input) this function will as well.
  (define (system/output command-string)
    (let-values (((out in id err ctrl)
                  (apply values (process command-string))))
      (ctrl 'wait)  ;; wait for the process to finish
      (begin0
        (case (ctrl 'status)
          ((done-ok)
           (read-all-lines out))
          (else #f))
        (close-output-port in)
        (close-input-port out)
        (close-input-port err)))))