//
// File searching program
// last edited October 29, 1980  6:21 PM
//
// Copyright Xerox Corporation 1979, 1980

	get "findpkgdefs.d"
	get "streams.d"
	get "altofilesys.d"
	get "bcplfiles.d"

external
[		// GP
	SetupReadParam
	ReadParam
		// MDI
	LookupEntries
		// findsub
	Usc2
	occlim
	linedelim
	paradelim
	breakdelim
	nonbravo
	copyseg
	splitstream
	boldstream
	readstring
	ReadChar
		// FindCompile
	FindCompile
		// FindNext
	FindInitScan
	FindNext
		// Template
	PutTemplate
		// O.S.
	Closes; CreateDiskStream; CreateDisplayStream
	DoubleAdd; dsp
	Endofs
	FilePos; FinishScanStream; fpComCm; fpSysDir; Free
	GetLinePos; Gets
	keys
	MoveBlock
	OpenFile
	Puts
	Resets
	SetBlock; SetFilePos; ShowDisplayStream; sysZone
	Timer
	Usc
	Ws; Wss
	Zero
]


manifest
[	bufsize = 77000b	// buffer space
	mbufsize = 800	// buffer for one-line message
	displines = 45
	savematches = 50	// remember position of this many matches
	maxll = 100	// max line length
	maxnl = 20	// max paragraph length
	lvCodeTop = #335
	lvDisplayHead = #420
	dsoptions = DSstopbottom+DSstopright
	mdsoptions = 0
]


structure BS:
[	length byte
	char^1,255 byte
]

structure MP:	// match position
[	fid word	// file number
	fa word lFA = @FA
	ppos word	// position within pattern
]
manifest lMP = size MP/16

structure FF:	// Find flags
[	itemproc word	// item delimitation procedure
	waf word	// if true, write all matches to file (allf % writef)
	allf word	// All flag
	casef word	// Case flag
	lstf word	// List flag
	multif word	// Multiple flag
	octalf word	// Octal flag
	spacef word	// Space flag
	verbatimf word	// Verbatim flag
	writef word	// Write flag
]
manifest lFF = size FF/16


static
[	charExit = 177b
	charWildCard = 1
	flags	// global flags, needed by ccproc
]

//
// Main program
//

let find(blv) be
[	let ff = vec lFF
	SetBlock(ff, false, lFF)
	let cpat = vec 30
	ff>>FF.itemproc = linedelim
	let com = OpenFile("Com.Cm", ksTypeReadOnly, charItem, 0, fpComCm)
	let nv, swv = vec 128, vec 128
	SetupReadParam(nv, swv, com, swv)
	for j = 1 to swv!0 do
	[ let ch = swv!j&137b
	  let off = getflag(ch)
	  test off ge 0
	   ifso ff!off = true
	   ifnot switchon ch into
	  [ case $B: ff>>FF.itemproc = breakdelim; endcase
	    case $L: ff>>FF.lstf = true; endcase
	    case $M: ff>>FF.multif = true; endcase
	    case $P: ff>>FF.itemproc = paradelim; endcase
	  ]
	]
	if ff>>FF.writef then ff>>FF.waf = true
	let buf = vec bufsize
	let A = blv>>BLV.overlayAddress^0
	let B = blv>>BLV.overlayAddress^1
	let flist = A
	addname("Find.Lst", lv flist)
	addname("Find.Matches", lv flist)
	 [ if ReadParam($P, -1, nv, swv) eq -1 break
	   addname(nv, lv flist)
	 ] repeatwhile ff>>FF.multif
	let fnames = flist
	let cfn = A
	while cfn ne fnames do
	 [ @flist = cfn
	   flist = flist+1
	   cfn = cfn + cfn>>BS.length/2+1
	 ]
	let fdvs = flist
	let nfiles = fdvs-fnames-2
	flist = fdvs+(nfiles+2)*lDV
	@lvCodeTop = flist
	let dir = CreateDiskStream(fpSysDir, ksTypeReadOnly, wordItem)
	if dir eq 0 then abor("Can't open SysDir")
	LookupEntries(dir, fnames, fdvs, nfiles+2, true, buf, bufsize)
	Closes(dir)
	let len = 0
	until Endofs(com) do
	 [ let ch = Gets(com)
	   if ch eq $*N break
	   len = len+1
	   cpat>>BS.char^len = ch
	 ]
	cpat>>BS.length = len
	Closes(com)
	// Flush initialization code
	MoveBlock(B, A, flist-A)
	let disp = B-A
	@lvCodeTop = flist+disp
	fnames, fdvs = fnames+disp, fdvs+disp
	for i = 0 to nfiles+1 do
	   fnames!i = fnames!i+disp
	let miss = false
	for i = 2 to nfiles+1 do
	 if fdvs!(i*lDV) eq 0 then
	 [ unless miss do
	    [ Ws("Can't find the following files:")
	      miss = true
	    ]
	   Puts(dsp, $*S)
	   Ws(fnames!i)
	 ]
	if miss then abor("*N")
	let lsts, mats = 0, 0
	if ff>>FF.lstf then lsts = OpenFile(fnames!0, ksTypeWriteOnly, charItem, verLatestCreate, lv fdvs>>DV.fp)
	mats = OpenFile(fnames!1, ksTypeWriteOnly, charItem, verLatestCreate, lv (fdvs+lDV)>>DV.fp)
	flags = ff	// set up static for ccproc
	 [ let r = nil
	   if len eq 0 then
	    [ readstring("Pattern: ", dsp, cpat, ccproc)
	      if cpat>>BS.length eq 0 break
	    ]
	   ff>>FF.waf = ff>>FF.allf % ff>>FF.writef
	   r = findmain(fnames+2, fdvs+2*lDV, nfiles, cpat, ff, lsts, mats, buf, bufsize)
	   if lsts ne 0 then [ Closes(lsts); lsts = 0 ]
	   if r ne 0 then
	    [ PutTemplate(dsp, "**********$S*N", r) ]
	 ] repeatwhile len eq 0
	Closes(mats)
]

