'
' Program to display or print a directory of font files
' including details from the font headers.
'
' Written by Keith Baines in HiSoft Basic.
' January 1990
'
' Slightly altered to allow "Printing" to a disc file.
' Altered options to allow BASIC2 compilation
' John Watkins February 1992

REM $OPTION R32			'A large stack for QSORT
DEFINT A-Z
LIBRARY "GEMDOS"

DIM SHARED DTA(21)			'Buffer for GEMDOS fsfirst/fsnext calls
COMMON SHARED Printer

CONST TRUE=-1
CONST FALSE=0

CommandParse

temp$ = FNGetToken$(1)
SELECT CASE temp$
CASE "-P"
   OPEN "LST:" FOR OUTPUT AS #2
   Printer=TRUE
CASE "-F"
		File=TRUE
		Printer=TRUE
CASE	ELSE
  	OPEN "CON:" FOR OUTPUT AS #2
   	Printer=FALSE
END SELECT

BANNER

IF COMMAND$="" THEN
   Usage
   GetKey
   STOP -1
END IF

GetFont FontPath$,FontName$

IF FontName$="" THEN FontName$="*.FNT"

CALL Init_DTA
Get_Files FontPath$+FontName$

IF Num_Files<=0 THEN
   PRINT "No matching files for ";FontPath$+FontName$
   PRINT
   GetKey
ELSE
   GetFontData FontPath$,FontName$
   CALL QSORT
   IF file=TRUE
			OPEN FontPath$+"font_dir.lst" FOR OUTPUT AS #2
	 END IF
   Show FontPath$,FontName$
END IF
Reset_DTA
STOP -1


'
' Set DTA to internal buffer for use with fsfirst/fsnext calls
'
SUB Init_DTA
   SHARED Old_DTA&,Our_DTA&
   Old_Dta&=FNfgetdta&
   Our_DTA&=VARPTR(DTA(0))
   fsetdta Our_DTA&
END SUB


'
' Restore GEMDOS's original DTA address
'
SUB Reset_DTA
   SHARED Old_DTA&
   fsetdta Old_DTA&
END SUB


'
' Get the font path and file name from the command line
'
SUB GetFont(P$,N$)
   LOCAL T$,L

   T$=FNGetToken$(0)
   L=LEN(T$)

   IF L=0 THEN
      P$=""
      N$=""
      EXIT SUB
   END IF

   DO UNTIL INSTR("\:",MID$(T$,L,1))
      DECR L
   LOOP WHILE L>0
   
   N$=MID$(T$,L+1)
   IF L>0 THEN
      P$=LEFT$(T$,L)
   ELSE
      P$=""
   END IF
END SUB


'
' Return the Ith command line token
'
DEF FNGetToken$(I)
   SHARED C__Tokens$(),N__Tokens
   IF I>N__Tokens THEN
      FNGetToken$=""
   ELSE
      FNGetToken$=C__Tokens$(I)
   END IF
END DEF


'
' Split the command line into space or comma delimited tokend
'
SUB CommandParse
   SHARED C__Tokens$(),N__Tokens
   LOCAL I,L,C$
   DIM C__Tokens$(10)
   
   L=LEN(COMMAND$)

   I=0
   N__Tokens=0
   C__Tokens$(0)=""
   
   FOR I=1 TO L
      C$=MID$(COMMAND$,I,1)
      IF C$="," THEN
         INCR N__Tokens
         C__Tokens$(N__Tokens)=""
      ELSEIF C$=" " THEN
         IF C__Tokens$(N__Tokens)<>"" THEN
            INCR N__Tokens
            C__Tokens$(N__Tokens)=""
         END IF
      ELSE
         C__Tokens$(N__Tokens)=C__Tokens$(N__Tokens)+C$
      END IF
      IF N__Tokens=10 THEN EXIT FOR
   NEXT I
   
END SUB
         
   
'
' Find all files matching Template$
'
SUB Get_Files(Template$)
   SHARED Num_Files,Max_Files,Files$(),File_size&(),File_Date$(),File_Time$()
   LOCAL RC

   PRINT " Scanning Directory ...."
   Max_Files=100
   Num_Files=0
   DIM Files$(Max_Files),File_Size&(Max_Files), _
       File_Date$(Max_Files),File_Time$(Max_Files)

   RC=FNfsfirst(Template$,0)
   DO WHILE RC=0
      Files$(Num_Files)=FNGetName$
      File_Size&(Num_Files)=FNGetSize&
      File_Date$(Num_Files)=FNGetDate$
      File_Time$(Num_Files)=FNGetTime$
      INCR Num_Files
      IF Num_Files>Max_Files THEN
         Max_Files=Max_Files+100
         REDIM APPEND Files$(Max_Files),File_Size&(Max_Files), _
                      File_Date$(Max_Files),File_Time$(Max_Files)
      END IF
      RC=FNfsnext
   LOOP
