#!/bin/sh
: ; exec klone $0 "$@"
; The above line finds the klone executable in the $PATH
;;Skeleton of a typical klone script
;;(stack-dump-on-error t)
;;(kdb t)
(setq args (getopts (setq usage "floppies: splits data onto multiple floppy disks, verifying the data
The user is prompted to insert disks, which are automatically detected
USAGE:
to create floppies:
tar cfvz - files/dirs... | floppies [options] w
splits data on N floppies, verifying data when writing
to read floppies (default):
floppies [options] r | tar xfvz -
re-combines floppies
x is a synonym of r and c of w
floppies is VERY safe and convenient:
- a popup is displayed to prompt for new disks (via Tk's wish command)
- disks insertion is automatically detected
- every written disk is re-read and compared to original data
- if a problem appears on a disk, read is re-tried indefinitely
- disks are labelled with order number, starting at 0
NOTE: to archive huge archives, make floppies use a file as input, not a pipe,
as in floppies < foo.tgz, or use the -disk, or better -pipe if your linux
doesnt deadlock with -pipe.
")
("-t" () text-only "text-only, do not use Tk dialogs")
("-w" () do-write "write floppies")
("-c" () do-write "write floppies")
("-v" () verbose "verbose operation")
("-s" size flopsize "floppy size (in K), defaults to 1440")
("-d" device (device "/dev/fd0") "device used, default /dev/fd0")
("-f" file in-file "floppies -f file is equivalent to: floppies w < file")
("-skip" N skip-disks "for writing, skip first N disks")
("-p" seconds (pause-disks 1) "pause N seconds between looking for disk")
("-delay" ms delay "delay N milliseconds between write/read chunks")
("-disk" () use-disk "store temp disk images in /tmp instead of memory")
("-pipe" () nomem "dont read all in memory before writing, which is
necessary to avoid a bug in most linuxes")
("-debug" () fulldebug "very verbose operation")
("-nover" () noverify "do not verify written disks")
("-F" () F "use 82 tracks, 23 sectors = 1886k floppies")
("-M" () M "use 82 tracks, 24 sectors = 1968k floppies")
; ("-X" () X "use XDF format: FAST 80 t, 23 s = 1840k floppies")
("-FF" () FF "formats a 82 tracks, 23 sectors = 1886k floppy")
("-MM" () MM "formats a 82 tracks, 24 sectors = 1966k floppy")
; ("-XX" () XX "formats a XDF 80 tracks, 23 sectors = 1840k floppy")
))
(defun parse-options ()
(defvar XX ()) (defvar X ())
(if (not args) (setq args (if do-write '("w") '("r"))))
(if (or FF MM XX) (progn
(format-floppy (if XX 80 82) (if MM 24 23))
(exit 0)))
(if (and (or (= '("w") args) (= '("c") args))
(not in-file) (/= 0 (getn (file-stats *standard-input*) 'dev)))
(setq in-file *standard-input*)
)
(when (and (/= args '("c")) (/= args '("x")) (/= args '("r"))(/= args '("w"))
(not in-file)
)
(sh floppies "-?")
(exit 1)
)
(if F (setq flopsize (* 23 82))
M (setq flopsize (* 24 82))
X (setq flopsize (* 23 80))
)
(if flopsize
(setq *floppy-size* (* 1024 (Int flopsize)))
(setq *floppy-size* 1474560)
)
(setq pause-disks (Int pause-disks))
(if (<= pause-disks 0) (setq pause-disks 1))
;; header on floppy is 13 bytes:
;; FLOPPY# (7 bytes)
;; a byte giving the serial of the volume (ascii code, one byte)
;; is this last disk? (byte to 1 if true)
;; the length of stored data, in 4 bytes BE
;; NOTE: file-position works on floppies
;; non-existent floppy is detected at open or first read (depend on
;; drives, apparently)
(setq *magic-string* "FLOPPY#")
(setq *header-length* 13)
(setq *buffer-size* (- *floppy-size* *header-length*))
(setq *num* 0)
(setq *track-size* 18432)
(setq *extract-chunks* (* 4 18432))
(when (and (or (= args '("w"))(= args '("c"))) (not in-file))
(if (file-position *standard-input* 1)
(setq in-file *standard-input*)
)
(file-position *standard-input* 0)
)
(if in-file (setq args '("w")))
(if fulldebug (trace-all t))
(if use-disk
(trap-signal 2 "rm /tmp/floppies*" 0)
)
;; read fd by small incs (36864 bytes), 2 tracks
(if delay (setq read-chunks:delay (Int delay)))
(if (or (not delay) (< read-chunks:delay 0))
(setq read-chunks:delay 0)
)
(defvar read-chunks:size 36864)
(defvar read-chunks:retries 0)
) ;end of option parsing
(defun main ()
(parse-options)
(if
in-file
(setq create-floppies create-floppies-in-file)
nomem
(setq create-floppies create-floppies-nomem)
t
(setq create-floppies create-floppies-default)
)
(if (or (= args '("c")) (= args '("w")))
(create-floppies) ; c w
(extract-floppies) ; x r
)
(xmessage (PF String "%0 floppies done.\nremove last floppy." (+ 1 *num*)))
(unless text-only
(while (disk-present? device) (sleep 1))
)
(xmessage :remove)
(kltk:send "exit")
(kltk:flush)
)
(defun make-header (num len &key last &aux
(text (PF String "FLOPPY#"))
)
(put text -1 num)
(put text -1 (if last 1 0))
(put text -1 (logand 255 (logshift len -24)))
(put text -1 (logand 255 (logshift len -16)))
(put text -1 (logand 255 (logshift len -8)))
(put text -1 (logand 255 len))
text
)
(defun decode-header (header)
(+
(logshift (get header (+ 2 (length *magic-string*))) 24)
(logshift (get header (+ 3 (length *magic-string*))) 16)
(logshift (get header (+ 4 (length *magic-string*))) 8)
(logshift (get header (+ 5 (length *magic-string*))) 0)
))
(defun verbose? (&rest args &aux nonewline)
(if verbose (progn
(if (= :n (getn args 0)) (progn
(setq nonewline t)
(setq args (subseq args 1))
))
(apply print-format (+ (list *standard-error*) args))
(if (not nonewline) (print-format *standard-error* "\n"))
(flush *standard-error*)
)))
;; reads one floppy less header and one more byte,
;; prompts for disk, writes, re-reads and compares
(defun create-floppies-in-file (&aux
buffer
next-buffer
bufferv
buflen
prompt-mess
(num 0)
maxnum
fd
fdin
size
n
stime
pos
)
(if (typep in-file Stream)
(setq fdin in-file)
(setq fdin (open in-file))
)
(setq size (get (file-stats in-file) 'size))
(setq num (+ 1 (/ size *buffer-size*)))
(if (= 0 (mod size *buffer-size*)) (incf num -1))
(verbose? "You will need %0 disk%1. prepare for writing" num
(if (> num 1) "s" "")
)
(setq maxnum num)
(setq num 0)
(if skip-disks (setq num (Int skip-disks)))
(while (< num maxnum) ;now write them
(setq pos (* num *buffer-size*))
(file-position fdin pos)
(setq buflen (min *buffer-size* (- size pos)))
(setq buffer (+
(make-header num buflen :last (= num (- maxnum 1)))
(read-chars buflen fdin))
)
(setq buflen (length buffer))
(sh sync)
(while (catch 'RETRY ;
(prompt-for-new-disk :num num :message prompt-mess
:last (= num (- maxnum 1)) :maxnum maxnum
)
(setq stime (get-current-time))
(setq prompt-mess ())
(adjust-fdprm)
(setq fd (open device :direction :io :error ()))
(unless fd
(setq prompt-mess "*** DISK WRITE PROTECTED ***")
(throw 'RETRY t)
)
(verbose? "writing %0k on disk %1 ..." (/ buflen 1024) num)
;write
(setq n (write-chunks buffer buflen fd))
(close fd)
(when (/= buflen n)
(setq prompt-mess (PF String
"retrying: could write only %0 bytes instead of %1"
n buflen)
)
(throw 'RETRY t)
)
;verify
(unless noverify
(sh sync)
(adjust-fdprm)
(setq fd (open device))
(verbose? "verifying...")
(catch 'EOF (setq bufferv (read-chunks buflen fd)))
(close fd)
(when (/= bufferv buffer)
(setq prompt-mess "*** VERIFY ERROR ***")
(throw 'RETRY t)
)
)
(verbose? "%0 seconds for this disk = %1 k/s"
(seconds-since stime)
(/ (/ buflen seconds-since:last) 1024))
))
(incf num)
(setqn buffer () bufferv ())
;; (if verbose (meminfo :all t))
)
(setq *num* (- num 1))
)
(defun create-floppies-nomem (&aux
buffer
next-buffer
bufferv
buflen
prompt-mess
(num 0)
fd
n
)
(if skip-disks (progn
(setq skip-disks (Int skip-disks))
(dotimes (i skip-disks)
(catch 'EOF (setq next-buffer (read-chars *buffer-size*)))
(incf num)
)))
(catch 'EOF (setq next-buffer (read-chars *buffer-size*)))
(catch 'DONE
(while next-buffer
(setq buffer next-buffer)
(setq next-buffer ())
(catch 'EOF (setq next-buffer (read-chars *buffer-size*)))
(setq buflen (length buffer))
(insert buffer 0 (make-header num buflen :last (not next-buffer)))
(setq buflen (length buffer))
(while (catch 'RETRY
(prompt-for-new-disk :num num :message prompt-mess
:last (not next-buffer))
(setq prompt-mess ())
(adjust-fdprm)
(setq fd (open device :direction :io :error ()))
(unless fd
(setq prompt-mess "*** DISK WRITE PROTECTED ***")
(throw 'RETRY t)
)
(verbose? "writing %0k on disk %1 ..." (/ buflen 1024) num)
(setq n (write-chars buffer buflen fd))
(close fd)
(when (/= buflen n)
(setq prompt-mess (PF String
"retrying: could write only %0 bytes instead of %1" n buflen)
)
(throw 'RETRY t)
)
;verify
(adjust-fdprm)
(setq fd (open device))
(verbose? "verifying...")
(catch 'EOF (setq bufferv (read-chars buflen fd)))
(close fd)
(when (/= bufferv buffer)
(setq prompt-mess "*** VERIFY ERROR ***")
(throw 'RETRY t)
)))
(incf num)
)
)
(setq *num* (- num 1))
)
(defun create-floppies-default (&aux ;default
buffer
next-buffer
bufferv
buflen
prompt-mess
(num 0)
maxnum
fd
n
stime
)
(unwind-protect (progn
(buffers:init)
(catch 'EOF (setq next-buffer (read-chars *buffer-size*)))
(catch 'DONE
(while next-buffer ;create N disk images as buffers
(setq buffer next-buffer)
(setq next-buffer ())
(catch 'EOF (setq next-buffer (read-chars *buffer-size*)))
(setq buflen (length buffer))
(insert buffer 0 (make-header num buflen :last (not next-buffer)))
(setq buflen (length buffer))
(verbose? "disk %0 ready in memory (%1 bytes)" num buflen)
(buffers:put num buffer)
(incf num)
)
(verbose? "all %0 disks made. prepare for writing" num)
(sh /bin/sync)
(setq maxnum num)
(setq num 0)
(while (< num maxnum) ;now write them
(flush-gc (progn
(setq buffer (buffers:get num))
(setq buflen (length buffer))
(while (catch 'RETRY ;
(prompt-for-new-disk :num num :message prompt-mess
:last (= num (- maxnum 1)) :maxnum maxnum
)
(setq stime (get-current-time))
(setq prompt-mess ())
(adjust-fdprm)
(setq fd (open device :direction :io :error ()))
(unless fd
(setq prompt-mess "*** DISK WRITE PROTECTED ***")
(throw 'RETRY t)
)
(verbose? "writing %0k on disk %1 ..." (/ buflen 1024) num)
;write
(setq n (write-chunks buffer buflen fd))
(close fd)
(when (/= buflen n)
(setq prompt-mess (PF String
"retrying: could write only %0 bytes instead of %1"
n buflen)
)
(throw 'RETRY t)
)
;verify
(adjust-fdprm)
(setq fd (open device))
(verbose? "verifying...")
(catch 'EOF (setq bufferv (read-chunks buflen fd)))
(close fd)
(when (/= bufferv buffer)
(setq prompt-mess "*** VERIFY ERROR ***")
(throw 'RETRY t)
)
(verbose? "%0 seconds for this disk = %1 k/s"
(seconds-since stime)
(/ (/ buflen seconds-since:last) 1024))
))
(incf num)
)))
))
(buffers:end)
(setq *num* (- num 1))
))
;;=============================================================================
;; image disk storage package
;;=============================================================================
(if use-disk (progn ;use /tmp
(defun buffers:init ()
(setq buffers:name "/tmp/floppies-buffer.")
)
(defun buffers:end ()
(sh rm -f ,(+ buffers:name "*"))
)
(defun buffers:get (num)
(String (open (+ buffers:name (String num))))
)
(defun buffers:put (num buffer &aux fd)
(setq fd (open (+ buffers:name (String num))
:direction :output :if-exists :supersede
))
(write-string buffer fd)
(close fd)
)
)
(progn ;stores them in memory in buffers:buffers
(defun buffers:init ()
(setq buffers:buffers (vector))
)
(defun buffers:end ()
(setq buffers:buffers (vector))
)
(defun buffers:get (num)
(get buffers:buffers num)
)
(defun buffers:put (num buffer)
(put buffers:buffers num buffer)
)
))
(defun read-chunks (size fd &aux
(rest size)
(toread size)
(l (list (read-chars (min toread read-chunks:size) fd)))
buf
res
)
(incf toread (- (length (get l -1))))
(catch 'EOF
(while (/= 0 toread)
(verbose? :n "-")
(lappend l (setq buf (read-chars (min toread read-chunks:size) fd)))
(if (= "" buf) ;read error
(throw 'EOF ())
)
(incf toread (- (length (get l -1))))
(select () :timeout read-chunks:delay)
))
(verbose? "")
(setq res (apply + l))
(setq l ())
res
)
(defun write-chunks (buffer size fd &aux
wrote
(offset 0)
)
(catch 'DONE
(while (/= offset size)
(verbose? :n "=")
(setq wrote (write-chars (substring-ptr buffer offset
(min (+ offset read-chunks:size) size)
)
(min read-chunks:size (- size offset))
fd
))
(wait (system '("sync")))
(if (/= wrote (min read-chunks:size (- size offset)))
(throw 'DONE (+ offset wrote))
)
(incf offset wrote)
(select () :timeout read-chunks:delay)
)
(verbose? "")
size
)
)
;;reads floppies.
(defun extract-floppies (&aux
buffer
buflen
prompt-mess
(num 0)
fd
header
last
position-on-disk
to-read
stime
)
(catch 'DONE
(while t
(while (catch 'RETRY
(prompt-for-new-disk :num num :message prompt-mess)
(setq prompt-mess ())
(adjust-fdprm)
(setq stime (get-current-time))
(setq fd (open device :error ()))
(unless fd
(setq prompt-mess "*** CANNOT READ DISK ***")
(throw 'RETRY t)
)
(setq header (read-chars *header-length* fd))
(when (/= (subseq header 0 (+ (length *magic-string*) 1))
(subseq (make-header num 0) 0 (+ (length *magic-string*) 1))
)
(close fd)
(setq prompt-mess
(if (= (subseq header 0 (length *magic-string*)) *magic-string*)
(PF String "*** Wrong disk, I want # %0, this one is # %1 ***"
num (get header (length *magic-string*))
)
"*** Wrong disk, not a floppies-created one ***"
))
(throw 'RETRY t)
)
(setq last (/= 0 (get header (+ (length *magic-string*) 1))))
(setq buflen (decode-header header))
(verbose? "reading %0k on disk %1 ..." (/ buflen 1024) num)
(setq position-on-disk 0)
(while (< position-on-disk buflen)
(if (< buflen (+ position-on-disk *extract-chunks*))
(setq to-read (- buflen position-on-disk))
(setq to-read *extract-chunks*)
)
(verbose? :n "-")
(setq buffer (read-chars to-read fd))
(when (/= to-read (length buffer))
(with (rnum 1)
(while (/= 0 to-read)
(xmessage :remove)
(xmessage (PF String "*** READ ERROR ***
at offset %0 on disk %1
retrying indefinitely...
retry # %2"
(+ *header-length* (+ position-on-disk (length buffer)))
num
rnum
))
(when (length buffer)
(incf position-on-disk (length buffer))
(write-chars buffer)
(incf to-read (- (length buffer)))
)
(if (/= 0 to-read) (progn
(setq buffer (read-chars to-read fd))
(incf rnum)
)
(progn ;OK!
(xmessage :remove)
(setq buffer "")
)
)
)
)
) ;end when
(incf position-on-disk to-read)
(write-chars buffer)
)
(verbose? "")
(verbose? "%0 seconds for this disk = %1 k/s"
(seconds-since stime)
(/ (/ buflen seconds-since:last) 1024))
))
(if last (throw 'DONE))
(incf num)
)
)
(setq *num* num)
)
(defun seconds-since (last-time)
(setq seconds-since:last (- (get-current-time) last-time))
(if (<= seconds-since:last 0)
(setq seconds-since:last 1)
)
seconds-since:last
)
(setq prompt-for-new-disk:last-num ())
(defun prompt-for-new-disk (&key num message last maxnum &aux
text
fd
)
(setq text (PF String "%0Please %3insert disk # %1%4%2"
(if message (+ message "\n\n") "") num
(if last "\n\n(last disk)" "")
(if (= num prompt-for-new-disk:last-num) "RE-" "")
(if (and (not last) maxnum) (+ " last = " (String (- maxnum 1))) "")
))
(xmessage text)
(if (not prompt-for-new-disk:last-num) (sleep 2)) ;1st time, let tk init
(while (disk-present? device) (sleep 1))
(while (not (disk-present? device)) (sleep 1))
(verbose? "disk # %0 inserted" num)
(setq prompt-for-new-disk:last-num num)
(xmessage :remove)
)
(defun disk-present? (device &aux fd res)
(adjust-fdprm)
(if (and (setq fd (open device :error ()))
(catch 'EOF (read-char fd) t)
)
(setq res t)
(setq res ())
)
(if fd (close fd))
res
)
(defun sleep (seconds)
(select () :timeout (* pause-disks (* 1000 seconds)))
)
;(unless text-only (setq kltk:wish-name "wish4.0")) ;name of interpreter
(defvar xmessage:w? ())
(defun xmessage (text &aux pid pid-in)
(if (= text :remove) ;remove previous
(unless text-only (if xmessage:w? (progn
(kltk:call "destroy .message\n")
(setq xmessage:w? ())
)))
(progn
(if text-only
(PF *standard-error* "\c07%0\n" text)
(progn
(kltk:send (+
set w .message
catch {destroy $w}
toplevel $w -class Dialog
wm withdraw .
wm withdraw $w
wm title $w floppies
wm iconname $w floppies_prompt
wm protocol $w WM_DELETE_WINDOW { }
wm transient $w [winfo toplevel [winfo parent $w]]
frame $w.top -relief raised -bd 1
pack $w.top -side top -fill both
label $w.msg -wraplength 4i -justify left -text { text } \
-font 12x24
pack $w.msg -in $w.top -side right -expand 1 -fill both \
-padx 3m -pady 3m
wm withdraw $w
update idletasks
set x [expr [winfo screenwidth $w]/2 - \
[winfo reqwidth $w]/2 - [winfo vrootx [winfo parent $w]]]
set y [expr [winfo screenheight $w]/2 - \
[winfo reqheight $w]/2 - [winfo vrooty [winfo parent $w]]]
wm geom $w +$x+$y
wm deiconify $w
))
(kltk:flush)
(PF *standard-error* "\x07")
(setq xmessage:w? t)
)
))))
;;; extended formats
(defun setfdprm (tracks sectors)
(sh setfdprm ,device ,(* 2 (* tracks sectors)) ,sectors 2 ,tracks
0 "0x1C" ,(if (= sectors 24) "0x20" "0x10") "0xCF" "0x00"
))
(defun adjust-fdprm ()
(if F (setfdprm 82 23)
M (setfdprm 82 24)
X (setfdprm 80 23)
))
(defun format-floppy (tracks sectors)
(setfdprm tracks sectors)
(if XX
(sh xdfcopy ,device)
(sh superformat "-1v2" -t ,tracks -s ,sectors ,device)
))
(main)
;;; EMACS MODES
;;; Local Variables: ***
;;; mode:lisp ***
;;; End: ***
syntax highlighted by Code2HTML, v. 0.9.1