// CopyDiskUtilB.bcpl
// Copyright Xerox Corporation 1979, 1980, 1981
// Last modified December 12, 1981  5:52 PM by Boggs

get "Streams.d"
get "AltoDefs.d"
get "CopyDisk.decl"

external
[
// outgoing procedures
InitCopyDiskUtil
MakeSS; DeclareDevice
PrintDiskParams; DeclareDiskParams
DoIt; GetBuffer; ReleaseBuffer
GetNumber; GetString; Confirm
Wss; Ding; FatalError; DataCompare

// incoming procedures from other parts of CopyDisk
MakeNetSS

// incoming procedures from OS and packages
Allocate; Free; DefaultArgs; Block; InitializeContext
SetTimer; TimerHasExpired; Dismiss
MoveBlock; Zero; Usc; BlockEq; ReadCalendar
Enqueue; Dequeue; Unqueue; DoubleDifference
CreateKeywordTable; InsertKeyword; LookupKeyword
SetBitPos; CharWidth; EraseBits
PutTemplate; Resets; Gets; Puts
ExtractSubstring; CopyString

// outgoing statics
driveLock; compareErrors; seriousErrors

// incoming statics
show; noShow; keys; dsp
ctxQ; sysZone; CtxRunning; debugFlag
]

static
[
driveLock; compareErrors; seriousErrors
deviceKT; pdpQ
]

structure String [ length byte; char↑1,1 byte ]

structure PDP:
[
link word
diskType word
printProc word
]
manifest lenPDP = size PDP/16

//----------------------------------------------------------------------------
let InitCopyDiskUtil() be
//----------------------------------------------------------------------------
[
deviceKT = CreateKeywordTable(30, 1)
pdpQ = Allocate(sysZone, 2); pdpQ!0 = 0
]

//----------------------------------------------------------------------------
and DeclareDevice(name, proc) be InsertKeyword(deviceKT, name)!0 = proc
//----------------------------------------------------------------------------