END SUB


'
' Copy file name from the DTA as a Basic string
'
DEF FNGetName$
   SHARED Our_DTA&
   LOCAL N$,P&,I,B
   P&=Our_DTA&+30
   N$=""
   FOR I=1 TO 14
      B=PEEKB(P&)
      IF B=0 THEN EXIT FOR
      N$=N$+CHR$(B)
      INCR P&
   NEXT I
   FNGetName$=N$
END DEF


'
' Copy file size from the DTA
'
DEF FNGetSize&
   SHARED Our_DTA&
   SHARED Our_DTA&
   FNGetSize&=PEEKL(Our_DTA&+26)
END DEF


'
' Copy file date from the DTA
'
DEF FNGetDate$
   SHARED Our_DTA&
   LOCAL T&,Y,M,D
   T&=PEEKL(Our_DTA&+22) AND &HFFFF&
   Y=80&+(T& AND &H0FE00)\512&
   M=(T& AND &H001E0)\32&
   D=(T& AND &H0001F)
   FNGetDate$=FNDigits$(D)+"/"+FNDigits$(M)+"/"+FNDigits$(Y)
END DEF
   

'
' COpy file time from the DTA
'
DEF FNGetTime$
   SHARED Our_DTA&
   LOCAL T&,H,M
   T&=PEEKL(Our_DTA&+20) AND &HFFFF&
   H=(T& AND &H0F100)\2048&
   M=(T& AND &H007E0)\32&
   FNGetTime$=FNDigits$(H)+":"+FNDigits$(M)
END DEF

DEF FNDigits$(I)=RIGHT$("00"+MID$(STR$(I),2),2)


'
' Read font file headers
'
SUB GetFontData(Path$,Name$)
   SHARED Num_Files,Files$()
   SHARED Font_ID(),Font_name$(),Font_size(),Font_first(),Font_last()
   LOCAL I,N$,P$,NAM$,F$,L$,T$,L
   
   DIM Font_ID(Num_Files),Font_size(Num_Files),Font_name$(Num_Files), _
       Font_first(Num_Files),Font_last(Num_Files)

   PRINT " Reading Font Data ...."
   FOR I=0 TO Num_Files-1
      OPEN Path$+Files$(I) FOR RANDOM AS #1 LEN=40
      FIELD #1,2 AS N$,2 AS P$,32 AS NAM$,2 AS F$,2 AS L$
      GET #1,1
      IF EOF(1) THEN
         Font_ID(I)=0
         Font_name$(I)="*** Not a Font File! ***"
         Font_first(I)=0
         Font_last(I)=0
      ELSE
         Font_ID(I)=FNIntel(N$)
         T$=NAM$
         L=INSTR(T$,CHR$(0))
         IF L=0 THEN L=32
         Font_name$(I)=LEFT$(T$,L)
         Font_size(I)=FNIntel(P$)
         Font_first(I)=FNIntel(F$)
         Font_last(I)=FNIntel(L$)
      END IF
      CLOSE #1
   NEXT I
END SUB


'
' Print or display font file details
'
SUB Show(Path$,Name$)
   SHARED Num_Files,Files$(),File_Size&(),File_Date$(),File_Time$()
   SHARED Font_ID(),Font_name$(),Font_size(),Font_first(),Font_last()
   LOCAL I,T$
   
   IF Printer THEN
      PRINT " Printing ...."
   ELSE
      CLS
   END IF

   FOR I=0 TO Num_Files-1

      IF (I MOD 20)=0 THEN
         IF I<>0 THEN
            IF NOT Printer THEN
               LOCATE 25,1
               PRINT " === More ===";
               WHILE INKEY$="":WEND
               LOCATE 25,1
               PRINT CHR$(27)+"K";
               Header Path$+Name$+"  Screen "+STR$(1+I\20)
            END IF
         ELSE
            Header Path$+Name$
         END IF
      END IF

      T$=Files$(I)
      IF INSTR(T$,".")>0 THEN
         T$=LEFT$(T$,INSTR(T$,".")-1)
      END IF
      PRINT #2, " ";T$ TAB(10)
      PRINT #2, USING "#######";File_Size&(I);
      PRINT #2, TAB(18);File_Date$(I);TAB(27);File_Time$(I);
      
      PRINT #2, TAB(33)
      PRINT #2, USING "#####";Font_ID(I);
      PRINT #2, USING "#####";Font_size(I);
      PRINT #2, TAB(44) LEFT$(Font_name$(I),27) TAB(71)
      PRINT #2, USING "####";Font_first(I);
      PRINT #2, USING "#####";Font_last(I)
      
   NEXT I
   IF NOT Printer THEN
      PRINT
      GetKey
   END IF
   PRINT #2
   
