REM Program Findcode v1.5a for Morutl Version v57.0a

Rem $Include: 'qbx.bi'
REM $INCLUDE: 'const.inc'
COMMON SHARED Routines() AS STRING
Max.Routines=1024
REDIM Routines(Max.Routines) AS STRING
Dim InregsX As RegTypeX
Dim OutRegsX As RegTypeX
COLOR 15, 0
PRINT "Subroutine finder v1.5a:"
CommandLine$ = COMMAND$
IF LEFT$(UCASE$(CommandLine$), 2) = "/D" THEN
   Write.Data.File = True
   CommandLine$ = MID$(CommandLine$, 3)
END IF
IF CommandLine$ = "/?" OR CommandLine$ = "-?" THEN
   COLOR 14, 0
   PRINT "Finds subroutines in basic source files;"
   PRINT "Specify subroutine to find on command line."
   PRINT "Precede variable with /D to write to disk."
   PRINT "Do not prefix 'Sub'. Also imbed ? for wildcard"
   PRINT "character replacement."
   COLOR 7, 0
   END
END IF
IF CommandLine$ = Nul THEN
   COLOR 15, 0
   PRINT "Enter subroutine name";
   INPUT CommandLine$
   If CommandLine$ = "" Then
      End
   Endif
END IF
IF LEFT$(LCASE$(CommandLine$), 4) = "sub " THEN
   COLOR 14, 0
   PRINT "Do not prefix 'sub ' for search."
   COLOR 7, 0
   END
END IF
IF INSTR(CommandLine$, "?") THEN
   PRINT "Use wildcards(y/n)? ";
   LOCATE , , 1
   DO
      Var$ = INKEY$
      IF LEN(Var$) THEN
         SELECT CASE LCASE$(Var$)
         CASE "y"
            PRINT "y"
            Wildcard = True
            EXIT DO
         CASE "n"
            PRINT "n"
            Wildcard = False
            EXIT DO
         END SELECT
      END IF
      Gosub TimeSlice
   LOOP
END IF
Search$ = "Sub " + CommandLine$
COLOR 15, 0
PRINT "Finding: "; CHR$(34);
COLOR 14, 0
PRINT Search$;
COLOR 15, 0
PRINT CHR$(34); " ";
IF Wildcard THEN
   PRINT "    ";
END IF
VarF! = TIMER
CommandLine$ = LTRIM$(CommandLine$)
CommandLine$ = RTRIM$(CommandLine$)
CommandLine$ = "sub " + CommandLine$
CommandLine$ = LCASE$(CommandLine$)
Length = LEN(CommandLine$)
FileSpec$ = "*.bas"
Filename$ = DIR$(FileSpec$)
WHILE LEN(Filename$)
   Total.Files = Total.Files + 1
   Filename$ = DIR$
WEND
If Total.Files = 0 Then
   Color 14, 0
   Print "No search files found."
   Color 7, 0
   End
Endif
FileSpec$ = "*.bas"
Filename$ = DIR$(FileSpec$)
WHILE LEN(Filename$)
   IF INKEY$ = CHR$(27) THEN
      COLOR 7, 0
      PRINT
      PRINT "Exiting to system:"
      END
   END IF
   CLOSE #1
   OPEN Filename$ FOR INPUT AS #1
   Current.File = Current.File + 1
   GOSUB Dot.Display
   DO WHILE NOT EOF(1)
      LINE INPUT #1, InputLine$
      IF INSTR(InputLine$, "(") THEN
         InputLine$ = RTRIM$(LEFT$(InputLine$, INSTR(InputLine$, "(") - 1))
      END IF
      InputLine$ = LTRIM$(LCASE$(InputLine$))
      VarX = False
      IF LEFT$(InputLine$, 4) = "sub " THEN
         IF WildCard THEN
            GOSUB CheckWildcard
            IF Match THEN
               VarX = True
            END IF
         ELSE
            IF InputLine$ = CommandLine$ THEN
               VarX = True
            END IF
         END IF
      END IF
      IF VarX THEN
         Routine1 = Routine1 + 1
         IF Routine1 > Max.Routines THEN
            Max.Routines = Max.Routines + 64
            REDIM PRESERVE Routines(Max.Routines) AS STRING
         END IF
         Routines(Routine1) = Filename$
         EXIT DO
      END IF
   LOOP
   Filename$ = DIR$
