#!/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: ***

