#
#
#
#    LIST File Listing Utility
#    =========================
#
#         Author:  William P. Wood, Jr.
#
#         Address: Computer Center
#                  Institute For Cancer Research
#                  7701 Burholme Ave.
#                  Philadelphia, Pa. 19111
#                  (215) 728 2760
#
#         Version: 3.0
#
#         Date:    December 29, 1981
#
#
#
#      *******************************************************
#      *                                                     *
#      *      THIS SOFTWARE WAS DEVELOPED WITH SUPPORT       *
#      *      FROM THE NATIONAL INSTITUTES OF HEALTH:        *
#      *         NIH CA06927                                 *
#      *         NIH CA22780                                 *
#      *                                                     *
#      *      DIRECT INQUIRIES TO:                           *
#      *            COMPUTER CENTER                          *
#      *            THE INSTITUTE FOR CANCER RESEARCH        *
#      *            7701 BURHOLME AVENUE                     *
#      *            PHILADELPHIA, PENNSYLVANIA   19111       *
#      *                                                     *
#      *      NO WARRANTY OR REPRESENTATION, EXPRESS OR      *
#      *      IMPLIED, IS MADE WITH RESPECT TO THE           *
#      *      CORRECTNESS, COMPLETENESS, OR USEFULNESS       *
#      *      OF THIS SOFTWARE, NOR THAT USE OF THIS         *
#      *      SOFTWARE MIGHT NOT INFRINGE PRIVATELY          *
#      *      OWNED RIGHTS.                                  *
#      *                                                     *
#      *      NO LIABILITY IS ASSUMED WITH RESPECT TO        *
#      *      THE USE OF, OR FOR DAMAGES RESULTING FROM      *
#      *      THE USE OF THIS SOFTWARE                       *
#      *                                                     *
#      *******************************************************
#
#
include symbols.rat

# parse - return first arg in comand and delete it from comand
  subroutine parse(comand, arg)
  byte comand(1), arg(1)
  integer j
  byte cupper

  j = 1
  while (comand(j) ~= ' '  &  comand(j) ~= EOS  &
	 (comand(j) ~= '/'  |  j == 1  |  comand(1) ~= '/')) {
    arg(j) = cupper(comand(j))
    j = j+1
    }
  arg(j) = EOS
  if (comand(j) == ' ')
    j = j+1
  call scopy(comand, j, comand, 1)
  return
  end

# getfil - return selected file names one at a time from a list of file specs
#          separated by commas.
#          File specs may be a simple file name, or they may reference
#          an indirect file if @<indirect file> is specified, or
#          file names may be selected by wild cards and/or switches.