WEND
PRINT
IF Routine1 > 1 THEN
   FOR Sort1 = 1 TO Routine1
      FOR Sort2 = Sort1 + 1 TO Routine1
         IF Routines(Sort1) > Routines(Sort2) THEN
            SWAP Routines(Sort1), Routines(Sort2)
         END IF
      NEXT
   NEXT
END IF
COLOR 15, 0
SELECT CASE Routine1
CASE 0
   PRINT "No Subroutines found."
CASE 1
   PRINT "Total of 1 subroutine found."
CASE ELSE
   PRINT "Total of"; Routine1; "subroutines found."
END SELECT
Page = 1
COLOR 14, 0
IF Routine1 > False THEN
   IF Write.Data.File THEN
      CLOSE #1
      OPEN "OUTPUT.LST" FOR Append AS #1
      PRINT #1, "Results for: " + CommandLine$
   END IF
   FOR Var = 1 TO Routine1
      Filename$ = Routines(Var)
      Filename$ = Filename$ + SPACE$(15 - LEN(Filename$))
      IF Write.Data.File THEN
         PRINT #1, Filename$;
      ELSE
         PRINT Filename$;
      END IF
      Line1 = Line1 + 1
      IF Line1 = 5 THEN
         IF Write.Data.File THEN
            PRINT #1, ""
         ELSE
            PRINT
            Page = Page + 1
            IF Page = 23 THEN
               Page = False
               COLOR 15, 0
               PRINT "More:";
               WHILE INKEY$ = Nul
                  Gosub TimeSlice
               WEND
               PRINT
               COLOR 14, 0
            END IF
         END IF
         Line1 = False
      END IF
   NEXT
END IF
IF Write.Data.File THEN
   Print #1,Chr$(13)+Chr$(10)
   PRINT "Data written to 'output.lst'"
END IF
COLOR 7, 0
PRINT
PRINT "Exiting to system:"
END

Dot.Display:
 IF Wildcard THEN
    Percent! = (Current.File / Total.Files) * 100!
    Percent! = INT(Percent!)
    FOR Imbedded = 1 TO 4
       PRINT CHR$(29); " "; CHR$(29);
    NEXT
    PRINT RIGHT$(STR$(Percent! + 1000!), 3) + "%";
    RETURN
 END IF
 VarG! = TIMER - VarE!
 IF VarG! < SFalse THEN
    VarG! = Elapsed.Time! + 86400!
 END IF
 IF VarG! >= 1! THEN
    VarE! = TIMER
    IF VarD = False THEN
       VarC = VarC + 1
       PRINT ".";
       IF VarC = 5 THEN
          VarD = True
          VarC = False
       END IF
    ELSE
       VarC = VarC + 1
       LOCATE CSRLIN, POS(0) - 1, 0
       PRINT " ";
       LOCATE CSRLIN, POS(0) - 1, 1
       IF VarC = 5 THEN
          VarD = False
          VarC = False
       END IF
    END IF
 END IF
 RETURN

CheckWildcard:
 Match = False
 Length1 = LEN(CommandLine$)
 FOR I1 = 1 TO LEN(InputLine$)
    S$ = MID$(InputLine$, I1)
    S$ = LEFT$(S$, Length1)
    IF LEN(S$) <> Length1 THEN
       EXIT FOR
    END IF
    ' compare search string to wildcard
    VarQ = True
    FOR I2 = 1 TO Length1
       IF MID$(CommandLine$, I2, 1) <> "?" THEN
          IF MID$(CommandLine$, I2, 1) <> MID$(S$, I2, 1) THEN
             VarQ = False
             EXIT FOR
          END IF
       END IF
    NEXT
    IF VarQ THEN
       Match = True
       EXIT FOR
    END IF
 NEXT
 RETURN

TimeSlice:
 InregsX.AX=&H1680
 InregsX.BX=&H0000
 Call InterruptX(&H2F,InregsX,OutregsX)
 Return
