//		D I R E C T O R Y   R O U T I N E S
// Copyright Xerox Corporation 1979, 1980

//	E. McCreight
//	last edited by R. Johnsson May 11, 1980  4:17 PM


get "sysdefs.d"
get "streams.d"
get "altofilesys.d"
get "COMSTRUCT.bcpl"


external	[
	InitScanStream
	GetScanStreamBuffer
	FinishScanStream
	]

static 	[
	MYDS
	EOP
	FILLQ
	SWITCHQ
	NMATCHES
	MATCHQ
	JUSTTAIL
	GTYPE
	PAUSE
	DIAGQ
	DIAGF
	MYERRRTN

	P
	PLen
	D
	DLen
	MP

	FirstMisMatch
	]



let MAPDIR(PATTERNQ, ACTION, PREFIXMATCH; numargs na) = valof

	[ if na ls 3 then PREFIXMATCH = false

	INITDIRBLK(SORTED)

	let PATTERN = vec 129
	QFTOSTRING(PATTERNQ, PATTERN)
	unless PREFIXMATCH do AppendDot(PATTERN)

	for I=FindFirst(PATTERN) to FindLast(PATTERN) do

		[ let de = DIRHDBLK!I

		if PMatchesD(PATTERN, de,
			PREFIXMATCH)
			then

			[ let T = ACTION(DIRHDBLK!I, FirstMisMatch-1)
			if T ne 0 then resultis T
			]
		]

	resultis 0
	]


and PMatchesD(Pattern, MyDE, MatchPrefix) = valof

	[ let DString = vec 129
	D = DString
	MoveBlock(D, lv MyDE>>MYDE.S,
		(MyDE>>MYDE.S.length rshift 1)+1)
	P = Pattern
	MP = MatchPrefix

	PLen = P>>STRING.length
	if PLen eq 0 then resultis MatchPrefix
	DLen = D>>STRING.length

	FirstMisMatch = MatchTails(1, 1, false)
	resultis (FirstMisMatch ge DLen+1)? true,
			((FirstMisMatch gr 1)? MatchPrefix,
				 false
			)
	] 