define(SIMPLENAME,0)
define(WLDNAME,1)
define(INDIRECTNAME,2)

  logical function getfil(file, ans, nselec, prompt)
  implicit integer (a - z)
  byte file(1), ans(2), termc, tfile(MAXLINE), filist(MAXLINE)
  logical prompt, islist, inbrak, wild
  byte cupper
  include "default.cmn"

  if (nselec == 0) {
    ip = 0
    call scopy(file, 1, filist, 1)
    nfile = 0
    islist = .false.
    }

  repeat {
    if (nfile == 0) {
      inbrak = .false.
      for (j = ip+1; filist(j) ~= EOS  &  (inbrak | filist(j) ~= ','); j = j+1)
	if (filist(j) == '[')
	  inbrak = .true.
	else if (filist(j) == ']')
	  inbrak = .false.
      if (filist(j) == ',')
	islist = .true.			# this is a list of file names
      do i = ip+1, j
	file(i-ip) = filist(i)
      file(j-ip) = EOS
      ip = j
      if (file(1) == '@')  		# Indirect file name?
	namtyp = INDIRECTNAME
      else {
        call scopy (file, 1, tfile, 1)
	tfile(bkscan(tfile, '/', 1)) = EOS
	call defnam(tfile, node, dev, uic, name, ext, .true.)
	call concat(tfile, file(bkscan(file, '/', 1)), MAXLINE)
	namtyp = SIMPLENAME
        if (wild(tfile)) {		# wild card or switch?
WLD       namtyp = WLDNAME
WLD	  call scopy (tfile, 1, file, 1)
	  }
	}
      }
    nc = 0
    if (namtyp == SIMPLENAME  &  ~islist)
      nfile = 1 - nfile
    else {
      repeat {
	if (namtyp == WLDNAME) {
	  if (nfile == 0) {
WLD         call fndfil(FINDFILE, file, tfile, nfile)
	    if (nfile == 0) {
	      call scopy('LIST -- ERROR OPENING ', 1, tfile, 1)
	      i = concat(tfile, file, MAXLINE)
	      call ttput(tfile, i)
	      }
	    }
	  else
WLD         call fndfil(FINDFILE, file, tfile, nfile)
	  }
	else if (namtyp == INDIRECTNAME)
	  call readf(FINDFILE, file, tfile, nfile)
	else {
	  nfile = 1 - nfile
	  call scopy(file, 1, tfile, 1)
	  }
	if (nfile > 0) {
	  call scopy(tfile, 1, file, 1)
	  if (prompt)
	    if (ans(1) ~= 'G') {
	      repeat {
		call readpr(TT$IN, file, ans, nc, 2, termc)
		} until (nc == EOF  |  nc >= 0)
	      ans(1) = cupper(ans(1))
	      }
	    else
	      call ttput(file, length(file))
	  }
	} until (nfile <= 0  |  nc == EOF  |  ans(1) == 'G'  |
		 (nc > 0  &  ans(1) == 'Y')  |  ~prompt)
      }
    } until (nfile > 0  |  filist(ip) == EOS  |  nc == EOF)
  getfil = nfile > 0  &  nc ~= EOF
  if (getfil) {
    nselec = nselec + 1
    if (namtyp != WLDNAME) {
      call scopy (file, 1, tfile, 1)
      call defnam(tfile, node, dev, uic, name, ext, .true.)
      }
    }
  if (nc == EOF)
    close(unit=FINDFILE)
  return
  end

# wild - return true if file name contains wild card characters or switches
  logical function wild(file)
  byte file(1)
  integer bkscan
 
_ifdef(VAX)
  if (file(bkscan(file, '/*%', 1)) != EOS)
    return(.true.)
  else {			# look for ...
    ndots = 0
    for (i = 1; file(i) != EOS  &  ndots < 3; i = i+1)
      if (file(i) == '.')
        ndots = ndots+1
      else
        ndots = 0
    if (ndots == 3)
      return(.true.)
    }
_elsedef
  if (file(bkscan(file, '/*?', 1)) != EOS)
    return(.true.)
_enddef
  return(.false.)
  end
 
# readf - read in file names from indirect file
subroutine readf(f, file, outfil, nselec)
integer f, nselec, nc
byte file(1), outfil(1)
_ifdef(VAX)
  external gpopen
_enddef
 
if (nselec == 0) {
  call defnam(file(2), EOS, DEFAULT$DISK, EOS, EOS, DEFAULT$COMMAND, .false.)
  close(unit=f)
  open(unit=f, name=file(2), type='old', readonly, shared, err=10 _
_ifdef(VAX)
    , useropen=gpopen _
_enddef
    )
  }
repeat
  call get(f, outfil, MAXLINE-1, nc)
  until (nc ~= 0)
if (nc < 0) {
  nselec = 0
  close(unit=f)
  }
else {
  nselec = nselec+1
  outfil(nc+1) = EOS
  }
return
 
10 continue
call err(file, 2, "Can't open file.")
return
end
 
# opndef - find and open file for reading using defaults in file name
  logical function opndef(lun, file, ans, nselec, prompt)
  implicit integer (a - z)