//----------------------------------------------------------------------------
and MakeSS(name, write) = valof
//----------------------------------------------------------------------------
// returns an SS or 0
[
Puts(dsp, $*S)
test name>>String.char↑1 eq $[
   ifso resultis MakeNetSS(name, write)
   ifnot
      [
      let device = nil
      let kte = LookupKeyword(deviceKT, name, lv device)
      test kte eq 0
         ifso [ Wss(dsp, "- No such disk"); resultis false ]
         ifnot resultis (kte!0)(device, write)
      ]
]

//----------------------------------------------------------------------------
and DeclareDiskParams(diskType, printProc) be
//----------------------------------------------------------------------------
[
let pdp = Allocate(sysZone, lenPDP)
pdp>>PDP.diskType = diskType
pdp>>PDP.printProc = printProc
Enqueue(pdpQ, pdp)
]

//----------------------------------------------------------------------------
and PrintDiskParams(cd) be
//----------------------------------------------------------------------------
[
let pdp = pdpQ!0
while pdp ne 0 do
   [
   if cd>>CD.diskParams.diskType eq pdp>>PDP.diskType then
      (pdp>>PDP.printProc)(cd)
   pdp = pdp>>PDP.link
   ]
]

//----------------------------------------------------------------------------
and DoIt(src, snk, write, tp) = valof
//----------------------------------------------------------------------------
[
if src eq 0 % snk eq 0 resultis false
manifest lenRWCtx = 400

let freeQ = vec 1; freeQ!0 = 0
let srcCtx = Allocate(sysZone, lenRWCtx)
Enqueue(ctxQ, InitializeContext(srcCtx, lenRWCtx, src>>SS.read, 1))
srcCtx>>CDCtx.ss = src
src>>SS.inputQ = freeQ
let srcTempQ = vec 1; srcTempQ!0 = 0
src>>SS.tempQ = srcTempQ
let srcOutputQ = vec 1; srcOutputQ!0 = 0
src>>SS.outputQ = srcOutputQ
src>>SS.otherSS = snk
src>>SS.tp = tp
src>>SS.fatalFlag = false
src>>SS.doneFlag = false

let snkCtx = Allocate(sysZone, lenRWCtx)
Enqueue(ctxQ, InitializeContext(snkCtx, lenRWCtx,
 (write? snk>>SS.write, snk>>SS.read), 1))
snkCtx>>CDCtx.ss = snk
snk>>SS.inputQ = write? srcOutputQ, freeQ
let snkTempQ = vec 1; snkTempQ!0 = 0
snk>>SS.tempQ = snkTempQ
let snkOutputQ = vec 1; snkOutputQ!0 = 0
snk>>SS.outputQ = write? freeQ, snkOutputQ
snk>>SS.otherSS = src
snk>>SS.tp = tp
snk>>SS.fatalFlag = false
snk>>SS.doneFlag = false

let lenBuffer = src>>SS.lenBuffer ne 0? src>>SS.lenBuffer, snk>>SS.lenBuffer
let numBuffers = 0
let freeSlop = Allocate(sysZone, 1000)
   [
   let buffer = Allocate(sysZone, lenBuffer, true)
   if buffer eq 0 break
   Enqueue(freeQ, buffer)
   numBuffers = numBuffers +1
   ] repeat
Free(sysZone, freeSlop)
unless write do numBuffers = numBuffers rshift 1
src>>SS.numBuffers, src>>SS.maxBuffers = numBuffers, numBuffers
snk>>SS.numBuffers, snk>>SS.maxBuffers = numBuffers, numBuffers

// DoIt (cont'd)

driveLock = false
compareErrors = 0
let timer = nil; SetTimer(lv timer, 0)
let startTime = vec 2; ReadCalendar(startTime)
   [
   Block()
   if TimerHasExpired(lv timer) then
      [ UpdateDAs(src, snk); SetTimer(lv timer, 20) ]
   let compareDone = write? true, Compare(src, snk)
   if (src>>SS.doneFlag & snk>>SS.doneFlag & compareDone) %
    src>>SS.fatalFlag % snk>>SS.fatalFlag break
   ] repeat
UpdateDAs(0, 0)

if debugFlag then
   [
   PutTemplate(dsp, "*N$D buffers", numBuffers)
   let endTime = vec 2; ReadCalendar(endTime)
   let seconds = DoubleDifference(endTime, startTime)
   PutTemplate(dsp, "*N$D:$2F0D seconds", seconds/60, seconds rem 60)
   ]

Unqueue(ctxQ, srcCtx); Free(sysZone, srcCtx)
Unqueue(ctxQ, snkCtx); Free(sysZone, snkCtx)
src>>SS.otherSS, snk>>SS.otherSS = 0, 0

DestroyQueue(freeQ)
DestroyQueue(srcTempQ)
DestroyQueue(srcOutputQ)
DestroyQueue(snkTempQ)
DestroyQueue(snkOutputQ)

seriousErrors = src>>SS.fatalFlag % snk>>SS.fatalFlag
(src>>SS.printBlock)(src, src>>SS.errors)
(snk>>SS.printBlock)(snk, snk>>SS.errors)
resultis not seriousErrors
]

//----------------------------------------------------------------------------
and FatalError(string, a0, a1, a2, a3, a4; numargs na) be
//----------------------------------------------------------------------------
[
if na gr 0 & string ne 0 then 
   PutTemplate(dsp, string, a0, a1, a2, a3, a4)
CtxRunning>>CDCtx.ss>>SS.fatalFlag = true
driveLock = false
Block() repeat
]

//----------------------------------------------------------------------------
and Compare(src, snk) = valof
//----------------------------------------------------------------------------
[
if (src>>SS.outputQ)!0 eq 0 resultis (snk>>SS.outputQ)!0 eq 0
if (snk>>SS.outputQ)!0 eq 0 resultis false
let buf1 = Dequeue(snk>>SS.outputQ)
let buf2 = Dequeue(src>>SS.outputQ)
unless (src>>SS.compare)(src, buf1, buf2) do
   compareErrors = compareErrors +1
ReleaseBuffer(buf1)
ReleaseBuffer(buf2)
resultis false
]

//----------------------------------------------------------------------------
and DataCompare(buf1, buf2, length) be
//----------------------------------------------------------------------------
[
let errors = 0
for i = 0 to length-1 if buf1!i ne buf2!i then
   [
   PutTemplate(dsp, "*N$U6O/$U6O   $U6O/$U6O", buf1+i, buf1!i, buf2+i, buf2!i)
   errors = errors +1
   if errors gr 4 break
   ]
]

//----------------------------------------------------------------------------
and UpdateDAs(src, snk) be
//----------------------------------------------------------------------------
[
if @displayListHead eq 0 return

Resets(noShow)
if src ne 0 & snk ne 0 then
   [
   let ss = snk>>SS.type eq ssDisk? snk, src
   (ss>>SS.printDA)(noShow, ss)
   ]

let dcb = @displayListHead; if dcb ne 0 then
   [
   while dcb>>DCB.next ne show>>DS.cdcb do dcb = dcb>>DCB.next
   noShow>>DS.cdcb>>DCB.next = show>>DS.cdcb>>DCB.next
   dcb>>DCB.next = noShow>>DS.cdcb
   let temp = noShow; noShow = show; show = temp
   ]
]

//----------------------------------------------------------------------------
and DestroyQueue(Q) be
//----------------------------------------------------------------------------
   while Q!0 ne 0 do Free(sysZone, Dequeue(Q))

//----------------------------------------------------------------------------
and GetBuffer(returnOnFail; numargs na) = valof
//----------------------------------------------------------------------------
[
let ss = CtxRunning>>CDCtx.ss
let buffer = nil
   [
   if ss>>SS.numBuffers gr 0 then
      [
      buffer = Dequeue(ss>>SS.inputQ)
      if buffer ne 0 break
      ]
   if na gr 0 & returnOnFail resultis false
   Block()
   ] repeat
buffer>>Buffer.ss = ss
ss>>SS.numBuffers = ss>>SS.numBuffers -1
resultis buffer
]

//----------------------------------------------------------------------------
and ReleaseBuffer(buffer) be
//----------------------------------------------------------------------------
[
let ss = buffer>>Buffer.ss
ss>>SS.numBuffers = ss>>SS.numBuffers +1
Enqueue(ss>>SS.inputQ, buffer)
]

//----------------------------------------------------------------------------
and Wss(stream, string) be
//----------------------------------------------------------------------------
   for i = 1 to string>>String.length do
      Puts(stream, string>>String.char↑i)

//----------------------------------------------------------------------------
and Ding(stream) be
//----------------------------------------------------------------------------
[
let dcb = stream>>DS.fdcb
   [
   dcb>>DCB.background = not dcb>>DCB.background
   dcb = dcb>>DCB.next
   if dcb eq stream>>DS.ldcb break
   ] repeat
Dismiss(10)
let dcb = stream>>DS.fdcb
   [
   dcb>>DCB.background = not dcb>>DCB.background
   dcb = dcb>>DCB.next
   if dcb eq stream>>DS.ldcb break
   ] repeat
]

//----------------------------------------------------------------------------
and GetString(prompt, def, mode, question; numargs na) = valof
//----------------------------------------------------------------------------
[
DefaultArgs(lv na, 0, 0, 0, editEcho+editReplace, 0)
let echo = (mode & editEcho) ne 0
let replace = (mode & editReplace) ne 0
if prompt then Wss(dsp, prompt)
let string, count = vec 128, 0
if def then
   [
   count = def>>String.length
   CopyString(string, def)
   if echo & replace then Wss(dsp, def)
   Free(sysZone, def)
   ]

   [
   let char = Gets(keys)
   switchon char into
      [
      case $*001: case $*010:
         [
         replace = false
         if count ne 0 then
            [
            if echo ne 0 then
               EraseBits(dsp, -CharWidth(dsp, string>>String.char↑count))
            count = count -1
            ]
         endcase
         ]
      case $*S: case $*N: case $*033: break
      case $?:
         [
         if count eq 0 & question ne 0 then
            [ question(); if prompt then Wss(dsp, prompt) ]
         endcase
         ]
      case $*177:
         [ Wss(dsp, " XXX"); resultis 0 ]
      default:
         [
         if char eq $*027 % replace then
            [
            if echo then for i = count to 1 by -1 do
               EraseBits(dsp, -CharWidth(dsp, string>>String.char↑i))
            count, replace = 0, false
            ]
         if char ge $*S & char le $*177 then
            [
            count = count +1
            string>>String.char↑count = char
            if echo then Puts(dsp, char)
            ]
         endcase
         ]
      ]
   ] repeat

if count eq 0 resultis 0
string>>String.length = count
resultis ExtractSubstring(string)
]

//----------------------------------------------------------------------------
and GetNumber(prompt, def; numargs na) = valof
//----------------------------------------------------------------------------
[
DefaultArgs(lv na, 0, 0, 0)
if prompt then Wss(dsp, prompt)
if na gr 1 then PutTemplate(dsp, "$UO", def)
let number = def
let digitTyped = na gr 1
   [
   let char = Gets(keys)
   switchon char into
      [
      case $*N: case $*S: case $*033:
         [ if digitTyped resultis number; endcase ]
      case $*177:
         [ Wss(dsp, " XXX"); resultis 0 ]
      case $0 to $7:
         [
         if na gr 1 then
            [
            na = 0
            while number ne 0 do
               [
               EraseBits(dsp, -CharWidth(dsp, (number&7)+$0))
               number = number rshift 3
               ]
            ]
         number = number lshift 3 + char-$0
         Puts(dsp, char)
         digitTyped = true
         endcase
         ]
      case $*001: case $*010:
         [
         na = 0
         if number ne 0 then
            EraseBits(dsp, -CharWidth(dsp, (number&7)+$0))
         number = number lshift 3
         endcase
         ]
      ]
   ] repeat
]

//----------------------------------------------------------------------------
and Confirm(prompt; numargs na) = valof
//----------------------------------------------------------------------------
[
PutTemplate(dsp, "$S [Confirm] ", (na? prompt, ""))
switchon Gets(keys) into
   [
   case $Y: case $y: case $*N:
      [ Wss(dsp, "Yes"); resultis true ]
   case $N: case $n: case $*177:
      [ Wss(dsp, "No"); resultis false ]
   case $?:
      [ Wss(dsp, "Y, y, <cr>, or N, n, <del>"); loop ]
   default:
      [ Ding(dsp); endcase ]
   ] repeat
]