END SUB

'
' Wait for a key press
'
SUB GetKey
   PRINT " === Press any key ===";
   WHILE INKEY$="":WEND
END SUB



SUB BANNER
   PRINT " FONT_DIR  --  a PD utility by Keith Baines  --   January 1990"
END SUB

'
' Print usage message
'
SUB Usage
   PRINT
   PRINT " USAGE:    FONT_DIR <path\>[template] [-P|-F]"
   PRINT
   PRINT " EXAMPLE:  FONT_DIR B:\GDOS.SYS\AT*.FNT"
   PRINT
   PRINT " FLAGS:    -P directs output to the printer"
   PRINT "           -F sends output to 'FONT_DIR.LST'"
   PRINT
   PRINT
END SUB

'
' Print/display page/screen header
'
SUB Header(H$)
   PRINT #2,
   PRINT #2, " ";H$
   PRINT #2,
   PRINT #2, " File      Bytes     Date  Time";
   PRINT #2, "    ID Size Font Name                   1st Last"
   PRINT #2, " ======== ====== ======== =====";
   PRINT #2, " ===== ==== =========================== === ===="
END SUB

      
'
' Swap byte order of an integer (Intel to/from Motorola format)
'
DEF FNIntel(C$)
   IF LEN(C$)<>2 THEN
      FNIntel=-1
   ELSE
      FNIntel=CVI(RIGHT$(C$,1)+LEFT$(C$,1))
   END IF
END DEF



' Recursive Quick Sort (Adapted from K & P S/W Tools in Pascal)


SUB QSORT
   SHARED Num_Files
	LOCAL I
	PRINT " Sorting ...."
	CALL RQUICK(0,Num_Files-1)
END SUB 'QSORT

SUB RQUICK(LO,HI)
   LOCAL I,J,PIVOT
   IF LO<HI THEN
      I=LO
      J=HI
      PIVOT=J
      DO
         WHILE (I<J) AND FNCompare(I,PIVOT)<=0
            INCR I
         WEND
         WHILE (J>I) AND FNCompare(J,PIVOT)>=0
            DECR J
         WEND
         IF (I<J) THEN
            CALL Exchange(I,J)
         END IF
      LOOP UNTIL I>=J

      CALL Exchange(I,HI)

      IF (I-LO) < (HI-J) THEN
         CALL RQUICK(LO,I-1)
         CALL RQUICK(I+1,HI)
      ELSE
         CALL RQUICK(I+1,HI)
         CALL RQUICK(LO,I-1)
      END IF
   END IF
END SUB 'RQUICK
						
DEF FNCompare(I,J)
   SHARED Files$(),File_Size&()
   SHARED Font_ID(),Font_name$(),Font_size()
   STATIC S
   
   S=SGN(Font_ID(I)-Font_ID(J))
   IF S=0 THEN S=SGN(Font_size(I)-Font_size(J))
   IF S=0 THEN S=SGN(File_Size&(I)-File_Size&(J))
   IF S=0 THEN
      IF Font_name$(I)<Font_name$(J) THEN
         S=-1
      ELSEIF Font_name$(I)>Font_name$(J) THEN
         S=1
      END IF
   END IF
   IF S=0 THEN
      IF Files$(I)<Files$(J) THEN
         S=-1
      ELSEIF Files$(I)>Files$(J) THEN
         S=1
      END IF
   END IF

   
   FNCompare=S
END DEF

SUB Exchange(I,J)
   SHARED Num_Files,Files$(),File_Size&(),File_Date$(),File_Time$()
   SHARED Font_ID(),Font_name$(),Font_size(),Font_first(),Font_last()
   SWAP Files$(I),Files$(J)
   SWAP File_Size&(I),File_Size&(J)
   SWAP File_Date$(I),File_Date$(J)
   SWAP File_Time$(I),File_Time$(J)
   SWAP Font_ID(I),Font_ID(J)
   SWAP Font_name$(I),Font_name$(J)
   SWAP Font_size(I),Font_size(J)
   SWAP Font_first(I),Font_first(J)
   SWAP Font_last(I),Font_last(J)
   
END SUB