_ifdef(VAX)
  external gpopen
_enddef
  byte file(1), ans(1), file1(MAXLINE)
  logical prompt, getfil
  include clist.cmn
  include "default.cmn"


  repeat {
    if (getfil(file, ans, nselec, prompt)) {


# try opening file with defaults applied

      call scopy (file, 1, file1, 1)
      call defnam (file, node, dev, uic, name, ext, .false.)
RECORDIO    open(unit=lun, name=file, type='old', readonly, shared, err=10,
RECORDIO _ifdef(VAX)
RECORDIO         blocksize=5120,
RECORDIO         useropen=gpopen)
RECORDIO _elsedef
RECORDIO         blocksize=2048)
RECORDIO _enddef
BLOCKIO     call bopen(lun, file, 'R', ier)
BLOCKIO     if (ier ~= 0)
BLOCKIO       goto 10
      goto 30


# now try file name as is, with DEFAULT$DISK and . as
# default device and extension

10    continue
      call defnam(file1, EOS, DEFAULT$DISK, EOS, EOS, '.', .false.)
RECORDIO    open(unit=lun, name=file1, type='old', readonly, shared, err=20,
RECORDIO _ifdef(VAX)
RECORDIO         blocksize=5120,
RECORDIO         useropen=gpopen)
RECORDIO _elsedef
RECORDIO         blocksize=2048)
RECORDIO _enddef
BLOCKIO     call bopen(lun, file1, 'R', ier)
BLOCKIO     if (ier ~= 0)
BLOCKIO       goto 20
      node(1) = EOS; dev(1) = EOS; uic(1) = EOS; name(1) = EOS; ext(1) = EOS
      call defnam(file1, node, dev, uic, name, ext, .true.)    # reset defaults
      call scopy (file1, 1, file, 1)		# return full file name

30    continue				# got one!
      call gftyp(lun, cc)
      return(.true.)


# here if unable to open a file

20    continue
      call scopy('LIST -- ERROR OPENING ', 1, file1, 1)
      i = concat(file1, file, MAXLINE)
      call ttput(file1, i)
      }
    else
      return(.false.)
    }					# go try next file
  end

# redir - redirect output from LIST
integer function redir(fout, comand)
integer fout, j, ftmp
integer chscan
byte comand(1)
byte node(NODESIZE), dev(DEVSIZE), uic(UICSIZE), name(NAMESIZE), ext(EXTSIZE)
logical append
_ifdef(VAX)
  external gpcre8
_enddef
include clist.cmn
data node(1)/EOS/, dev(1)/EOS/, uic(1)/EOS/, name(1)/EOS/, ext(1)/EOS/
 