and addname(str, lvlst) be
[	let nw = str>>BS.length/2+1
	MoveBlock(@lvlst, str, nw)
	@lvlst = @lvlst+nw
]

and abor(s) be
	 [ Ws(s); finish ]

and ccproc(ds, ch) = valof
// Handle a control character during pattern input.
// The only character recognized is ^S, which prompts for a
// switch to toggle, or ? meaning show the current state.
[	if ch ne $S-100b resultis false
	Wss(ds, " Switch: ")
	ch = ReadChar(ds, 5, 200)
	let msg = nil
	let off = getflag(ch, lv msg)
	test off ne -1
	 ifso
	[ flags!off = not flags!off
	  Wss(ds, msg)
	  Wss(ds, (flags!off? " -- on", " -- off"))
	]
	 ifnot
	test ch eq $?
	 ifso
	[ Puts(ds, $*N)
	  for i = 0 to 5 do
	  [ off = getflag(table[ $A;$C;$O;$S;$V;$W ]!i, lv msg)
	    if flags!off then PutTemplate(ds, "  $S*N", msg)
	  ]
	]
	 ifnot Wss(ds, " ???")
	resultis true
]

and getflag(ch, lvMsg; numargs na) = valof
// Convert a global flag character to an index in the FF structure,
// or -1 if not recognized.  If a second arg is supplied,
// store an explanatory message into it.
[	if na ls 2 then lvMsg = lv na
	switchon (ch&137b) into	// lower case = upper case
	[ case $A: @lvMsg = "All to file"; resultis offset FF.allf/16
	  case $C: @lvMsg = "Case matters"; resultis offset FF.casef/16
	  case $O: @lvMsg = "Octal positions"; resultis offset FF.octalf/16
	  case $S: @lvMsg = "Spaces matter"; resultis offset FF.spacef/16
	  case $V: @lvMsg = "Verbatim"; resultis offset FF.verbatimf/16
	  case $W: @lvMsg = "Write only"; resultis offset FF.writef/16
	]
	resultis -1
]

//
// Main matching code
//

