Date: 02-16-2022
Return to Index
created by gbSnippets
'Compilable Example: (Jose Includes)
#Compiler PBWin 9, PBWin 10
#Compile EXE
#Dim All
%Unicode=1
#Include "Win32API.inc"
Global hDlg As Dword
Function PBMain() As Long
Local Style&
Style& = %WS_Child Or %WS_Visible Or %ES_MultiLine Or %WS_VScroll Or %ES_AutoHScroll _
Or %WS_HScroll Or %ES_AutoVScroll Or %ES_WantReturn Or %ES_NoHideSel Or %WS_TabStop
Dialog New Pixels, 0, "Test Code",300,300,400,400, %WS_OverlappedWindow To hDlg
Control Add Button, hDlg, 100,"Slow", 30,10,100,20
Control Add Button, hDlg, 101,"Fast", 150,10,100,20
Control Add Button, hDlg, 102,"Fastest", 270,10,100,20
Control Add TextBox, hDlg, 150, Repeat$(10,SampleCode), 20,40,350,350, Style&
Dialog Show Modal hDlg Call DlgProc
End Function
CallBack Function DlgProc() As Long
Local i, iStart As Long, temp$
Select Case Cb.Msg
Case %WM_Command
Select Case Cb.Ctl
Case 100
iStart = GetTickCount
For i = 0 To 1000
Control Get Text hDlg, 150 To temp$
slowBuildProcedureList(temp$)
Next i
? Format$((GetTickCount - iStart)/1000,3) & " seconds"
Case 101
iStart = GetTickCount
For i = 0 To 1000
Control Get Text hDlg, 150 To temp$
fastBuildProcedureList(temp$)
Next i
? Format$((GetTickCount - iStart)/1000,3) & " seconds"
Case 102
iStart = GetTickCount
For i = 0 To 1000
Control Get Text hDlg, 150 To temp$
GetProcNames2(temp$)
Next i
? Format$((GetTickCount - iStart)/1000,3) & " seconds"
End Select
End Select
End Function
Function slowBuildProcedureList(ProcListBuf As String) As String
Local i As Long, tmp$, w1$, w2$, w3$, w4$, r$
Dim BufArray(ParseCount(ProcListBuf,$CrLf)-1) As String 'break input string into an array
Parse ProcListBuf, BufArray(), $CrLf
For i = 0 To UBound(BufArray)
tmp$ = LTrim$(Retain$(BufArray(i), Any Chr$(65 To 90, 95, 97 To 122, 48 To 57, $Spc, "()=")))
Replace Any "()" With " " In tmp$
While InStr(tmp$, " ") : Replace " " With " " In tmp$ : Wend 'remove all pairs of spaces
w1$ = Parse$(tmp$," ",1) : w2$ = Parse$(tmp$," ",2) : w3$ = Parse$(tmp$," ",3) : w4$ = Parse$(tmp$," ",4)
If LCase$(w1$+" "+w2$+" "+w3$) = "override property get" Then r$=r$+$CrLf+w4$ : Iterate For
If LCase$(w1$+" "+w2$+" "+w3$) = "override property set" Then r$=r$+$CrLf+w4$ : Iterate For
If LCase$(w1$+" "+w2$) = "macro function" Then r$=r$+$CrLf+w3$ : Iterate For
If LCase$(w1$+" "+w2$) = "callback function" Then r$=r$+$CrLf+w3$ : Iterate For
If LCase$(w1$+" "+w2$) = "thread function" Then r$=r$+$CrLf+w3$ : Iterate For
If LCase$(w1$+" "+w2$) = "class method" Then r$=r$+$CrLf+w3$ : Iterate For
If LCase$(w1$+" "+w2$) = "override method" Then r$=r$+$CrLf+w3$ : Iterate For
If LCase$(w1$+" "+w2$) = "property get" Then r$=r$+$CrLf+w3$ : Iterate For
If LCase$(w1$+" "+w2$) = "property set" Then r$=r$+$CrLf+w3$ : Iterate For
If LCase$(w1$) = "union" Then r$=r$+$CrLf+w2$ : Iterate For
If LCase$(w1$) = "macro" Then r$=r$+$CrLf+w2$ : Iterate For
If LCase$(w1$) = "sub" Then r$=r$+$CrLf+w2$ : Iterate For
If LCase$(w1$) = "function" And w2$ <> "=" Then r$=r$+$CrLf+w2$ : Iterate For
If LCase$(w1$) = "class" Then r$=r$+$CrLf+w2$ : Iterate For
If LCase$(w1$) = "method" And w2$ <> "=" Then r$=r$+$CrLf+w2$ : Iterate For
If LCase$(w1$) = "interface" Then r$=r$+$CrLf+w2$ : Iterate For
Next i
Function = Trim$(r$,$CrLf)
End Function
Function fastBuildProcedureList(ProcListBuf As String) As String
Local i As Long, tmp$, w1$, w2$, w3$, w4$, r$, s1$, s2$, s3$, s4$, s12$, s123$
Dim BufArray(ParseCount(ProcListBuf,$CrLf)-1) As String 'break input string into an array
Parse ProcListBuf, BufArray(), $CrLf
For i = 0 To UBound(BufArray)
tmp$ = LTrim$(Retain$(BufArray(i), Any Chr$(65 To 90, 95, 97 To 122, 48 To 57, $Spc, "()=")))
Replace Any "()" With " " In tmp$
While InStr(tmp$, " ") : Replace " " With " " In tmp$ : Wend 'remove all pairs of spaces
w1$ = Parse$(tmp$," ",1) : w2$ = Parse$(tmp$," ",2) : w3$ = Parse$(tmp$," ",3) : w4$ = Parse$(tmp$," ",4)
s1$ = LCase$(w1$) : s2$ = LCase$(w2$) : s3$ = Lcase$(w3$) : s4$ = LCase$(w4$)
s12$ = Build$(s1$," ",s2$) : s123$ = Build$(s1$," ",s2$," ",s3$)
If s1$ = "sub" Then r$=Build$(r$,$CrLf,w2$) : Iterate For
If s1$ = "function" And w2$ <> "=" Then r$=Build$(r$,$CrLf,w2$) : Iterate For
If s12$ = "callback function" Then r$=Build$(r$,$CrLf,w3$) : Iterate For
If s1$ = "macro" Then r$=Build$(r$,$CrLf,w2$) : Iterate For
If s12$ = "macro function" Then r$=Build$(r$,$CrLf,w3$) : Iterate For
If s12$ = "thread function" Then r$=Build$(r$,$CrLf,w3$) : Iterate For
If s1$ = "class" Then r$=Build$(r$,$CrLf,w2$) : Iterate For
If s1$ = "method" And w2$ <> "=" Then r$=Build$(r$,$CrLf,w2$) : Iterate For
If s12$ = "class method" Then r$=Build$(r$,$CrLf,w3$) : Iterate For
If s12$ = "override method" Then r$=Build$(r$,$CrLf,w3$) : Iterate For
If s1$ = "interface" Then r$=Build$(r$,$CrLf,w2$) : Iterate For
If s12$ = "property get" Then r$=Build$(r$,$CrLf,w3$) : Iterate For
If s12$ = "property set" Then r$=Build$(r$,$CrLf,w3$) : Iterate For
If s123$ = "override property get" Then r$=Build$(r$,$CrLf,w4$) : Iterate For
If s123$ = "override property set" Then r$=Build$(r$,$CrLf,w4$) : Iterate For
If s1$ = "union" Then r$=Build$(r$,$CrLf,w2$) : Iterate For
Next i
Function = Trim$(r$,$CrLf)
End Function
Sub fastestBuildProcedureList(ProcListBuf$)
Local i, pCount As Long, tmp$, w1$, w2$, w3$, w4$, r$, s1$, s2$, s3$, s4$, s12$, s123$
Dim MUser(1000) As String
Dim BufArray(ParseCount(ProcListBuf$,$CrLf)-1) As String 'break input string into an array
Parse ProcListBuf$, BufArray(), $CrLf
For i = 0 To UBound(BufArray)
tmp$ = LTrim$(Retain$(BufArray(i), Any Chr$(65 To 90, 95, 97 To 122, 48 To 57, $Spc, "()=")))
Replace Any "()" With " " In tmp$
While InStr(tmp$, " ") : Replace " " With " " In tmp$ : Wend 'remove all pairs of spaces
w1$ = Parse$(tmp$," ",1) : w2$ = Parse$(tmp$," ",2) : w3$ = Parse$(tmp$," ",3) : w4$ = Parse$(tmp$," ",4)
s1$ = LCase$(w1$) : s2$ = LCase$(w2$) : s3$ = Lcase$(w3$) : s4$ = LCase$(w4$)
s12$ = Build$(s1$, s2$) : s123$ = Build$(s1$, s2$, s3$)
If s1$ = "sub" Then MUser(pCount) = w2$ : Incr pCount : Iterate For
If s1$ = "function" And w2$ <> "=" Then MUser(pCount) = w2$ : Incr pCount : Iterate For
If s12$ = "callback function" Then MUser(pCount) = w3$ : Incr pCount : Iterate For
If s1$ = "macro" Then MUser(pCount) = w2$ : Incr pCount : Iterate For
If s12$ = "macro function" Then MUser(pCount) = w3$ : Incr pCount : Iterate For
If s12$ = "thread function" Then MUser(pCount) = w3$ : Incr pCount : Iterate For
If s1$ = "class" Then MUser(pCount) = w2$ : Incr pCount : Iterate For
If s1$ = "method" And w2$ <> "=" Then MUser(pCount) = w2$ : Incr pCount : Iterate For
If s12$ = "class method" Then MUser(pCount) = w3$ : Incr pCount : Iterate For
If s12$ = "override method" Then MUser(pCount) = w3$ : Incr pCount : Iterate For
If s1$ = "interface" Then MUser(pCount) = w2$ : Incr pCount : Iterate For
If s12$ = "property get" Then MUser(pCount) = w3$ : Incr pCount : Iterate For
If s12$ = "property set" Then MUser(pCount) = w3$ : Incr pCount : Iterate For
If s123$ = "override property get" Then MUser(pCount) = w4$ : Incr pCount : Iterate For
If s123$ = "override property set" Then MUser(pCount) = w4$ : Incr pCount : Iterate For
If s1$ = "union" Then MUser(pCount) = w2$ : Incr pCount : Iterate For
Next i
ReDim Preserve MUser(IIF(pCount>0, pCount-1, pCount))
End Sub
Function SampleCode() As String
Local temp$
'4 word possibilities
temp$ = temp$ + $CrLf + "Override Property Get myOPG"
temp$ = temp$ + $CrLf + "Override Property Set myOPS"
'3 word possibilities
temp$ = temp$ + $CrLf + "Macro Function myMacroFunction"
temp$ = temp$ + $CrLf + "CallBack Function myCallbackFunction"
temp$ = temp$ + $CrLf + "Thread Function myThreadFunction"
temp$ = temp$ + $CrLf + "Class Method myClassMethod"
temp$ = temp$ + $CrLf + "Override Method myOverrideMethod"
temp$ = temp$ + $CrLf + "Property Get myPropertyGet"
temp$ = temp$ + $CrLf + "Property Set myPropertySGet"
'2 word possibilities
temp$ = temp$ + $CrLf + "Union myUnion"
temp$ = temp$ + $CrLf + "Macro myMacro"
temp$ = temp$ + $CrLf + "Sub mySub"
temp$ = temp$ + $CrLf + "Function myFunction"
temp$ = temp$ + $CrLf + "Thread myThread" 'invalid
temp$ = temp$ + $CrLf + "Callback myCallback" 'invalid
temp$ = temp$ + $CrLf + "Class myClass"
temp$ = temp$ + $CrLf + "Method myMethod"
temp$ = temp$ + $CrLf + "Interface myInterface"
temp$ = temp$ + $CrLf + "Override myOverride" 'invalid
temp$ = temp$ + $CrLf + "Property myProperty" 'invalid
temp$ = temp$ + $CrLf + "Function=50" 'code should ignore
temp$ = temp$ + $CrLf + " Function = 10" 'code should ignore
temp$ = temp$ + $CrLf + "Method=50" 'code should ignore
temp$ = temp$ + $CrLf + " Method = 10" 'code should ignore
Function = Trim$(temp$,$CrLf)
End Function
MACRO AddLine(value)
IF cntProcs>=maxProcs THEN
maxProcs = maxProcs + 1000
REDIM PRESERVE procs(maxProcs)
END IF
procs(cntProcs)=value
INCR cntProcs
END MACRO
Sub GetProcNames1(value As String)
DIM maxProcs AS INTEGER
maxProcs=1000
DIM procs(maxProcs) As String
DIM cntProcs AS INTEGER
cntProcs = 0
DIM translate(255) AS STATIC BYTE
ARRAY ASSIGN translate() = _
0, 0, 0, 0, 0, 0, 0, 0, 0, 32, 0, 0, 0, 13, 0, 0 _
, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 _
, 32, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 _
, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 0, 0, 0, 61, 0, 0 _
, 0, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79 _
, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 0, 0, 0, 0, 95 _
, 0, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79 _
, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 0, 0, 0, 0, 0 _
, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 _
, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 _
, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 _
, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 _
, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 _
, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 _
, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 _
, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
REGISTER i AS INTEGER, p AS INTEGER
DIM t AS INTEGER
i=MAX(LEN(value)-13, 0): ' Forget last 13 characters
DIM v AS BYTE PTR, d AS BYTE PTR
v = STRPTR(value)
DIM dest As String
dest = STRING$(i,32)
d = STRPTR(dest)
DIM lastSpace AS INTEGER
DIM c AS BYTE
p = 0
DO WHILE i
DO
' Skip leading spaces
WHILE i AND translate(@v)<=32
DECR i
INCR v
WEND
' Only consider possible lines
IF INSTR("CFIMOPST",CHR$(translate(@v)))>0 THEN EXIT DO
' So find next carriage return
WHILE i AND translate(@v)<>13
DECR i
INCR v
WEND
LOOP WHILE i
IF i=0 THEN EXIT DO
' translate possible line
lastSpace=0
DO
c=translate(@v)
IF c=0 THEN
' Skip over rubbish
WHILE i AND translate(@v)<>13
DECR i
INCR v
WEND
c = 13
END IF
IF lastSpace AND c=32 THEN
c=0
ELSE
lastSpace = (c = 32)
END IF
IF c THEN
@d = c
INCR d
END IF
DECR i
INCR v
LOOP WHILE i AND c<>13
LOOP
value=RTRIM$(dest)
p = PARSECOUNT(value, $CR)
DIM iLines(p-1) As String
PARSE value, iLines(), $CR
FOR i=0 TO p-1
IF LEFT$(iLines(i), 9) = "CALLBACK " THEN
AddLine(iLines(i))
ITERATE FOR
END IF
IF LEFT$(iLines(i), 6) = "CLASS " THEN
AddLine(iLines(i))
ITERATE FOR
END IF
IF LEFT$(iLines(i), 9) = "Function " AND INSTR(iLines(i), "=")=0 THEN
AddLine(iLines(i))
ITERATE FOR
END IF
IF LEFT$(iLines(i), 10) = "INTERFACE " THEN
AddLine(iLines(i))
ITERATE FOR
END IF
IF LEFT$(iLines(i), 6) = "MACRO " THEN
AddLine(iLines(i))
ITERATE FOR
END IF
IF LEFT$(iLines(i), 7) = "METHOD " AND INSTR(iLines(i), "=")=0 THEN
AddLine(iLines(i))
ITERATE FOR
END IF
IF LEFT$(iLines(i), 9) = "OVERRIDE " THEN
AddLine(iLines(i))
ITERATE FOR
END IF
IF LEFT$(iLines(i), 9) = "PROPERTY " AND INSTR(iLines(i), "=")=0 THEN
AddLine(iLines(i))
ITERATE FOR
END IF
IF LEFT$(iLines(i), 4) = "SUB " THEN
AddLine(iLines(i))
ITERATE FOR
END IF
IF LEFT$(iLines(i), 7) = "THREAD " THEN
AddLine(iLines(i))
ITERATE FOR
END IF
NEXT
REDIM PRESERVE procs(cntProcs)
End Sub
Sub GetProcNames2(SOURCE As String)
DIM maxProcs As Long: ' Room we have for procs right now
DIM cntProcs As Long: ' Number of procs found
maxProcs=1000
cntProcs = 0
DIM procs(maxProcs) As String: ' List of found procs
DIM valid(6) As String: ' List of valid signatures
DIM pSource AS BYTE PTR: ' Pointer to incomming code string
DIM pValid AS BYTE PTR: ' Pointer to a line signature
DIM dest As String: ' Working buffer
DIM pDest AS BYTE PTR: ' Pointer to working buffer
REGISTER dstLen AS INTEGER: ' Length of line in working buffer
REGISTER p AS INTEGER: ' General variable
DIM firstStatement AS INTEGER: ' Indicates we're still in first statement
ARRAY ASSIGN valid() = "class ","function ","method ","override ","property ","sub ","thread "
pSource = STRPTR(SOURCE)
dest = STRING$(1000, " ")
DO WHILE @pSource
DO
' Skip leading spaces
WHILE @pSource AND @pSource <= 32
INCR pSource
WEND
SELECT CASE @pSource OR 32
CASE 99: p=0: ' c
CASE 102: p=1: ' f
CASE 109: p=2: ' m
CASE 111: p=3: ' o
CASE 112: p=4: ' p
CASE 115: p=5: ' s
CASE 116: p=6: ' t
CASE ELSE: p=-1
END SELECT
IF p>-1 THEN
pValid = STRPTR(valid(p))
pDest = STRPTR(dest)
dstLen = 0
' Check line signature
DO WHILE @pSource AND @pValid
IF (@pSource OR 32) <> @pValid THEN EXIT LOOP
@pDest = @pSource: ' Copy while checking
INCR pDest
INCR dstLen
INCR pSource
INCR pValid
LOOP
IF @pValid=0 THEN
' Finish line copy
firstStatement = -1
DO WHILE @pSource AND @pSource<>13
IF firstStatement THEN
SELECT CASE @pSource
CASE 58: firstStatement=0: ' :
CASE 61: EXIT DO: ' =
END SELECT
END IF
@pDest = @pSource
INCR pSource
INCR pDest
INCR dstLen
LOOP
IF @pSource=13 OR @pSource=0 THEN
' Ensure room for new proc signature
IF cntProcs>=maxProcs THEN
maxProcs = maxProcs + 1000
REDIM PRESERVE procs(maxProcs)
END IF
' Add proc signature to list
procs(cntProcs)=LEFT$(dest, dstLen)
INCR cntProcs
END IF
END IF
END IF
' Move on to the end of the line if not there
WHILE @pSource AND @pSource<>13
INCR pSource
WEND
LOOP WHILE @pSource
LOOP
REDIM PRESERVE procs(cntProcs-1)
End Sub
'gbs_01079
'Date: 03-10-2012
http://www.garybeene.com/sw/gbsnippets.htm