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

/ WebHome / Cookbook.ProcessUntarScriptExample

This Web


WebHome 
WebChanges 
TOC (with recipes)
NewRecipe 
WebTopicList 
WebStatistics 

Other Webs


Chicken
Cookbook
Erlang
Know
Main
Plugins
Sandbox
Scm
TWiki  

Schematics


Schematics Home
Sourceforge Page
SchemeWiki.org
Original Cookbook
RSS

Scheme Links


Schemers.org
Scheme FAQ
R5RS
SRFIs
Scheme Cross Reference
PLT Scheme SISC
Scheme48 SCM
MIT Scheme scsh
JScheme Kawa
Chicken Guile
Bigloo Tiny
Gambit LispMe
GaucheChez

Lambda the Ultimate
TWiki.org

Scripting Example: Untar

Problem

You want to use Scheme to do something that you would normally do using a shell script.

Solution

PLT Scheme has a great deal of support for scripting-style functionality. To demonstrate some of these features, the following program was converted from this bash script. See the header comment for an explanation of this script.

#!/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)"))))

The above program relies on some general routines which provide additional support for a few basic scripting-style operations, some of which have been very loosely modeled on features found in scsh. For the above script to run correctly, /usr/bin/scheme-sh should be a link to the mzscheme binary, and the following program should be saved as init.ss in a directory called plt/collects/script-lang/sh. (This triggers MzScheme's built-in script engine support.)

(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)))))

Discussion

TODO.


Comments about this recipe

Needs more explanation.

Contributors

-- AntonVanStraaten - 10 Feb 2006

CookbookForm
TopicType: Recipe
ParentTopic: ProcessRecipes
TopicOrder: 999

 
 
Copyright © 2004 by the contributing authors. All material on the Schematics Cookbook web site is the property of the contributing authors.
The copyright for certain compilations of material taken from this website is held by the SchematicsEditorsGroup - see ContributorAgreement & LGPL.
Other than such compilations, this material can be redistributed and/or modified under the terms of the GNU Lesser General Public License (LGPL), version 2.1, as published by the Free Software Foundation.
Ideas, requests, problems regarding Schematics Cookbook? Send feedback.
/ You are Main.guest