j = 1
if (chscan(comand, j, REDIRECT) == YES) {		# file redirection
  append = .false.
  ftmp = FILE$OUT
  if (comand(j+1) == REDIRECT) {
    append = .true.
    j = j+1
    }
  if (fout == ftmp) {			# fout already redirected?
    call err(comand, j, 'Output is already redirected.')
    return(ERROR)
    }
  if (comand(j+1) == EOS) {
    if (dev(1) == EOS) goto 10
    call defnam(comand(j+1), node, dev, uic, name, ext, .false.)
    }
  else
    call defnam(comand(j+1), EOS, DEFAULT$DISK, EOS, EOS, DEFAULT$EXT, .false.)
  if (append) {	 	# need three open statements to get the proper
			# carriagecontrol when file is nonexistent.
    if (cc == LIST)
      open(unit=ftmp, name=comand(j+1), type='unknown', access='append',
RECORDIO            blocksize=1024,
_ifdef(VAX)
	   useropen=gpcre8,
_enddef
           carriagecontrol='list', recordsize=524, err=10)
    else if (cc == FORTRAN)
      open(unit=ftmp, name=comand(j+1), type='unknown', access='append',
RECORDIO            blocksize=1024,
_ifdef(VAX)
	   useropen=gpcre8,
_enddef
           carriagecontrol='fortran', recordsize=524, err=10)
    else
      open(unit=ftmp, name=comand(j+1), type='unknown', access='append',
RECORDIO            blocksize=1024,
_ifdef(VAX)
	   useropen=gpcre8,
_enddef
           carriagecontrol='none', recordsize=524, err=10)
    comand(j-1) = EOS
    }
  else {
    if (cc == LIST)
      open(unit=ftmp, name=comand(j+1), type='new',
RECORDIO            blocksize=1024,
_ifdef(VAX)
	   useropen=gpcre8,
_enddef
           carriagecontrol='list', recordsize=524, err=10)
    else if (cc == FORTRAN)
      open(unit=ftmp, name=comand(j+1), type='new',
RECORDIO            blocksize=1024,
_ifdef(VAX)
	   useropen=gpcre8,
_enddef
           carriagecontrol='fortran', recordsize=524, err=10)
    else
      open(unit=ftmp, name=comand(j+1), type='new',
RECORDIO            blocksize=1024,
_ifdef(VAX)
	   useropen=gpcre8,
_enddef
           carriagecontrol='none', recordsize=524, err=10)
    comand(j) = EOS
    }
  fout = ftmp
  call gftyp(fout, outcc)
  call defnam(comand(j+1), node, dev, uic, name, ext, .true.) # reset defaults
  }
return(YES)
 
10 continue
call err(comand, j+1, "Can't open file.")
return(ERROR)
end
 
define(HDRSIZE,FILENAMESIZE+32)
# puthdr - put out LIST file name header to output file
subroutine puthdr(f, file)
integer f, fcc, l1, l2, i
byte file(1), hdr(HDRSIZE)
byte listcc(2), fortcc(2), nonecc(4)
integer concat
byte cupper
data listcc/FF, EOS/,
     fortcc/'1', EOS/,
     nonecc/CR,
            LF,
            FF,
            EOS/
 
call gftyp(f, fcc)		# get carriagecontrol type
hdr(1) = EOS
if (fcc == LIST)
  l1 = concat(hdr, listcc, HDRSIZE)
else if (fcc == FORTRAN)
  l1 = concat(hdr, fortcc, HDRSIZE)
else
  l1 = concat(hdr, nonecc, HDRSIZE)
l1 = concat(hdr, '# LIST  ', HDRSIZE)
l2 = concat(hdr, file, HDRSIZE)
do i = l1, l2
  hdr(i) = cupper(hdr(i))
for (i = l2+1; i <= l1+33; i = i+1)
  hdr(i) = ' '
hdr(i) = ' '; hdr(i+1) = ' '
i = i+2
call date(hdr(i))
hdr(i+9) = ' '; hdr(i+10) = ' ';
call time(hdr(i+11))
hdr(i+19) = LF
call put(f, hdr, i+19, ier)
return
end
 
# err - put out error message
subroutine err(comand, cp, msg)
integer cp, ier, j, k, l
integer length
byte comand(1), msg(1)
include term.cmn
 
j = mod(cp-1, scrwid) + 1
l = length(comand)
k = min0(cp + scrwid - j, l)
call ttput(comand, k)
encode(j, (t<j>,'^'), comand)
call ttput(comand, j)
if (k < l)
  call ttput(comand(k+1), l - k)
call ttput(msg, length(msg))
comand(cp) = ERROR
return
end

# ttput - put a line with carriagecontrol to the standard output file
#       - inefficient version for error messages, etc.
  subroutine ttput(buf, nch)
  include clist.cmn
  integer nch, ier
  byte buf(1), crlf(2)
  data crlf /CR, LF/

  ier = 0
  if (ttcc == NONE)
    call put(TT$OUT, crlf, 2, ier)
  if (ier == 0)
    call put(TT$OUT, buf, nch, ier)
  return
  end