// MDirs.Bcpl -- OS Dirs.Bcpl sans DeleteFile stuff
// Last edited: 27 October 1979

get "AltoFileSys.d"
get "Disks.d"
get "Streams.d"

external
[
// outgoing procedures
FindFdEntry; MakeNewFdEntry; ParseFileName; OpenFile; StripVersion

// incoming procedures
ScanDirBuffer; InitScanStream; GetScanStreamBuffer; FinishScanStream
Puts; Resets; Errors; Closes; WriteBlock; SetFilePos
CreateDiskStream; GetCompleteFa; LnPageSize; JumpToFa
SysErr; CreateDiskFile
MoveBlock; Zero; Noop; DefaultArgs; Dvec; Min

// outgoing static
dirVersions

// incoming statics
sysZone; sysDisk
]

static [ dirVersions = false ]

manifest
[
// error codes
ecDeTooBig = 1501
ecBadDeType = 1502
ecBadDirName = 1503
ecFnTooLong = 1504
ecCantOpenFile = 1505

maxExtraSpace = lSTRING
maxDeSize = lDV+maxLengthFnInWords+maxExtraSpace
maxFreeDeSize = (1 lshift size DV.length)-1

fnMask = not (#40*(#400+1)) //137,,137 in case you didn't guess...

// version control masks (see definitions of verxxx in streams.d)
verCrMask = 40000B	// if non-zero, create file ok
]

structure HD:  // Hole Descriptor
[
maxSize word
neededSize word
pos word
]
compileif size HD/16 ne 3 then [ Error("Change lHD in Streams.d") ]

structure SDB:	// ScanDirBuffer state -- must agree with DirScanA.asm
[
name word	// -> name being looked up (all upper-case)
length word	// number of words to check in name
ignoreFree word	// true to skip over free entries, false to stop on each one
scratch word 5	// scratch region used by ScanDirBuffer procedure
]
manifest lenSDB = size SDB/16

structure FSS:  // File Scan State
[
buffer word	// -> current buffer (0 => hit end-of-file)
pos word	// word position in buffer of current directory entry
endPos word	// word position of first word not in buffer
basePos word	// file word position of first word of buffer
ssd word	// -> Scan Stream Descriptor
]

//---------------------------------------------------------------------------
let FindFdEntry(dirS, name, compareFn, dv, hd, nil,
    extraSpace; numargs na) = valof
//---------------------------------------------------------------------------
// FindFdEntry returns the position, or -1 if the name is not found.
// The name is not parsed so this should have already been done.
// If dv is supplied, the dv of the name we find is returned in it.
// If hd is supplied, it is filled in with a hole descriptor for a hole big
//  enough to hold an entry for name with extraSpace extra words of space.
// If compareFn is supplied, it should return 0 if the entry should be
//  accepted.
[
let extraBuf = 1 lshift LnPageSize(dirS)
Dvec(FindFdEntry, lv extraBuf)
let d, h = vec lDV, vec lHD
DefaultArgs(lv na, -2, 0, d, h, nil, 0)

Zero(hd, lHD)
hd>>HD.neededSize = extraSpace

let lNameInWords = nil
let sdb = vec lenSDB
let capName = vec maxLengthFnInWords

if compareFn eq 0 then
   [
   // the +2 adds the length byte and rounds up
   let t = name>>STRING.length + 2
   // the -1 takes off the trailing $.
   lNameInWords = (t-1) rshift 1
   hd>>HD.neededSize = Min(t rshift 1 + lDV + extraSpace, maxDeSize)

   // Set up ScanDirBuffer state and generate capitalized version of name
   sdb>>SDB.name = capName
   sdb>>SDB.length = lNameInWords
   sdb>>SDB.ignoreFree = false
   capName!0 = name!0 & 177737B
   for i = 1 to lNameInWords-1 do capName!i = name!i & fnMask
   ]

let tempDV = vec maxDeSize
let bestPos = -1
let holeFA = vec lFA; holeFA>>FA.charPos = 0

// The following must be declared in the order defined in the FSS structure
let buffer, pos, endPos, basePos, ssd = 0, 0, 0, 0, nil
let fss = lv buffer

Resets(dirS)
ssd = InitScanStream(dirS, lv extraBuf, 1)
AdvanceBuffer(fss)

while buffer ne 0 do
   [
   // Advance the pointer to the first "interesting" directory entry.
   // The call to ScanDirBuffer accelerates the search, but if the call is
   // omitted the search still works, only more slowly.
   if compareFn eq 0 then
      pos = ScanDirBuffer(buffer+pos, buffer+endPos, sdb) - buffer

   // Now inspect the entry carefully.
   let filePos = basePos + pos
   let thisDV = buffer + pos
   let len = thisDV>>DV.length
   switchon thisDV>>DV.type into
      [
      case dvTypeFree:
         [
         // note that we never accumulate a sequence of free blocks longer
         // than neededSize+(size of biggest free block)
         if sdb>>SDB.ignoreFree then endcase  // already found hole
         if hd>>HD.pos+hd>>HD.maxSize ne filePos then
            [ // Not adjacent to previous hole; record beginning of new one
            hd>>HD.maxSize = 0
            hd>>HD.pos = filePos
            holeFA>>FA.da = ssd>>SSD.da
            holeFA>>FA.pageNumber = ssd>>SSD.pageNumber
            ]
         hd>>HD.maxSize = hd>>HD.maxSize+len
         sdb>>SDB.ignoreFree = hd>>HD.maxSize ge hd>>HD.neededSize
         endcase
         ]
      case dvTypeFile:
         [
         // keep a malformed directory entry from overflowing thisName
         if len gr maxDeSize then Errors(dirS, ecDeTooBig, filePos)
         MoveBlock(tempDV, thisDV, len)
         pos = pos+len
         if pos ge endPos then
            [ AdvanceBuffer(fss); MoveBlock(tempDV+len-pos, buffer, pos) ]
         test compareFn eq 0
            ifso
               [  //default system compareFn
               tempDV!len = 1  // fake next block of length 1 to stop scan
               unless ScanDirBuffer(tempDV, tempDV+len+1, sdb) eq tempDV loop
               ]
            ifnot unless compareFn(name, tempDV+lDV, tempDV) eq 0 loop

         // If we get here, the desired entry was found
         MoveBlock(dv, tempDV, lDV)
         bestPos = filePos
         break
         ]
      default:  // unknown type of directory entry
         [
         Errors(dirS, ecBadDeType, filePos)
         endcase
         ]
      ]
   pos = pos+len
   while pos ge endPos & buffer ne 0 do AdvanceBuffer(fss)
   ]

FinishScanStream(ssd)

// If we found a hole and did not find a matching directory entry, position
// the stream to the page containing the hole.
// If we did not find a hole, set the HD.pos to end-of-file.
test sdb>>SDB.ignoreFree
   ifso if bestPos eq -1 then JumpToFa(dirS, holeFA)
   ifnot hd>>HD.pos = basePos+pos

resultis bestPos
]

//---------------------------------------------------------------------------
and AdvanceBuffer(fss) be
//---------------------------------------------------------------------------
[
fss>>FSS.buffer = GetScanStreamBuffer(fss>>FSS.ssd)
fss>>FSS.basePos = fss>>FSS.basePos + fss>>FSS.endPos
fss>>FSS.pos = fss>>FSS.pos - fss>>FSS.endPos
fss>>FSS.endPos = fss>>FSS.ssd>>SSD.numChars rshift 1
]

//---------------------------------------------------------------------------
and MakeNewFdEntry(dirS, name, dv, hd, extraStuff) be
//---------------------------------------------------------------------------
// Make an entry (name, dv) of size hd>>HD.neededSize in dirS at the hole
// specified by hd.  This hole is of size hd>>HD.maxSize, which is either
// bigger than hd>>HD.neededSize or at the end of dirS.  The hd's
// maxSize-neededSize must not be greater than maxFreeDeSize; hd's
// produced by FindFdEntry have this property, since they are obtained by
// concatenating free de's until a big enough hole is obtained.
// The name should be parsed by the caller.
[
let lNameInWords = name>>STRING.length rshift 1 +1
if lNameInWords ge maxLengthFnInWords then
   Errors(dirS, ecFnTooLong, name)
dv>>DV.type = dvTypeFile
dv>>DV.length = hd>>HD.neededSize
SetFilePos(dirS, 0, 2*(hd>>HD.pos))
WriteBlock(dirS, dv, lDV)
WriteBlock(dirS, name, lNameInWords)
WriteBlock(dirS, extraStuff, hd>>HD.neededSize-lDV-lNameInWords)

let extra = hd>>HD.maxSize-hd>>HD.neededSize
if extra gr 0 then  //make remaining words into a free block
   [
   let h = nil
   h<<DV.type = dvTypeFree
   h<<DV.length = extra
   Puts(dirS, h)
   ]
]

//---------------------------------------------------------------------------
and ParseFileName(fn, n, list, versionControl) = valof
//---------------------------------------------------------------------------
// Parses n into fn, appending a $. if necessary
// Returns a directory stream in which to look for the name.
// list!0 = errRtn; list!1 = zone; list!3 = disk
[
let length = n>>STRING.length; let sep = 0
for i = 1 to length do
   [
   let c = n>>STRING.char^i
   if c eq $< % c eq $> then sep = i
   ]
let dirFn = vec maxLengthFnInWords
ExtractLegalFileName(n, dirFn, 0, sep-1)
ExtractLegalFileName(n, fn, sep, length)

// Now need to check to see if dirFn is null (in which case use WorkingDir)
// or <, in which case use SysDir
let fp = 0
let disk = list!3
if dirFn>>STRING.length eq 0 then
   [
   // Assume working directory:
   fp = disk>>DSK.fpWorkingDir
   dirFn = disk>>DSK.nameWorkingDir
   if n>>STRING.char^sep eq $< then [ fp = disk>>DSK.fpSysDir; dirFn = 0 ]
   ]
resultis OpenFile(dirFn, 0, 0, versionControl, fp, list!0, list!1,
 nil, disk, 0, #100000)
]

//---------------------------------------------------------------------------
and ExtractLegalFileName(srcS, destS, firstMinus1, last) be
//---------------------------------------------------------------------------
[
let length = last - firstMinus1
Zero(destS, (length+3) rshift 1)  // in particular, zero length & garbage byte
if length gr 0 then
   [
   for i = 1 to length do  //make sure each character is legal
      [
      let char = srcS>>STRING.char^(firstMinus1+i)
      switchon char into
         [
         default:
            unless ((char&137B) ge $A & (char&137B) le $Z) %
             (char ge $0 & char le $9) do char = $-
         case $-: case $$: case $!: case $?:
         case $+: case $.: case $<: case $>:
         ]
      destS>>STRING.char^i = char
      ]
   destS>>STRING.length = length
   StripVersion(destS)  // append $. if necessary
   ]
]

//---------------------------------------------------------------------------
and SetWorkingDir(name, fp, disk; numargs na) be
//---------------------------------------------------------------------------
[
if na ls 3 then disk = sysDisk
MoveBlock(disk>>DSK.fpWorkingDir, fp, lFP)
MoveBlock(disk>>DSK.nameWorkingDir, name, maxLengthFnInWords)
]

//---------------------------------------------------------------------------
and OpenFile(name, ksType, itemSize, versionControl, hintFp, errRtn,
 zone, nil, disk, CreateStream, SNword; numargs na) = valof
//---------------------------------------------------------------------------
[
let defaultFp = vec lFP
DefaultArgs(lv na, -1, ksTypeReadWrite, wordItem, 0, defaultFp, SysErr,
 sysZone, nil, sysDisk, CreateDiskStream, 0)
if versionControl eq 0 then
   versionControl = ksType eq ksTypeReadOnly? verLatest, verLatestCreate

   [ // repeat
   // Following check tries to decide whether the hint is filled in.
   // It may be that user just wants it filled in.
   // On the second iteration it will always call CreateStream.
   if hintFp ne defaultFp & hintFp>>FP.version ne 0 then
      [
      let s = CreateStream(hintFp, ksType, itemSize, Noop, errRtn,
       zone, nil, disk)
      if s ne 0 resultis s
      ]

   if defaultFp eq 0 resultis errRtn(nil, ecCantOpenFile)
   defaultFp = 0  // Force CreateStream to be done on next iteration

   // blunder check
   if name eq 0 % name>>STRING.length eq 0 resultis 0

   let fixedName, dv, hd = vec maxLengthFnInWords, vec lDV, vec lHD

   // strip off the directory info, return a name body and dir stream
   let currentDirS = ParseFileName(fixedName, name, lv errRtn, versionControl)
   if currentDirS eq 0 resultis 0  //no such directory

   // go look in the directory for the file.
   if FindFdEntry(currentDirS, fixedName, 0, dv, hd) eq -1 then
      [ // Not there; allowed to create?
      if (versionControl & verCrMask) eq 0 then
         [ Closes(currentDirS); resultis 0 ]
      let dirCfa = vec lCFA; GetCompleteFa(currentDirS, dirCfa)
      CreateDiskFile(disk, fixedName, lv dv>>DV.fp, lv dirCfa>>CFA.fp, SNword)
      MakeNewFdEntry(currentDirS, fixedName, dv, hd)
      ]

   Closes(currentDirS)
   MoveBlock(hintFp, lv dv>>DV.fp, lFP)
   ] repeat
]


//Moved this from MDirs.bcpl to avoid swapping in Directory overlay
//on LookupEntries calls during initialization, which is unnecessary
//when temporary files already exist.
and StripVersion(fn, lvVersionExists; numargs na) = valof
[	if na gr 1 then @lvVersionExists = false
	let len = fn>>STRING.length
	if fn>>STRING.char^len ne $. then
	[ fn>>STRING.length = len +1
	  fn>>STRING.char^(len+1) = $.
	]
	resultis 0
]