and MatchTails(NextPChar, NextDChar, PrefixHasStar) = valof

	[ // returns +i if the match "succeeded" and matched up
	//	through the i-th character of D.
	// returns +infinity if all characters of D were matched.
	// returns -j if there was no successful match,
	//	but the pattern was prefixed by a * and the
	//	first misaligned partial match occurred after
	//	ignoring the first j characters of D.
	// returns -(DLen+2) if an exactly-aligned match
	//	could not be made and either the pattern
	//	was not prefixed by a * or not even a
	//	misaligned partial match could be made.

	while (NextPChar le PLen)&
		((P>>STRING.char^NextPChar eq $**)%
			(P>>STRING.char^NextPChar eq $%)) do
		[ PrefixHasStar = true
		NextPChar = NextPChar+1
		]

	if NextPChar gr PLen then
		resultis (NextDChar ls DLen+1 & PrefixHasStar)?
			DLen+1,
			NextDChar

	let FirstMatch = DLen+2
	let Alignment = 0
	let PC = P>>STRING.char^NextPChar
	if (PC ge $a) & (PC le $z) then PC = PC+($A-$a)

	while (Alignment eq 0) %
		(PrefixHasStar &
		(NextDChar+Alignment le DLen+2)) do

		[ let CurPC = PC
		let i = 0

		while true do
			[ let Index = NextDChar+Alignment+i

			if Index gr DLen then Index = DLen

			let CurDC = D>>STRING.char^Index

			if (CurDC ge $a) & (CurDC le $z) then
				CurDC = CurDC+($A-$a)

			if (CurDC ne CurPC) &
				((CurPC ne $#) %
					(CurDC eq $.)) then
				break

			i = i+1

			if NextPChar+i gr PLen then
				[ if (NextDChar+Alignment+i ls
					DLen) & PrefixHasStar &
					(not MP) then
						break

				resultis NextDChar+Alignment+i
				]

			CurPC = P>>STRING.char^(NextPChar+i)

			if (CurPC eq $**) % (CurPC eq $%) then
				[ if FirstMatch gr Alignment then
					FirstMatch = Alignment
				let T = MatchTails(NextPChar+i,
					NextDChar+Alignment+i)

				if T gr 0 then resultis T

				// That match failed, try another
				Alignment = (-T gr Alignment)?
					-T, Alignment
				break
				]

			if (CurPC ge $a) & (CurPC le $z) then
				CurPC = CurPC+($A-$a)
			]

		Alignment = Alignment+1
		]

	resultis -FirstMatch
	]


and FindFirst(Pattern) = valof

	[ let Prefix = vec 129
	ComputePrefix(Pattern, Prefix)

	resultis BinSearch(DIRHDBLK, Prefix)
	]


and FindLast(Pattern) = valof

	[ let Prefix = vec 129
	ComputePrefix(Pattern, Prefix)

	let Len = Prefix>>STRING.length+1
	Prefix>>STRING.length = Len
	Prefix>>STRING.char^Len = #377

	resultis BinSearch(DIRHDBLK, Prefix)
	]


and ComputePrefix(Pattern, Prefix) be

	[ let Length = 0
	let PatLen = Pattern>>STRING.length

	while Length ls PatLen do
		[ let C = Pattern>>STRING.char^(Length+1)
		if selecton C into
			[ case $**:
			case $#:
			case $%:
				true

			default: false
			]
			then break

		Length = Length+1
		Prefix>>STRING.char^Length = C
		]

	if (Length eq PatLen)&(PatLen ge 1)&
		(Pattern>>STRING.char^PatLen eq $.) then
		Length = Length-1		// remove final period
	Prefix>>STRING.length = Length
	]



and FilesWithSuffix(FNQ, SufQ, NewFNQ) = valof

	[ let QCopy = vec size QS/16
	INITQ(QCopy)
	COPYQ(FNQ, QCopy)
	JUSTTAIL = false
	MATCHQ = NewFNQ
	NMATCHES = 0
	MAPDIR(QCopy, ESCMATCH)
	if NMATCHES eq 1 then
		[ let C = GETQR(NewFNQ)
		while C eq $. do
			C = GETQR(NewFNQ)
		PUTQR(NewFNQ, C)
		resultis 1
		]

	EMPTYOUTQ(NewFNQ)

	let FileName = vec size STRING/16
	COPYQ(FNQ, QCopy)
	QFTOSTRING(QCopy, FileName)

	let Suffix = vec size STRING/16
	COPYQ(SufQ, QCopy)
	QFTOSTRING(QCopy, Suffix)

	let FNLen = FileName>>STRING.length
	let SufLen = Suffix>>STRING.length

	for Overlap=0 to ((SufLen gr FNLen)? FNLen, SufLen) do

		[ let OverlapValid = true

		for i=1 to Overlap do
			if Capitalize(Suffix>>STRING.char^i) ne
				Capitalize(FileName>>STRING.char^
					(FNLen-Overlap+i))
				then	[ OverlapValid = false
					break
					]

		unless OverlapValid do loop

		EMPTYOUTQ(NewFNQ)
		EMPTYOUTQ(QCopy)

		for i=1 to FNLen-Overlap do
			PUTQR(QCopy, FileName>>STRING.char^i)
		STRINGTOQR(Suffix, QCopy)

		let MatchCount = EXPANDESC(QCopy, NewFNQ, false)
		EMPTYOUTQ(QCopy)
		if MatchCount ne 0 then
			resultis MatchCount
		]

	resultis 0
	]


and Capitalize(Char) = ((Char ge $a) & (Char le $z))?
			Char+$A-$a,
			Char


and ISSEP(C) = (C eq $.) % (C eq $;) % (C eq $<) % (C eq $>)


and ISFILECHAR(C) =

		((C ge $A) & (C le $Z)) %
		((C ge $a) & (C le $z)) %
		((C ge $0) & (C le $9)) %
		valof
			[ let S = "+-.!$"
			for i=1 to S>>STRING.length do
				if C eq S>>STRING.char^i then
					resultis true
			resultis false
			]


and ISNTFILECHAR(C) = not ISFILECHAR(C)


and IsCommandChar(C) = ((C ge $A) & (C le $Z)) %
		((C ge $a) & (C le $z)) %
		((C ge $0) & (C le $9)) %
		valof
			[ let S = "+-.!$~?**#%"
			for i=1 to S>>STRING.length do
				if C eq S>>STRING.char^i then
					resultis true
			resultis false
			]



and IsntCommandChar(C) = not IsCommandChar(C)


and ISITEMCHAR(C) = IsCommandChar(C) % (C eq $/)


and EXPANDSTAR(Q) be

	[

	let ADDITEM(MYDE, Y) = valof

		[ if MYDE>>MYDE.TYPE ne ISFILE then resultis 0

		for I=1 to (MYDE>>MYDE.S.length)-1 do
			PUTQR(FILLQ, MYDE>>MYDE.S.char^I)
		COPYQ(SWITCHQ, FILLQ)	// Add the switches,
		PUTQR(FILLQ, $*S)	//	and a final space

		resultis 0
		]


	let MYFNQ = vec size QS/16
	let MYSWQ = vec size QS/16

	INITQ(MYFNQ)
	INITQ(MYSWQ)

	XFERQWHILE(GETQR, PUTQR, Q, PUTQF, MYSWQ, ISITEMCHAR)
	XFERQWHILE(GETQF, PUTQF, MYSWQ, PUTQR, MYFNQ, IsCommandChar)

	FILLQ = Q
	SWITCHQ = MYSWQ

	INITDIRBLK(SORTED)
	MAPDIR(MYFNQ, ADDITEM)

	EMPTYOUTQ(MYFNQ)
	EMPTYOUTQ(MYSWQ)

	return
	]



 and EXPANDESC(Q, RQ, TAILONLY) = valof

	[ JUSTTAIL = TAILONLY

	let FNQ = vec size QS/16
	INITQ(FNQ)

	XFERQWHILE(GETQR, PUTQR, Q, PUTQF, FNQ, IsCommandChar)
	COPYQ(FNQ, Q)

	NMATCHES = 0
	MATCHQ = RQ

	MAPDIR(FNQ, ESCMATCH, true)

	resultis NMATCHES
	]


and ESCMATCH(MYDE, MATCHLEN) = valof

	[ let FIRSTCHAR = JUSTTAIL? MATCHLEN+1, 1

	let fileName = vec 50
	let fileNameLength = MYDE>>MYDE.S.length

	MoveBlock(fileName, lv (MYDE>>MYDE.S),
		(fileNameLength rshift 1)+1)
	AppendDot(fileName)
	fileNameLength = fileName>>STRING.length-1  // remove final "."

	let I = nil
	test NMATCHES eq 0

	ifso	[ NMATCHES = 1
		I = fileNameLength+1
		]

	ifnot	[ I = FIRSTCHAR

		while I le fileNameLength do
			[ if ISEMPTYQ(MATCHQ) then break
			let C1 = fileName>>STRING.char^I
			if (C1 ge $a) & (C1 le $z) then C1 = C1+($A-$a)
			let C2 = GETQF(MATCHQ)
			if (C2 ge $a) & (C2 le $z) then C2 = C2+($A-$a)
			if C2 ne C1 then
				[ NMATCHES = NMATCHES+1
				break
				]
			I = I+1
			]
		]

	EMPTYOUTQ(MATCHQ)
	for J = FIRSTCHAR to I-1 do
		PUTQR(MATCHQ, fileName>>STRING.char^J)

	resultis 0
	]


and MyOpenFile(fileName, ksType, itemSize,
		versionControl, fp, errRtn, zone, logInfo,
		disk, CreateStream; numargs na) = valof

	[ static [ gSpecialFp; gVersionControl ]

	let FindSpecialFp(MYDE) = valof
		[
		if MYDE>>MYDE.TYPE ne ISFILE then resultis 0
		resultis lv (MYDE>>MYDE.FP)
		]


	switchon na into
		[ case 0:
		case 1:	ksType = ksTypeReadWrite
		case 2:	itemSize = wordItem
		case 3:	versionControl = 0
		case 4:	fp = 0
		case 5:	errRtn = @lvSysErr
		case 6:	zone = sysZone
		case 7:	logInfo = 0
		case 8:	disk = sysDisk
		case 9:	CreateStream = CreateDiskStream
		default:
		]

	let localName = vec 50

	if (fp eq 0) & valof
		[ let dirName = vec 129
		SplitFileName(fileName, dirName, localName)
		resultis (dirName>>STRING.length gr 0)
		]
		then
		[ // let the system do this one...
		let Value = OpenFile(fileName, ksType,
				itemSize, versionControl,
				fp, errRtn, zone, logInfo,
				disk, CreateStream)
		resultis Value
		]

	gVersionControl = (versionControl ne 0)? versionControl,
		selecton ksType into
			[ case ksTypeReadWrite:
					verLatestCreate
			case ksTypeReadOnly:
					verLatest
			case ksTypeWriteOnly:
					verLatestCreate
			]

	if fp eq 0 then
		[
		let FNQ = vec size QS/16
		INITQ(FNQ)
		STRINGTOQR(localName, FNQ)
		GETQR(FNQ)	// remove training period
		fp = MAPDIR(FNQ, FindSpecialFp)
		]

	let S = (fp ne 0 %
		 gVersionControl eq verLatestCreate %
		 gVersionControl eq verNew %
		 gVersionControl eq verNewAlways)?
	    OpenFile(fileName, ksType,
		itemSize, versionControl,
		fp, errRtn, zone, logInfo,
		disk, CreateStream), 0

	if (S ne 0) & (fp eq 0) then WIPEDIRBLK()

	resultis S
	]


and INITDIRBLK(P) be

	[ static [ DIRHDQ
		DECOUNT
		LP
		ssd
		ssdBuffers
		scanBuffer
		wordsInBuffer
		cl
		cd
		DirE
		LocalE
		]

	let GetNWordsFromScan(n, dest, move) be
		[
		while n gr 0 do
		  [ let chunk = n ls wordsInBuffer? n, wordsInBuffer
		  move(dest, scanBuffer, chunk)
		  wordsInBuffer = wordsInBuffer - chunk
		  test wordsInBuffer eq 0
		    ifso
		      [ scanBuffer = GetScanStreamBuffer(ssd)
		      if scanBuffer eq 0 then break
		      wordsInBuffer = (ssd>>SSD.numChars+1) rshift 1
		      ]
		    ifnot [ scanBuffer = scanBuffer + chunk; break]
		  dest = dest + chunk
		  n = n - chunk
		  ]
		]
	PAUSE = P eq true
	switchon DIRSTATE into

	[ case EMPTY:
		[ Resets(SYSTEMDIR)
		ssdBuffers = Allocate(CZ, 512)
		let ssdTable = vec 1
		ssdTable!0, ssdTable!1 = ssdBuffers, ssdBuffers+256
		ssd = InitScanStream(SYSTEMDIR, ssdTable, 2)
		scanBuffer = GetScanStreamBuffer(ssd)
		wordsInBuffer = (ssd>>SSD.numChars+1) rshift 1;
		DIRSTATE = GETTINGFILE
		]

	case GETTINGFILE:

		DECOUNT = 0
		DIRHDQ = Allocate(CZ, size QS/16)
		INITQ(DIRHDQ)
		DIRSTATE = MAKINGBLK

		LP = LOCALTABLE
		cl, cd = 0, 0 // first chars from local and directory
		DirE = Allocate(CZ, 256)

	case MAKINGBLK:

		[ until (cl % cd) eq 0 & scanBuffer eq 0 &
			LP>>TE.pStatic eq 0 do

			[ if ISPAUSE() then return

			if cd eq 0 & scanBuffer ne 0 then
			  [ GetNWordsFromScan(1, DirE, MoveBlock)
			  let DELEN = DirE>>DV.length
			  GetNWordsFromScan(DELEN-1, DirE+1,
			    ((DirE>>DV.type eq dvTypeFile)?
			         MoveBlock, Noop))
			  if DirE>>DV.type ne dvTypeFile then loop
			  cd = Capitalize(DirE>>DV.name.char^1) lshift 7
			  cd = cd + Capitalize(DirE>>DV.name.char^2)
			  ]

			if cl eq 0 & LP>>TE.pStatic ne 0 then
			  [ LocalE = LP
			  LP = LP+(offset TE.SUBSYSNAME/16)+
			    (LocalE>>TE.SUBSYSNAME.length/2)+1
			  cl = Capitalize(LocalE>>TE.SUBSYSNAME.char^1) lshift 7
			  cl = cl + Capitalize(LocalE>>TE.SUBSYSNAME.char^2)
			  ]

			let ISAFILE = nil

			test cl ne 0 & cd ne 0
			  ifso	test cd ls cl
				  ifso	[ ISAFILE = true; cd = 0 ]
				  ifnot	[ ISAFILE = false; cl = 0 ]
			  ifnot	test cl eq 0
				  ifso	[ ISAFILE = true; cd = 0 ]
				  ifnot	[ ISAFILE = false; cl = 0 ]

			DECOUNT = DECOUNT+1

			let NCHARS = ISAFILE? 
			   DirE>>DV.name.length,
			   LocalE>>TE.SUBSYSNAME.length

			let BlockLength = ((offset MYDE.S.length)+
					15)/16+((NCHARS+2) rshift 1)
			let MYDE = Allocate(CZ, BlockLength)

			PUTNWQR(1, DIRHDQ, lv MYDE)

			test ISAFILE

			ifso	[ MoveBlock(MYDE, DirE,
						BlockLength)
				MYDE>>MYDE.TYPE = ISFILE
				]

			ifnot	[ MYDE>>MYDE.TYPE = ISLOCALSUBSYS
				MYDE>>MYDE.pStatic = LocalE>>TE.pStatic
				MYDE>>MYDE.S.length = NCHARS

				for I=1 to NCHARS do
				    MYDE>>MYDE.S.char^I =
					LocalE>>TE.SUBSYSNAME.char^I
				]

			]

		FinishScanStream(ssd)
		Free(CZ, ssdBuffers)
		Free(CZ, DirE)
		DIRHDBLK = Allocate(CZ, DECOUNT+1)
		DIRHDBLK!0 = DECOUNT
		GETNWQF(DECOUNT, DIRHDQ, DIRHDBLK+1)

		Free(CZ, DIRHDQ)
		DIRSTATE = MADEBLK
		]

	case MADEBLK:
	case SORTING:
		if (P ge 0) & (P le MADEBLK) then return
		if SORT(DIRHDBLK, ISPAUSE) then return
		DIRSTATE = SORTED


	case SORTED:
		DIRSTATE = PAGESCOUNTED

	case PAGESCOUNTED:
		if ((P ge 0) & (P le PAGESCOUNTED)) %
			ISPAUSE() then return
		MAKETIMELINE()
		endcase
	]
	]


and ReturnThirdArg(x, y, z) = z


and AppendDot(s) be

	[ let len = s>>STRING.length
	if s>>STRING.char^len ne $. then
		[ len = len + 1
		s>>STRING.char^len = $.
		s>>STRING.length = len
		]
	]


and ISPAUSE() = PAUSE & (not Endofs(keys))


and WIPEDIRBLK() be

	[ unless DIRSTATE eq EMPTY do
		[ INITDIRBLK(MADEBLK)
		for I=1 to DIRHDBLK!0 do
			Free(CZ, DIRHDBLK!I)
		Free(CZ, DIRHDBLK)

		DIRSTATE = EMPTY
		]

	return
	]


and SETUPCLK(EventTime, IntervalL, IntervalH; numargs na) be

	[ let Interval = vec 2
	Interval!1 = IntervalL
	Interval!0 = (na ls 3)? 0, IntervalH

	Timer(EventTime)
	DoubleAdd(EventTime, Interval)
	]


and TIMEHASCOME(EventTime) = valof

	[ // resultis true if CurrentTime ge Time

	let CurrentTime = vec 2
	Timer(CurrentTime)

	let TimeRemaining = vec 2

	for i=0 to 1 do
		TimeRemaining!i = (-1)-(CurrentTime!i)

	DoubleAdd(TimeRemaining, EventTime)

	// TimeRemaining = EventTime-CurrentTime-1

	resultis TimeRemaining!0 ls 0
	]


and DumpDirectory() = valof

	[ 
	external Wns
	let s = OpenFile("Exec.data", ksTypeWriteOnly, charItem)
	for i = 1 to DIRHDBLK!0 do
	  [
	  Wns(s,i,3,8); Puts(s,$*s)
	  let de = DIRHDBLK!i
	  let l = de>>MYDE.S.length
	  for j = 1 to l do Puts(s,de>>MYDE.S.char^j)
	  Puts(s,$*n)
	  ]
	Closes(s)
	resultis DIRHDBLK!0
	]