and findmain(fnames, fdvs, nfiles, upat, ff, lsts, mats, buf, bsize) = valof
[	let chtab = vec 200b
	let tables = 0
	let r = compat(upat, ff, lsts, chtab, lv tables)
	if r ne 0 resultis r
	let matchpos = vec (lMP*savematches)
	let old = vec lMP
	Zero(old, lMP)
	let npages = 0
	let dh = @lvDisplayHead
	@lvDisplayHead = 0
	let btime = vec 1
	Timer(btime)
	let nmatches = getmatches(fdvs, nfiles, buf, bsize, matchpos, lv npages, old)
	let atime = vec 1
	Timer(atime)
	@lvDisplayHead = dh
	let dtime = vec 1
	dtime!0, dtime!1 = not btime!0, not btime!1
	DoubleAdd(dtime, table[ 0; 1 ])
	DoubleAdd(dtime, atime)	// dtime _ atime-btime
	PutTemplate(dsp, "  $D matches, $ED ms, $D pages", nmatches, dtime, npages)
	if nmatches gr savematches then nmatches = savematches
	let first = true
	let dbsize = (ff>>FF.writef? 0, bsize)
	if nmatches ne 0 then
	 [ let last = nmatches ls savematches
	   let nm = showmatches(fnames, fdvs, mats, buf, dbsize, matchpos, nmatches, upat>>BS.length, chtab, first, last, ff)
	   if nm ls 0 then
	   [ unless ff>>FF.waf break
	     nm = -1-nm
	     if last & (nm eq nmatches) break	// all done
	     dbsize = 0	// don't display any more
	   ]
	   MoveBlock(old, matchpos+(nm-1)*lMP, lMP)
	   nmatches = getmatches(fdvs, nfiles, buf, bsize, matchpos, 0, old)
	   first = false
	 ] repeat
	if tables ne 0 then Free(sysZone, tables)
	resultis 0
]

and compat(upat, ff, lsts, chtab, lvTables) = valof
[	// Decode user-specified pattern into string, wildcards, fuzz
	SetBlock(chtab, classOther, 200b)
	chtab!charExit = classExit
	unless ff>>FF.spacef do chtab!$*S = classSkip
	unless ff>>FF.casef do for ch = $a to $z do chtab!ch = ch+($A-$a)
	let pat = upat
	let len, fuzz = 0, 0
	let quote = false
	for i = 1 to upat>>BS.length do
	 [ let ch = upat>>BS.char^i & 177b
	   if ch ls 40b resultis "Control char.s not allowed"
	   unless quote switchon ch into
	   [ case $~:
	      fuzz = fuzz+1
	      loop
	     case $':
	      quote = true
	      loop
	     case $*S:
	      if ff>>FF.spacef endcase
	      loop
	     case $#:
	      ch = charWildCard
	   ]
	   len = len+1
	   pat>>BS.char^len = ch
	   quote = false
	 ]
	pat>>BS.length = len
	resultis FindCompile(pat, chtab, charWildCard, fuzz, lsts, true, 0, lvTables)
]

and getmatches(fdvs, nfiles, buf, bsize, matchpos, lvnp, old) = valof
// Returns # of matches
[	let nmatches = 0
	let fa = vec lFA
	let skip = lvnp eq 0	// skip all matches through old
	for i = old>>MP.fid to nfiles-1 do
	 [ let st = CreateDiskStream(lv (fdvs+i*lDV)>>DV.fp, charItem, ksTypeReadOnly)
	   let ssd = FindInitScan(st, buf, bsize, fa)
	    [ let ppos = FindNext()
	      if ppos ls 0 then	// end of file, ppos = not npages
	       [ if lvnp ne 0 then @lvnp = @lvnp + not ppos
	         break
	       ]
	      if skip then
	       [ if (i eq old>>MP.fid) & (ppos eq old>>MP.ppos) &
	          (fa>>FA.pageNumber eq old>>MP.pageNumber) &
	          (fa>>FA.charPos eq old>>MP.charPos) then
	            skip = false
	         loop
	       ]
	      test nmatches ls savematches
	       ifso	// save position of match
	       [ let mp = matchpos+lMP*nmatches
	         mp>>MP.fid = i
	         mp>>MP.ppos = ppos
	         mp>>MP.da = fa>>FA.da
	         mp>>MP.pageNumber = fa>>FA.pageNumber
	         mp>>MP.charPos = fa>>FA.charPos
	       ]
	       ifnot
	        if lvnp eq 0 then	// quit now
	       [ FinishScanStream(ssd)
	         Closes(st)
	         resultis nmatches
	       ]
	      nmatches = nmatches+1
	    ] repeat
	   FinishScanStream(ssd)
	   Closes(st)
	 ]
	resultis nmatches
]

