by Grifter (1 Submission)
Category: Miscellaneous
Compatability: Visual Basic 3.0
Difficulty: Unknown Difficulty
Originally Published: Tue 24th August 2004
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
OpenBSL is an open source GPL'd Basic Scripting Language written in Visual Basic.
VBcoders
Rem Originally developed by Grifter
'from the ground up OpenBSL has
'been written from scratch.
Rem Last Update: October 12, 2000
Rem Current Developer: Grifter
Rem http://www.untrendy.org/grifter
Rem http://www.untrendy.org/openbsl
Rem A special thanks to these individuals:
'The Refsoft Team (http://www.refsoft.com)
Rem openbsl.bas and all subsidiaries
'are protected under the GNU GPL
'for the latest versions visit
'www.gnu.org, www.gpl.org
'this source is completely open you
'may extend this language as you see
'fit, but do not take initial credit
'for the foundation it was developed
'from.
'Key notes:
'1 All variables must be declared
'2 Formulas and strings must be on seperate lines.
'3 All syntax MUST be lowercase, this is how it is interpeted.
Option Explicit
Rem VB 3.0 16-bit drawbacks
'This version of vb does not support
'3 dimensional arrays, so we can no longer
'have a variable array within a type.
'In otherwords, we can only load 1 script
'at a time =[.
Const InternalFuncs$ = "/left/right/msgbox/len/instr/"
Dim FunctionCount As Long
Dim FunctionName() As String
Dim FunctionBlock() As String
Dim VariantObjects As Integer
Global VariantObject() As String
Function CalcFormula (ByVal StringToEval As String) As Variant
'I wrote a really hackerish algorithm that
'calculates long formulas like 1 + (6 / 7 + 5) * 3
'but it was written in VB 6.0, and I used collection
'methods, which VB 3.0 does not support, so, for
'now, when you want to do mathematical formulas,
'it's 1 per line.
Dim Calc As Variant
If InStr(StringToEval$, "+") Then
Calc = Val(Parse(StringToEval$, "+", 1, 1)) + Val(Parse(StringToEval$, "+", 2, 32000))
ElseIf InStr(StringToEval$, "-") Then
Calc = Val(Parse(StringToEval$, "-", 1, 1)) - Val(Parse(StringToEval$, "-", 2, 32000))
ElseIf InStr(StringToEval$, "*") Then
Calc = Val(Parse(StringToEval$, "*", 1, 1)) * Val(Parse(StringToEval$, "*", 2, 32000))
ElseIf InStr(StringToEval$, "/") Then
Calc = Val(Parse(StringToEval$, "/", 1, 1)) / Val(Parse(StringToEval$, "/", 2, 32000))
ElseIf InStr(StringToEval$, "\") Then
Calc = Val(Parse(StringToEval$, "\", 1, 1)) \ Val(Parse(StringToEval$, "\", 2, 32000))
End If
If Calc = "" Then
CalcFormula = StringToEval$
Else
CalcFormula = Calc
End If
End Function
Function CallFunction (ByVal FuncName As String, FuncArguments As Variant)
'Executes an internal function, many of our
'reserved functions reside here, ex: left, right
'You can add/remove as you see fit, there is where
'you extend the language. You'll be doing a lot of
'linking here to make your programs scriptable.
FuncArguments = Replace(FuncArguments, "; ", ";")
'Some of your internal functions may need
'more arguments, just create a new variable
'and change the parse #'s to 4,4...5,5...6,6
'and so on. I did this for simplicity.
Dim Arg1 As Variant, Arg2 As Variant, Arg3 As Variant
If InStr(FuncArguments, ";") Then
Arg1 = Parse(FuncArguments, ";", 1, 1)
Arg2 = Parse(FuncArguments, ";", 2, 2)
Arg3 = Parse(FuncArguments, ";", 3, 3)
Else
Arg1 = Parse(FuncArguments, ";", 1, 1)
End If
Select Case FuncName
Case "left"
CallFunction = Left(Arg1, Arg2)
Exit Function
Case "right"
CallFunction = Right(Arg1, Arg2)
Exit Function
Case "instr"
CallFunction = InStr(Arg1, Arg2)
Exit Function
Case "len"
CallFunction = Len(Arg1)
Exit Function
Case "msgbox"
If Arg2 <> "" And Arg3 <> "" Then
CallFunction = MsgBox(Arg1, Arg2, Arg3)
Else
CallFunction = MsgBox(Arg1)
End If
Exit Function
End Select
'Executes a function within the script, these are
'functions written in the script, not hard coded
'k? good. :)
If GetObjectIndex(FuncName$) = 0 Then
NewObject FuncName$, ""
End If
If FuncArguments <> "" Then
Dim I&, Ret&, Pos&, CurArg, CurIntArg, IntArgs
Dim FuncIndex As Long
Do
DoEvents
Pos& = Pos& + 1
If InStr(FuncArguments, ";") = 0 Then
CurArg = FuncArguments
Else
CurArg = Parse(FuncArguments, ";", Pos&, Pos&)
End If
For I& = 1 To FunctionCount&
If Left(FunctionName$(I&), Len(FuncName$)) = FuncName$ Then
FuncIndex& = I&
IntArgs = Parse(FunctionName$(I&), "(", 2, 32000)
IntArgs = Left(IntArgs, Len(IntArgs) - 1)
If InStr(FuncArguments, ";") = 0 Then
CurIntArg = IntArgs
Else
CurIntArg = Parse(IntArgs, ",", Pos&, Pos&)
End If
If GetObjectIndex(CurIntArg) = 0 Then
NewObject CurIntArg, ""
WriteObject CurIntArg, CurArg
End If
Exit For
End If
Next I&
Loop Until InStr(FuncArguments, ";") = 0 Or Parse(FuncArguments, ";", Pos& + 1, Pos& + 1) = ""
End If
If FuncIndex& = 0 Then
For I& = 1 To FunctionCount&
If Left(FunctionName$(I&), Len(FuncName$)) = FuncName$ Then FuncIndex& = I&
Next I&
End If
Ret& = ExecuteCode(FunctionBlock$(FuncIndex&))
CallFunction = ReadObject(FuncName$)
End Function
Function CompareObjects (Compare As String) As Integer
'This is the most important aspect of the if/else
'engine. The compare, it supports = <> > < >= <=
'In the future it will support: and/or/xor
Dim Object1 As Variant, Object2 As Variant, X As Long
Dim Oper As String
For X = 1 To VariantObjects
If InStr(Compare$, Parse(VariantObject(X), "=", 1, 1)) Then
Compare$ = Replace(Compare$, Parse(VariantObject(X), "=", 1, 1), Parse(VariantObject(X), "=", 2, 32000))
End If
Next X
If InStr(Compare$, " = ") Then
Oper$ = " = "
Compare$ = Replace(Compare$, " = ", "|")
ElseIf InStr(Compare, " <> ") Then
Oper$ = " <> "
Compare$ = Replace(Compare$, " <> ", "|")
ElseIf InStr(Compare, " < ") Then
Oper$ = " < "
Compare$ = Replace(Compare$, " < ", "|")
ElseIf InStr(Compare, " > ") Then
Oper$ = " > "
Compare$ = Replace(Compare$, " > ", "|")
ElseIf InStr(Compare, " >= ") Then
Oper$ = " >= "
Compare$ = Replace(Compare$, " >= ", "|")
ElseIf InStr(Compare, " <= ") Then
Oper$ = " <= "
Compare$ = Replace(Compare$, " <= ", "|")
End If
Object1 = Parse(Compare$, "|", 1, 1)
Object2 = Parse(Compare$, "|", 2, 32000)
If Oper$ = " = " Then
If Object1 = Object2 Then
CompareObjects = True
Else
CompareObjects = False
End If
ElseIf Oper$ = " <> " Then
If Object1 <> Object2 Then
CompareObjects = True
Else
CompareObjects = False
End If
ElseIf Oper$ = " >= " Then
If Object1 >= Object2 Then
CompareObjects = True
Else
CompareObjects = False
End If
ElseIf Oper$ = " <= " Then
If Object1 <= Object2 Then
CompareObjects = True
Else
CompareObjects = False
End If
ElseIf Oper$ = " > " Then
If Object1 > Object2 Then
CompareObjects = True
Else
CompareObjects = False
End If
ElseIf Oper$ = " < " Then
If Object1 < Object2 Then
CompareObjects = True
Else
CompareObjects = False
End If
End If
End Function
Function CreateBlock (Code$, FirstPrefix$, LastPrefix$)
End Function
Function ExecuteCode (Block$)
'This is the heart of OpenBSL
'Tmp$ - Temporary variable, must be
'reset to "" for each line interpeted.
Dim Pos&, TmpMemory$, CurLine$, Tmp$, Ret&
'Debugging variables
Dim Cnt&, IfMode%
Dim IfCmd$, IfTmp$, ElseTmp$, IfOpen%, IfClosed%
TmpMemory = Block$
Do
Cnt& = Cnt& + 1
Pos = InStr(TmpMemory, Chr(13))
If Pos Then
CurLine = Left(TmpMemory, Pos - 1)
If Left(CurLine, 4) = "else" Then 'Switch to else collect mode
If IfOpen% = IfClosed% + 1 Then
IfMode% = 2
GoTo NextLine
End If
End If
'When all block ifs are complete, execute code depending
'on boolean, compare is true, or compare is false. if/else
If Left(CurLine, 6) = "end if" Then
IfClosed% = IfClosed% + 1
If IfClosed% = IfOpen% Then
If CompareObjects(IfCmd$) = True Then
Ret& = ExecuteCode(IfTmp$)
ElseIf ElseTmp$ <> "" Then
Ret& = ExecuteCode(ElseTmp$)
End If
IfTmp$ = ""
ElseTmp$ = ""
IfMode% = 0
IfOpen% = 0
IfClosed% = 0
GoTo NextLine
End If
End If
'If Mode/Handler
Select Case IfMode%
Case 1 'Build IF code block
If Left(CurLine, 2) = "if" Then IfOpen% = IfOpen% + 1
IfTmp$ = IfTmp$ & CurLine & Chr(13) & Chr(10)
GoTo NextLine
Case 2 'Build ELSE code block
If Left(CurLine, 2) = "if" Then IfOpen% = IfOpen% + 1
ElseTmp$ = ElseTmp$ & CurLine & Chr(13) & Chr(10)
GoTo NextLine
End Select
'If/Else - Program flow/execution, control
If Left(CurLine, 2) = "if" Then
IfOpen% = IfOpen% + 1
IfMode% = 1
IfCmd$ = Parse(CurLine, " ", 2, 32000)
IfCmd$ = Left(IfCmd$, Len(IfCmd$) - 5)
GoTo NextLine
End If
'Dim - Creating variant objects
If Left(CurLine, 3) = "dim" Then
If InStr(CurLine, "=") Then
Tmp$ = RenderData(Right(Parse(CurLine, "=", 2, 32000), Len(Parse(CurLine, "=", 2, 32000)) - 1))
End If
NewObject Parse(CurLine, " ", 2, 2), Tmp$
GoTo NextLine
End If
'Object I/O
If InStr(CurLine, "=") Then
If GetObjectIndex(Parse(CurLine, " ", 1, 1)) Then
ObjectIO Parse(CurLine, " ", 1, 1), Parse(CurLine, " ", 3, 32000)
End If
End If
NextLine:
TmpMemory = Right(TmpMemory, (Len(TmpMemory) - Pos - 1))
Tmp$ = ""
Else
Exit Do
End If
Loop
End Function
Sub FreeObjects ()
VariantObjects% = 0
ReDim VariantObject$(1 To 1)
End Sub
Function GetObjectIndex (ByVal Object$) As Integer
Dim I As Integer
Let I% = 0
'Search the array
For I = 1 To VariantObjects%
'Check for match
If Left(VariantObject$(I), Len(Object$) + 1) = Object$ & "=" Then
GetObjectIndex% = I
Exit For
End If
Next I
End Function
Sub LoadScript (FromFile As String)
Dim TmpMemory As String
Dim Pos&, Cnt&, EL$, CurLine$, CurFunc&
'Load script into memory
Open FromFile For Input As #1
TmpMemory = Input(LOF(1), 1)
Close #1
'Optimize script
'Seperate functions
Do
Cnt& = Cnt& + 1
Pos = InStr(TmpMemory, Chr(13))
If Pos Then
CurLine = Left(TmpMemory, Pos - 1)
ReLoadScript:
If Left(CurLine, 1) = Chr(32) Or Left(CurLine, 1) = Chr(9) Then
CurLine = Right(CurLine, Len(CurLine) - 1)
GoTo ReLoadScript
End If
If Left(CurLine, 12) = "end function" Then GoTo SkipLoadScript
If Left(CurLine, 3) = "rem" Then GoTo SkipLoadScript
If Left(CurLine, 9) = "end class" Then GoTo SkipLoadScript
If InStr(CurLine, "'") Then CurLine = Parse(CurLine, "'", 1, 1)
'This will create a new space in memory for a function to be
'inserted. Incriment the number of functions, insert name
'and insert function contents (block/code).
If Left(CurLine, 8) = "function" Then
CurFunc& = CurFunc& + 1
FunctionCount& = CurFunc&
ReDim Preserve FunctionName$(1 To CurFunc&)
FunctionName(CurFunc&) = Parse(CurLine, " ", 2, 32000)
ReDim Preserve FunctionBlock$(1 To CurFunc&)
GoTo SkipLoadScript
End If
If CurLine = "" Then GoTo SkipLoadScript
If Cnt& > 1 Then EL$ = Chr(13) & Chr(10)
FunctionBlock$(CurFunc&) = FunctionBlock$(CurFunc&) & CurLine & EL$
SkipLoadScript:
TmpMemory = Right(TmpMemory, (Len(TmpMemory) - Pos - 1))
Else
Exit Do
End If
Loop
End Sub
Sub Main ()
Rem This is where I test all aspects of the script
'this function is executed as soon as OpenBSL
'the project is ran because there is no form
'and openbsl.bas is the only thing in the
'project. Just remove this function if you are
'using forms in your VB project, or keep it
'as a reference for using BSL.
'How to use OpenBSL
'Ok, as you look around you'll pick it up,
'pretty self explanitory.
'What OpenBSL does, is interpet code from
'a text file, and execute it. OpenBSL is used
'to give your program more customization, more
'extensibility, scalability, and a lot of other
'20$ dollar words.
'An example of how OpenBSL would be used is
'this.
'Instead of calling your own Function, like
'for instance say you have a function that
'takes 2 names and puts an ! between them.
'now in the future someone might wanna change
'this to put a ^ sign between them. Well you
'would write this into a text file.
'function Stuff$(fName1; fName2)
'Stuff$ = fName1 & "!" & fName2
'end function
'Now when your program starts, you'd load this
'script (text file), with this command.
'Sub Form_Load()
'LoadScript "text.txt"
'End Sub
'Now say you wanted to make a msgbox come up
'with the two names binded by the script. For
'example will just use a button.
'Sub Command1_Click()
'Dim X
'X = MsgBox(CallFunction("Stuff$", "Jack; Jill"))
'Jack and Jill are the function arguments, arg
'uments are seperated by ;'s instead of ,'s
'this is for many reasons, but that is the
'the only major difference between BSL and
'basic.
'You can add your own functions too. So a
'script would be able to call Chatsend in
'an AOL proggie.
'OpenBSL itself consists of functions only.
'Though you can link functions to subs.
'OpenBSL scripts consist of functions, it
'doesn't matter what order they are in, just
'one on top of the other, they can all call
'eachother, their is no pub/priv.
'All objects (variables) are GLOBAL, so i
'suggest using f's or f_'s in your function
'arguments, ex:
'function example(f_argument1; f_argument2)
'end function
'Um, Rem statements and the ' symbol work
'just like they do in VB.
'ALL SYNTAX IS LOWERCASE. All commands,
'functions, etc, are lowercase in BSL. Though
'the names of your variables or strings, or the
'data within the strings can be any case. Ex:
'X$ = "yo" These are acceptable
'x$ = "Yo" ....
'DiM yo This is not acceptable
' It should be ...
'dim yo
'All variables must be declared, it doesn't
'matter what type they are.Eg: %,&,$,!
'You cannot do X = blah or Y = blah
'until do:
'dim X
'They must be declared. You can do
'this several ways, you can also set
'a value while declaring it, like in C.
'dim X Note: X and X$ would be
'dim X$ considered two different
'dim X = "Hi" variables.
'
' Note: A variables name may
' have any chr except, + -
' ; ' and ,
'dim X,Y$,Z%,L&,A#,B@
' Note: You can declare more than
' one on the same line.
Rem This concludes the OpenBSL brief overview.
'Use it, play with it, and you'll get the hang
'of it.
End Sub
Sub NewObject (ByVal Object$, Default As Variant)
'Objects must be created before they are accessed
'in otherwords, all objects must be declared.
'You can also initialize the object with data
'upon its creation.
'Ex: dim x$,y,z%
'Ex: dim x$
' dim y
' dim z%
'Ex: dim x$ = "word"
Dim ObjectB$, Pos&
Object$ = Replace(Object$, ", ", ",")
Do
DoEvents
If InStr(Object$, ",") Then
Pos& = Pos& + 1
ObjectB$ = Replace(Parse(Object$, ",", Pos&, Pos&), " ", "")
Else
ObjectB$ = Object$
End If
'Update Object Count
VariantObjects% = VariantObjects% + 1
'Set new object
ReDim Preserve VariantObject$(1 To VariantObjects%)
'Set default value
VariantObject$(VariantObjects%) = ObjectB$ & "=" & Default
Loop Until InStr(Object$, ",") = 0 Or Parse(Object$, ",", Pos& + 1, Pos& + 1) = ""
End Sub
Sub ObjectIO (Object$, DataToRender$)
'Any time an object changes, or in more technical
'terms, any time an object is initialized.
Dim I As Long, X As Long, Ret As Variant, FuncName$
FuncName$ = Parse(DataToRender$, "(", 1, 1)
If InStr(InternalFuncs$, "/" & FuncName$ & "/") Then
'Internal Function
Ret = Left(Parse(DataToRender$, "(", 2, 32000), Len(Parse(DataToRender$, "(", 2, 32000)) - 1)
Ret = Replace(Ret, """", "")
For X = 1 To VariantObjects
If InStr(Ret, Parse(VariantObject(X), "=", 1, 1)) Then
Ret = Replace(Ret, Parse(VariantObject(X), "=", 1, 1), Parse(VariantObject(X), "=", 2, 32000))
End If
Next X
DataToRender$ = CallFunction(FuncName$, Ret)
Else
'Script Function
For I& = 1 To FunctionCount&
If Left(DataToRender$, Len(FuncName$)) = Left(FunctionName$(I&), Len(FuncName$)) Then
'This is where we format the data into
'a basically executeable function.
Ret = Left(Parse(DataToRender$, "(", 2, 32000), Len(Parse(DataToRender$, "(", 2, 32000)) - 1)
Ret = Replace(Ret, """", "")
For X = 1 To VariantObjects
If InStr(Ret, Parse(VariantObject(X), "=", 1, 1)) Then
Ret = Replace(Ret, Parse(VariantObject(X), "=", 1, 1), Parse(VariantObject(X), "=", 2, 32000))
End If
Next X
DataToRender$ = CallFunction(FuncName$, Ret)
Exit For
End If
Next I
End If
WriteObject Object$, RenderData(DataToRender$)
End Sub
Function Operator (Block As String) As Integer
Select Case Block$
Case "("
Operator = True
Case ")"
Operator = True
Case "+"
Operator = True
Case "-"
Operator = True
Case "*"
Operator = True
Case "/"
Operator = True
Case "\"
Operator = True
Case " "
Operator = True
Case Else
Operator = False
End Select
End Function
Function Parse (ByVal Text As String, ByVal Separator As String, ByVal From As Integer, ByVal Thru As Integer) As String
Dim I As Integer, Temp As String, Result As String
Dim ParseBegin As Integer, T As Integer, Count As Integer
Dim ParseEnd As Integer, Found As Integer
Parse = ""
If Text$ = "" Then Exit Function
If Separator$ = "" Then Exit Function
If Not (From > 0) Then From = 1
If Thru < From Then Thru = From
T = InStr(1, Text$, Separator$)
If T = 0 Then
Parse = Text$
Exit Function
End If
If (From = 1) And (From = Thru) Then
If T = 1 Then
Parse = ""
Exit Function
Else
Parse = Left$(Text$, T - 1)
Exit Function
End If
End If
ParseBegin = 1
For I = 1 To From - 1
T = InStr(ParseBegin, Text$, Separator)
If T = 0 Then Exit For
ParseBegin = T + 1
Next I
If T = 0 Then Exit Function
If From = Thru Then
T = InStr(ParseBegin, Text$, Separator)
If T = 0 Then T = Len(Text$) + 1
Result = Left$(Text$, T - 1)
Parse = Right$(Result, T - ParseBegin)
Exit Function
End If
'Find last Parse then exit
ParseEnd = T + 1
If From = 1 Then From = 2
For I = From To Thru
T = InStr(ParseEnd, Text$, Separator)
If T = 0 Then
T = Len(Text$) + 1
Exit For
End If
ParseEnd = T + 1
Next I
If T = 0 Then T = Len(Text$) + 1
Result = Left$(Text$, T - 1)
Parse = Right$(Result, T - ParseBegin)
End Function
Function ReadObject (ByVal Object$) As Variant
'Get object value
ReadObject = Parse(VariantObject$(GetObjectIndex(Object$)), "=", 2, 2)
End Function
Function RenderData (DataToRender$) As String
Dim TmpData$, TmpDataB$, I&, X&, Pos&
Dim Quotes As Integer, NextByte As Integer
'Super-fast rendering algorithm
'This will interpet and render the data to be input
'into an object/function.
'This isn't really commented, though it is one
'of the key contributors to the speed or lack
'there of, in OpenBSL, in contrast/comparison
'toward a system programming language.
If DataToRender$ = "" Then Exit Function
Quotes = False
NextByte = False
If InStr(DataToRender$, """") Then
If Right(DataToRender$, 1) <> """" Then DataToRender$ = DataToRender$ + " + """""
For I = 1 To Len(DataToRender$) + 1
If NextByte = True Then
NextByte = False
GoTo SkipByte
End If
Select Case Mid$(DataToRender$, I, 1)
Case """"
Case "+"
TmpDataB$ = Left(TmpDataB$, Len(TmpDataB$) - 1)
NextByte = True
GoTo SkipByte
Case "&"
TmpDataB$ = Left(TmpDataB$, Len(TmpDataB$) - 1)
NextByte = True
GoTo SkipByte
Case Else
NextByte = False
TmpData$ = TmpData$ & Mid$(DataToRender$, I, 1)
End Select
If Quotes = False And NextByte = False And Mid$(DataToRender$, I, 1) = """" Or Mid$(DataToRender$, I, 1) = " " Then
Quotes = True
For X = 1 To VariantObjects
If InStr(TmpData$, Parse(VariantObject(X), "=", 1, 1)) Then
TmpData$ = Replace(TmpData$, Parse(VariantObject(X), "=", 1, 1), Parse(VariantObject(X), "=", 2, 32000))
End If
Next X
TmpDataB$ = TmpDataB$ & TmpData$
TmpData$ = ""
ElseIf Quotes = True And Mid$(DataToRender$, I, 1) = """" Then
Quotes = False
For X = 1 To VariantObjects
If InStr(TmpData$, Parse(VariantObject(X), "=", 1, 1)) Then
TmpData$ = Replace(TmpData$, " " & Parse(VariantObject(X), "=", 1, 1) & " ", Parse(VariantObject(X), "=", 2, 32000))
End If
No comments have been posted about OpenBSL is an open source GPL'd Basic Scripting Language written in Visual Basic.. Why not be the first to post a comment about OpenBSL is an open source GPL'd Basic Scripting Language written in Visual Basic..