[Wisp-cvs] wisp/users/dig struburn.wisp,NONE,1.1

[<di...@us...>]

Update of /cvsroot/wisp/wisp/users/dig
In directory sc8-pr-cvs1:/tmp/cvs-serv12532/users/dig

Added Files:
	struburn.wisp 
Log Message:
imported struburn.wisp

--- NEW FILE: struburn.wisp ---
#! /usr/bin/wisp

;;;; struburn.wisp - an utility to burn CDs with the directory
;;                 structure intact
;;
;; Copyleft © 2002 by Andres Soolo (di...@us...)
;; This file is licensed under the GNU GPL v2.  If you
;; don't know what that means, please do read the GPL.
;;
;;;; @(#) $Id: struburn.wisp,v 1.1 2003/02/05 19:51:15 digg Exp $

(use
  files getopt lists phases qsort syscalls unix)

(define farm (construct-filename (or (env-ref "TMPDIR") "/tmp")
                                 "farm.$(sys:getpid)"))

(define (uniq =? l)
  (if (null? l)
    '()
    (collect
      (lambda (emit)
        (my previous (car l)
          (emit previous)
          (for-each (lambda (i)
                      (if (not (=? previous i))
                        (begin
                          (emit i)
                          (set! previous i))))
            (cdr l)))))))

(my (objects size-only? md5? volid dummy? speed output microsoft? help?)
  (getopt '((option ("size" #\s) flag size-only?)
            (option ("md5" #\m) flag md5?)
            (option ("volid" #\V) value volid)
            (option ("dummy" #\d) flag dummy?)
            (option ("speed" #\x) value speed)
            (option ("output" #\o) value output)
            (option ("microsoft" #\J) flag microsoft?)
            (option ("help" #\h) flag help?)
            (arg objects rest)
            (default speed "4")
            (return objects size-only? md5? volid dummy?
                    speed output microsoft? help?))
          *arglist*)
  (if (or (null? objects) help?)
    (begin
      (print "usage: struburn [options] object object ...\n\n\
              Options recognized:\n\
             \  -s, --size         just calculate image size\n\
             \  -m, --md5          create the MD5SUMS file\n\
             \  -V, --volid=text   specifies the volume ID to be used\n\
             \  -d, --dummy        write in dummy mode\n\
             \  -x, --speed=N      specifies the writing speed (default 4)\n\
             \  -o, --output=file  just create a CD image, don't burn it\n\
             \  -J, --microsoft    create a Microsoft-friendly CD\n\
             \      --help         show this help message\n\n")
      (exit)))
  (set! speed (or (string->integer speed) speed))
  (type integer speed)
  (let ((dirs '())
        (links '()))
    (sys:mkdir farm #o0700)
    (for-each (lambda (o)
                (while (string=? o[... 2] "./")
                  (set! o o[2 ...]))
                (cond
                  ((string-null? o)  (raise 'invalid-filename o))
                  ((absolute-path? o) (raise 'absolute-filename o)))
                (let ((name (basename o))
                      (dir (dirname o)))
                  (cons! links (construct-filename dir name))
                  (let (loop (dir dir))
                    (while (string=? dir[-2 ...] "/.")
                      (set! dir dir[... -2]))
                    (if (not (string=? dir "."))
                      (begin
                        (cons! dirs dir)
                        (loop (dirname dir)))))))
              objects)
    (set! links (qsort! string<? links))
    (set! dirs (uniq string=? (qsort! string<? dirs)))

    ; sanity check
    (my int (lset-intersection string=? links dirs)
      (if (not (null? int))
        (raise 'conflict int)))

    ; create the dirs
    (for-each (lambda (d)
               (sys:mkdir (construct-filename farm d) #o700))
              dirs)

    ; create the symlinks
    (my curdir (cwd)
      (for-each (lambda (link)
                  (sys:symlink (construct-filename curdir link)
                               (construct-filename farm link)))
                links))

    (if md5?
      (my files (collect
                  (lambda (emit)
                    (let (loop (dir ".") (follow? #t))
                      (for-dir-entries
                        (lambda (name inode)
                          (if (not (member name '("." "..") string=?))
                            (my qn (construct-filename dir name)
                              (case (file-type (construct-filename
                                                 farm qn) #f)
                                ((regular) (emit qn))
                                ((directory) (loop qn follow?))
                                ((symlink)
                                  (if follow?
                                    (case (file-type (construct-filename
                                                       farm qn) #t)
                                      ((regular) (emit qn))
                                      ((directory) (loop qn #f)))))))))
                        (construct-filename farm dir)))))
        (set! files (qsort string<? files))
        (my-port MD5SUMS (open-output-file (construct-filename
                                             farm "MD5SUMS")
                           'exclusive 'follow-not #o600)
          (if (or size-only? dummy?) ; checksumming is expensive
            (for-each
              (lambda (filename)
                (print MD5SUMS "$,(make-string 32 #\0)  $,[filename]\n"))
              files)
            (phase "Calculating MD5 checksums"
              (my-port pipe (pipe-from `("/usr/bin/md5sum" "--" ,@files))
                (byte-copy-port pipe MD5SUMS)))))))
    (my cmdline `("/usr/bin/mkisofs" "-r" ,@(if microsoft?
                                              '("-J")
                                              '("-U" "-D"))
                  "-F" ,farm
                  "-quiet"
                  ,@(if volid
                      `("-V" ,volid)
                      '()))
      (my tsize (my-port p (pipe-from `(,@cmdline "-print-size" ,farm))
                  (read p))
        (print "Space to be occupied: $(ceiling (/ tsize 512))MiB\n")
        (if (not size-only?)
          (if output
            (call-process `(,@cmdline "-o" ,output ,farm))
            (call-process
              (pipeline `(,@cmdline ,farm)
                        `("/usr/bin/cdrecord" "dev=0,0,0"
                          ,"speed=$[speed]" "-v"
                          ,@(if dummy? '("-dummy") '())
                          ,"tsize=$[tsize]s" "-")))))
        (call-process `("/bin/rm" "-rf" ,farm))))))

; vim: ft=wisp