//
// Output results
//

and showmatches(fnames, fdvs, mats, db, bsize, matchpos, nmatches, patlen, chtab, first, last, ff) = valof
// Returns # of matches displayed normally, -1-# if aborted or done
[	let ds, mds, ms, bolds = nil, nil, vec lST, vec lST
	test bsize eq 0
	 ifso	// just copy matches, don't display
	  ds, ms = 0, mats
	 ifnot
	[ ds = CreateDisplayStream(displines, db, bsize-mbufsize, 0, 0, dsoptions)
	  ShowDisplayStream(ds)
	  mds = CreateDisplayStream(2, db+bsize-mbufsize, mbufsize, 0, 0, mdsoptions)
	  ShowDisplayStream(mds, DSbelow, ds)
	  boldstream(bolds, ds)
	  splitstream(ms, ds, mats)
	]
	let ll, nl = nil, nil
	test ff>>FF.waf
	 ifso ll, nl = -1, -1
	 ifnot ll, nl = maxll, maxnl
	let para = ff>>FF.verbatimf & (ff>>FF.itemproc eq paradelim)
	let eop = (para? "*032*N", "*N")	// end of paragraph string
	let lastfid = (first? -1, matchpos>>MP.fid-1)
	let fs = (first? ms, ds)
	let lim = nmatches-1
	let st = 0
	let i = 0
	while i le lim do
	 [ let mp = matchpos+lMP*i
	   if mp>>MP.fid ne lastfid then
	    [ if st ne 0 then Closes(st)
	      while lastfid ne mp>>MP.fid do
	       [ lastfid = lastfid+1
	         if fs ne 0 then PutTemplate(fs, "****** $S$S", fnames!lastfid, eop)
	       ]
	      fs = ms
	      st = CreateDiskStream(lv (fdvs+lastfid*lDV)>>DV.fp, ksTypeReadOnly, charItem)
	    ]
	   let begv, mbegv, posv, mendv, endv = vec 1, vec 1, vec 1, vec 1, vec 1
	   let fa = lv mp>>MP.fa
	   let pn = fa>>FA.pageNumber-1
	   posv!0, posv!1 = pn rshift 7, pn lshift 9 + fa>>FA.charPos
	   occlim(st, posv, mbegv, mendv, mp>>MP.ppos, patlen, chtab)
	   let inl = ff>>FF.itemproc(st, mbegv, begv, endv, ll, nl)
	   unless ff>>FF.verbatimf do nonbravo(st, mbegv, begv, endv)
	   if ff>>FF.octalf then PutTemplate(mats, "$6EO$S", posv, (para? eop, " "))
	   if copyseg(st, mats, begv, endv) ne $*N then Wss(mats, eop)
	   if ds ne 0 then
	   [ PutTemplate(ds, "$6EO ", posv)
	     copyseg(st, ds, begv, mbegv)
	     let lastch = nil
	     test Usc2(endv, mendv) gr 0
	     ifso	// normal case, match falls within delimited area
	     [ copyseg(st, bolds, mbegv, mendv)
	       lastch = copyseg(st, ds, mendv, endv)
	     ]
	     ifnot	// delimited area ends within match
	       lastch = copyseg(st, bolds, mbegv, endv)
	     if lastch ne $*N then Puts(ds, $*N)
	     if (GetLinePos(ds) ge displines-5) % (i eq lim) then
	      [ test (i eq lim) & last
	         ifso
	         [ Wss(mds, "*N*T*T----- <SP> to clear screen -----*N")
	           Gets(keys)
	           i = i+1
	         ]
	         ifnot
	         [ Wss(mds, "*N*T*T----- <SP> for more, <DEL> to abort -----*N")
	           i = (Gets(keys) eq 177b? -i-2, i+1)
	         ]
	        break
	      ]
	   ]
	   i = i+1
	 ]
	if st ne 0 then Closes(st)
	if ds ne 0 then
	[ ShowDisplayStream(mds, DSdelete)
	  ShowDisplayStream(ds, DSdelete)
	]
	resultis ((i eq nmatches) & last? -i-1, i)
]