Show Posts

This section allows you to view all posts made by this member. Note that you can only see posts made in areas you currently have access to.

Messages - Support

Pages: 1 ... 6 7 [8] 9 10 ... 59

106

What's New / SBx 3 Forms

« on: May 27, 2015, 11:19:46 PM »

As it turns out, you really don't need threading to achieve multiple window support. As I see it threading of a IUP dialog would be a special use case. It's good to know it can be done.

Code: Script BASIC

' SBx_buttons Example (3 Form Version)
 
IMPORT iup.bas
IMPORT sbt.inc
IMPORT "SBx"
 
' Form 1 Callback Routines
SUB frm1_btn1_clicked
  PRINT "Form 1 Button 1 Pressed\n"
  PRINT "Which Mouse Button: ",CHR(Iup::GetBtnPressed()),"\n"
  PRINT "Button Up/Dn State: ",Iup::GetBtnState(),"\n"
END SUB
 
SUB frm1_btn2_clicked
  PRINT "Form 1 Button 2 Pressed\n"
END SUB
 
SUB frm1_btn3_clicked
  PRINT "Form 1 Button 3 Pressed\n"
END SUB
 
' Form 2  Callback Routines
SUB frm2_btn1_clicked
  PRINT "Form 2 Button 1 Pressed\n"
  PRINT "Which Mouse Button: ",CHR(Iup::GetBtnPressed()),"\n"
  PRINT "Button Up/Dn State: ",Iup::GetBtnState(),"\n"
END SUB
 
SUB frm2_btn2_clicked
  PRINT "Form 2 Button 2 Pressed\n"
END SUB
 
SUB frm2_btn3_clicked
  PRINT "Form 2 Button 3 Pressed\n"
END SUB
 
' Form 3 Callback Routines
SUB frm3_btn1_clicked
  PRINT "Form 3 Button 1 Pressed\n"
  PRINT "Which Mouse Button: ",CHR(Iup::GetBtnPressed()),"\n"
  PRINT "Button Up/Dn State: ",Iup::GetBtnState(),"\n"
END SUB
 
SUB frm3_btn2_clicked
  PRINT "Form 3 Button 2 Pressed\n"
END SUB
 
SUB frm3_btn3_clicked
  PRINT "Form 3 Button 3 Pressed\n"
END SUB
 
SUB win_exit
  ' Good-Bye
END SUB
 
Iup::Open()
 
' Form 1 Dialog
win1 = DIALOG()
SETPROPERTIES(win1, "TITLE=\"SBx Form 1\", SIZE=300x")
horzbox1 = HBOX()
SETPROPERTIES horzbox1, "GAP=5"
btn1_1 = BUTTON()
SETPROPERTIES btn1_1, "TITLE=\"Button 1\", EXPAND=HORIZONTAL"
btn1_2 = BUTTON()
SETPROPERTIES btn1_2, "TITLE=\"Button 2\", EXPAND=HORIZONTAL"
btn1_3 = BUTTON()
SETPROPERTIES btn1_3, "TITLE=\"Button 3\", EXPAND=HORIZONTAL"
APPEND horzbox1, btn1_1
APPEND horzbox1, btn1_2
APPEND horzbox1, btn1_3
APPEND win1, horzbox1
Iup::SetCallback win1, "CLOSE_CB", ADDRESS(win_exit())
Iup::SetCallback btn1_1, "BUTTON_CB", ADDRESS(frm1_btn1_clicked())
Iup::SetCallback btn1_2, "ACTION", ADDRESS(frm1_btn2_clicked())
Iup::SetCallback btn1_3, "ACTION", ADDRESS(frm1_btn3_clicked())
Iup::ShowXY(win1,500,200)
 
 
 
' Form 2 Dialog
win2 = DIALOG()
SETPROPERTIES win2, "TITLE=\"SBx Form 2\", SIZE=300x"
horzbox2 = HBOX()
SETPROPERTIES horzbox2, "GAP=5"
btn2_1 = BUTTON()
SETPROPERTIES btn2_1, "TITLE=\"Button 1\", EXPAND=HORIZONTAL"
btn2_2 = BUTTON()
SETPROPERTIES btn2_2, "TITLE=\"Button 2\", EXPAND=HORIZONTAL"
btn2_3 = BUTTON()
SETPROPERTIES btn2_3, "TITLE=\"Button 3\", EXPAND=HORIZONTAL"
APPEND horzbox2, btn2_1
APPEND horzbox2, btn2_2
APPEND horzbox2, btn2_3
APPEND win2, horzbox2
Iup::SetCallback win2, "CLOSE_CB", ADDRESS(win_exit())
Iup::SetCallback btn2_1, "BUTTON_CB", ADDRESS(frm2_btn1_clicked())
Iup::SetCallback btn2_2, "ACTION", ADDRESS(frm2_btn2_clicked())
Iup::SetCallback btn2_3, "ACTION", ADDRESS(frm2_btn3_clicked())
Iup::ShowXY(win2,500,400)
 
' Form 3 Dialog
win3 = DIALOG()
SETPROPERTIES win3, "TITLE=\"SBx Form 3\", SIZE=300x"
horzbox3 = HBOX()
SETPROPERTIES horzbox3, "GAP=5"
btn3_1 = BUTTON()
SETPROPERTIES btn3_1, "TITLE=\"Button 1\", EXPAND=HORIZONTAL"
btn3_2 = BUTTON()
SETPROPERTIES btn3_2, "TITLE=\"Button 2\", EXPAND=HORIZONTAL"
btn3_3 = BUTTON()
SETPROPERTIES btn3_3, "TITLE=\"Button 3\", EXPAND=HORIZONTAL"
APPEND horzbox3, btn3_1
APPEND horzbox3, btn3_2
APPEND horzbox3, btn3_3
APPEND win3, horzbox3
Iup::SetCallback win3, "CLOSE_CB", ADDRESS(win_exit())
Iup::SetCallback btn3_1, "BUTTON_CB", ADDRESS(frm3_btn1_clicked())
Iup::SetCallback btn3_2, "ACTION", ADDRESS(frm3_btn2_clicked())
Iup::SetCallback btn3_3, "ACTION", ADDRESS(frm3_btn3_clicked())
Iup::ShowXY(win3,500,600)
 
 
 
' Event Loop
windows = 3
 
WHILE windows
  Iup::LoopStep()
  this_event = Iup::GetEvent()
  this_event = Iup::BB_HTA(this_event)
  IF this_event = event{this_event}[0] THEN
    ICALL event{this_event}[1]
    IF Iup::GetActionName() = "CLOSE_CB" THEN windows -= 1
  END IF  
  SB_msSleep(250)
WEND
 
Iup::Close
 

iup.bas - I changed the Iup::SetCallback() to create the event array in the main namespace.

Code: Script BASIC

FUNCTION SetCallback(ih, aname, fname)
  main::event{BB_HTA(ih)}[0] = BB_HTA(ih)
  main::event{BB_HTA(ih)}[1] = fname
  SetCallback = __SetCallback(ih, aname)
END FUNCTION
 

107

**What's New / IUP Threaded - Linux 64 bit - SBT 3*3**

« on: May 25, 2015, 07:20:52 PM »

The solution to my unstable IUP start-up issues were resolved with creating an IUP dialog in the parent script before creating threaded children dialogs. I moved the Iup::MainLoop and Iup::GetThreadCallback routines into the main script from the IUP extension module. At this point everything is working as expected and I couldn't be happier.

Moral: How can you have well behaved children if you don't have a mature parent in charge?

SBx_Main

Code: Script BASIC

' SBT IUP Theaded Example
 
IMPORT mt.bas
IMPORT sbt.inc
IMPORT iup.bas
IMPORT "SBx"
 
Iup::Open()
 
SUB SB_Wait(mtvar)
  WHILE mt::GetVariable(mtvar) <> "OK"
    SB_msSleep(5000)
  WEND
END SUB
 
SUB btn1_clicked
  PRINT "Main 0 Button 1 Pressed\n"
  PRINT "Which Mouse Button: ",CHR(Iup::GetBtnPressed()),"\n"
  PRINT "Button Up/Dn State: ",Iup::GetBtnState(),"\n"
END SUB
 
SUB btn2_clicked
  PRINT "Main 0 Button 2 Pressed\n"
END SUB
 
SUB btn3_clicked
  PRINT "Main 0 Button 3 Pressed\n"
END SUB
 
SUB win_exit
  ' Good-Bye
END SUB
 
win = DIALOG()
SETPROPERTIES win, "TITLE=\"SBx Main 0\", SIZE=300x"
horzbox = HBOX()
SETPROPERTIES horzbox, "GAP=5"
btn1 = BUTTON()
SETPROPERTIES btn1, "TITLE=\"Button 1\", EXPAND=HORIZONTAL"
btn2 = BUTTON()
SETPROPERTIES btn2, "TITLE=\"Button 2\", EXPAND=HORIZONTAL"
btn3 = BUTTON()
SETPROPERTIES btn3, "TITLE=\"Button 3\", EXPAND=HORIZONTAL"
APPEND horzbox, btn1
APPEND horzbox, btn2
APPEND horzbox, btn3
APPEND win, horzbox
Iup::SetThreadCallback(win, "CLOSE_CB", ADDRESS(win_exit()), 0)
Iup::SetThreadCallback(btn1, "BUTTON_CB", ADDRESS(btn1_clicked()), 0)
Iup::SetThreadCallback(btn2, "ACTION", ADDRESS(btn2_clicked()), 0)
Iup::SetThreadCallback(btn3, "ACTION", ADDRESS(btn3_clicked()), 0)
SHOW win
 
' Puppet Show
 
sb1 = SB_ThreadStart("SBx_T1",undef,"/etc/scriba/basic.conf")
SB_Wait("sb1_loaded")
sb1_rtn = SB_CallSubArgs(sb1, "main::main", sb1)
 
sb2 = SB_ThreadStart("SBx_T2",undef,"/etc/scriba/basic.conf")
SB_Wait("sb2_loaded")
sb2_rtn = SB_CallSubArgs(sb2, "main::main", sb2)
 
threads = 3
 
t_event = mt::GetVariable("Callback_Map")
SPLITA t_event BY "\n" TO e_list
FOR x = 0 TO UBOUND(e_list)
  SPLITA e_list[x] BY "|" TO e_array
  event{e_array[0]}[0] = e_array[0]
  event{e_array[0]}[1] = e_array[1]
  event{e_array[0]}[2] = e_array[2]
NEXT
 
WHILE threads
  Iup::LoopStep()
  this_event = Iup::GetEvent()
  hex_event = Iup::BB_HTA(this_event)
  IF hex_event = event{hex_event}[0] THEN
    IF event{hex_event}[2] = 0 THEN
      ICALL event{hex_event}[1]
    ELSE IF event{hex_event}[2] = 1 THEN
      SB_CallSub(main::sb1, event{hex_event}[1])
    ELSE IF event{hex_event}[2] = 2 THEN
      SB_CallSub(main::sb2, event{hex_event}[1])
    END IF
    IF Iup::GetActionName() = "CLOSE_CB" THEN threads -= 1
  END IF  
  SB_msSleep(250)
WEND
 
Iup::Close()
SB_Destroy(sb2)
SB_Destroy(sb1)
 

SBx_T1 - T2 is the same

Code: Script BASIC

' SBx_buttons Example (Thread 1)
 
IMPORT mt.bas
IMPORT iup.bas
IMPORT "SBx"
 
SUB btn1_clicked
  PRINT "Thread 1 Button 1 Pressed\n"
  PRINT "Which Mouse Button: ",CHR(Iup::GetBtnPressed()),"\n"
  PRINT "Button Up/Dn State: ",Iup::GetBtnState(),"\n"
END SUB
 
SUB btn2_clicked
  PRINT "Thread 1 Button 2 Pressed\n"
END SUB
 
SUB btn3_clicked
  PRINT "Thread 1 Button 3 Pressed\n"
END SUB
 
SUB win_exit
  ' Good-Bye
END SUB
 
SUB main
  win = DIALOG()
  SETPROPERTIES win, "TITLE=\"SBx Thread 1\", SIZE=300x"
  horzbox = HBOX()
  SETPROPERTIES horzbox, "GAP=5"
  btn1 = BUTTON()
  SETPROPERTIES btn1, "TITLE=\"Button 1\", EXPAND=HORIZONTAL"
  btn2 = BUTTON()
  SETPROPERTIES btn2, "TITLE=\"Button 2\", EXPAND=HORIZONTAL"
  btn3 = BUTTON()
  SETPROPERTIES btn3, "TITLE=\"Button 3\", EXPAND=HORIZONTAL"
  APPEND horzbox, btn1
  APPEND horzbox, btn2
  APPEND horzbox, btn3
  APPEND win, horzbox
  Iup::SetThreadCallback(win, "CLOSE_CB", "main::win_exit", 1)
  Iup::SetThreadCallback(btn1, "BUTTON_CB", "main::btn1_clicked", 1)
   Iup::SetThreadCallback(btn2, "ACTION", "main::btn2_clicked", 1)
  Iup::SetThreadCallback(btn3, "ACTION", "main::btn3_clicked", 1)
  SHOW win
END SUB
mt::SetVariable("sb1_loaded","OK")
 

SBx (Experimental IUP Wrapper)

Code: Script BASIC

' ScriptBasic IUP Interface
 
FUNCTION DIALOG
  DIALOG = Iup::Create("dialog")
END FUNCTION
 
SUB SETPROPERTIES(ih, propstr)
  Iup::SetAttributes(ih, propstr)
END SUB
 
SUB SETPROPERTY(ih, typ, value)
  Iup::SetAttribute(ih, typ, value)
END SUB
 
FUNCTION GETPROPERTY(ih, typ)
  GETPROPERTY = Iup::GetAttribute(ih, typ)
END FUNCTION
 
FUNCTION VBOX
  VBOX = Iup::Create("vbox")
END FUNCTION
 
FUNCTION HBOX
  HBOX = Iup::Create("hbox")
END FUNCTION
 
FUNCTION FRAME
  FRAME = Iup::Create("frame")
END FUNCTION
 
FUNCTION BUTTON
  BUTTON = Iup::Create("button")
END FUNCTION
 
FUNCTION LIST
  LIST = Iup::Create("list")
END FUNCTION
 
FUNCTION TEXT
  TEXT = Iup::Create("text")
END FUNCTION
 
FUNCTION LABEL
  LABEL = Iup::Create("label")
END FUNCTION
 
FUNCTION TOGGLE
  TOGGLE = Iup::Create("toggle")
END FUNCTION
 
SUB MESSAGE(title, body)
  Iup::Message(title, body)
END SUB
 
FUNCTION GETITEM
  GETITEM = Iup::GetListText()
END FUNCTION
 
SUB APPEND(ih_to, ih_from)
  Iup::Append(ih_to, ih_from)
END SUB
 
FUNCTION FOCUS(ih)
  FOCUS = Iup::SetFocus(ih)
END FUNCTION
 
FUNCTION UPDATE(ih)
  UPDATE = Iup::Update(ih)
END FUNCTION
 
SUB CLEAR(ih)
  Iup::ClearList(ih)
END SUB
 
' SUB SETEVENT(ih, class, funcaddr)
'   Iup::SetCallback(ih, class,  funcaddr)
' END SUB
 
SUB SHOW(ih)
  Iup::Show(ih)
END SUB  
 
' SUB GETEVENT
'   Iup::MainLoop
'   Iup::Close
' END SUB
 

108

What's New / IUP Threaded - Linux 64 bit - SBT

« on: May 23, 2015, 07:26:41 PM »

Done!

I finally got this worked out and didn't have to inform Gtk or IUP that they're being threaded.

I can click on either thread window's button as fast as I can and it responds with the being pressed message. The only minor issue I still have is the second thread window will open in max size and sometimes without a max/restore window button. At this point I'm happy.

iup.bas - callback handling functions

Code: Script BASIC

FUNCTION MainLoop
LOCAL hex_event
  LoopStep()
  this_event = GetEvent()
  hex_event = BB_HTA(this_event)
  IF hex_event = event{hex_event}[0] THEN
    IF event{hex_event}[2] = 1 THEN
      SB_CallSub(main::sb1, event{hex_event}[1])
    ELSEIF event{hex_event}[2] = 2 THEN
      SB_CallSub(main::sb2, event{hex_event}[1])
    END IF
    MainLoop = GetActionName()
  END IF  
END FUNCTION
 
FUNCTION SetThreadCallback(ih, aname, fname, tnum)
  t_event = mt::GetVariable("Callback_Map")
  IF t_event = undef THEN t_event = ""
  t_event = t_event & BB_HTA(ih) & "|" & fname & "|" & tnum & "\n"
  mt::SetVariable("Callback_Map", t_event)
  SetThreadCallback = __SetCallback(ih, aname)
END FUNCTION
 
SUB GetThreadCallback
  LOCAL t_event, e_list, e_array, x
  t_event = mt::GetVariable("Callback_Map")
  SPLITA t_event BY "\n" TO e_list
  FOR x = 0 TO UBOUND(e_list)
    SPLITA e_list[x] BY "|" TO e_array
    event{e_array[0]}[0] = e_array[0]
    event{e_array[0]}[1] = e_array[1]
    event{e_array[0]}[2] = e_array[2]
  NEXT
END SUB
 
FUNCTION BB_HTA(AsciiStr)
  LOCAL AsciiLen,ScanPos,HexStr
  AsciiLen = LEN(AsciiStr)
  HexStr = ""
  IF AsciiLen THEN
    FOR ScanPos = 1 TO AsciiLen
      HexStr &= RIGHT("0" & HEX(ASC(MID(AsciiStr, ScanPos, 1))),2)
    NEXT ScanPos
  ELSE
    HexStr = ""
  END IF
  BB_HTA = HexStr
END FUNCTION
 

iupmain.sb - host SB script (puppet master)

Code: Script BASIC

IMPORT mt.bas
IMPORT sbt.inc
IMPORT iup.bas
 
Iup::Open()
 
SUB SB_Wait(mtvar)
  WHILE mt::GetVariable(mtvar) <> "OK"
    SB_msSleep(5000)
  WEND
END SUB
 
sb1 = SB_ThreadStart("rqdemo1.sb",undef,"/etc/scriba/basic.conf")
SB_Wait("sb1_loaded")
sb1_rtn = SB_CallSubArgs(sb1, "main::main", sb1)
 
sb2 = SB_ThreadStart("rqdemo2.sb",undef,"/etc/scriba/basic.conf")
SB_Wait("sb2_loaded")
sb2_rtn = SB_CallSubArgs(sb2, "main::main", sb2)
 
threads = 2
 
Iup::GetThreadCallback()
 
WHILE threads
  event_class = Iup::MainLoop()
  IF event_class = "CLOSE_CB" THEN
    threads -= 1
    IF Iup::event{Iup::BB_HTA(Iup::this_event)}[2] = 1 THEN
      SB_CallSub(sb1, "iup::exitloop")
    ELSEIF Iup::event{Iup::BB_HTA(Iup::this_event)}[2] = 2 THEN
      SB_CallSub(sb2, "iup::exitloop")
    END IF
  END IF  
  SB_msSleep(250)
WEND
 
Iup::Close()
SB_Destroy(sb2)
SB_Destroy(sb1)
 

rqdemo1.sb - rqdemo2.sb is identical other than the references to it been the second thread.

Code: Script BASIC

' Script BASIC Rapid-Q form conversion
 
IMPORT mt.bas
IMPORT iup.bas
 
' CALLBACKS FUNCTIONS
 
SUB button_quit
  PRINT "Thread 1 Quit Button Pressed\n"
END SUB  
 
SUB win_exit
  ' Good-Bye   
END SUB
 
SUB main
  
  ' SBIUP-Q INIT
 
  Iup::Open()
  Iup::SetGlobal("DEFAULTFONT", "Sans, 7.5")
  
  ' CREATE FORM
  
  Form = Iup::Create("dialog")
         Iup::SetAttributes(Form, "RASTERSIZE=320x240, TITLE=\"Thread 1\"")
  
       Label1  = Iup::Create("label")
                 Iup::SetAttributes(Label1, "TITLE=\"Customer\", RASTERSIZE=55x13, FLOATING=YES, POSITION=\"19,19\"")
  
       Edit1   = Iup::Create("text")
                 Iup::SetAttributes(Edit1, "RASTERSIZE=121x21, FLOATING=YES, POSITION=\"72,16\"")
  
       Button1 = Iup::Create("button")
                 Iup::SetAttributes(Button1, "TITLE=\"&Quit\", RASTERSIZE=75x25, FLOATING=YES, POSITION=\"107,164\"")
  
  vbx = Iup::Vbox(Label1, Edit1, Button1)
  Iup::Append(Form, vbx)
                 
  ' SET CALLBACKS
  
  Iup::SetThreadCallback(Form, "CLOSE_CB", "main::win_exit", 1)
  Iup::SetThreadCallback(Button1, "ACTION", "main::button_quit", 1)
  Iup::Show(Form)
END SUB
mt::SetVariable("sb1_loaded","OK")
 

109

What's New / IUP Threaded - Windows 32 bit - DLLC

« on: May 17, 2015, 10:30:46 PM »

Here is an example of IUP running in a threaded mode with the DLLC extension module for Windows 32 bit.

The DLLC Windows 32 bit extension module can be found in the current OxygenBasic build and maintained by Charles Pegge.

Thread #1 script

Code: Script BASIC

' Thread #1 Script
 
INCLUDE "dllcinc.sb"
 
iup = dllfile("iup.dll")
 
IupOpen          = dllproc(iup,"IupOpen          cdecl i = (i argc, i argv)")
IupCreate        = dllproc(iup,"IupCreate        cdecl i = (c *classname)")
IupSetAttributes = dllproc(iup,"IupSetAttributes cdecl i = (i ih, c *attr_str)")
IupAppend        = dllproc(iup,"IupAppend        cdecl i = (i ih, cdecl i new_child)")
IupSetCallback   = dllproc(iup,"IupSetCallback   cdecl i = (i ih, c*cb_name, i funcaddr)")
IupShow          = dllproc(iup,"IupShow          cdecl i = (i ih)")
IupMainLoop      = dllproc(iup,"IupMainLoop      cdecl i = ()")
IupClose         = dllproc(iup,"IupClose         cdecl     ()")
 
GLOBAL CONST IUP_DEFAULT = -2
 
FUNCTION Btn1_T1(ih, mbut, pstat)
  PRINT "B1 - T1 ", CHR(mbut), " - ", pstat, "\n"
  Btn1_clicked = IUP_DEFAULT
END FUNCTION
 
FUNCTION Btn2_T1(ih)
  dllprnt"B2 - T1\n"
  Btn2_clicked = IUP_DEFAULT
END FUNCTION
 
FUNCTION Btn3_T1(ih)
  dllprnt"B3 - T1\n"
  Btn3_clicked = IUP_DEFAULT
END FUNCTION
 
FUNCTION main(pProg,idat)
  dllcall(IupOpen, 0, 0)
  win = dllcall(IupCreate, "dialog")
  dllcall(IupSetAttributes, win, "TITLE=\"Thread #1\", SIZE=300x")
  horzbox = dllcall(IupCreate, "hbox")
  dllcall(IupSetAttributes, horzbox, "GAP=5")
  btn1 = dllcall(IupCreate, "button")
  dllcall(IupSetAttributes, btn1, "TITLE=Button1, EXPAND=HORIZONTAL")
  btn2 = dllcall(IupCreate, "button")
  dllcall(IupSetAttributes, btn2, "TITLE=Button2, EXPAND=HORIZONTAL")
  btn3 = dllcall(IupCreate, "button")
  dllcall(IupSetAttributes, btn3, "TITLE=Button3, EXPAND=HORIZONTAL")
  dllcall(IupAppend, horzbox, btn1)
  dllcall(IupAppend, horzbox, btn2)
  dllcall(IupAppend, horzbox, btn3)
  dllcall(IupAppend, win, horzbox)
  dllcall(IupSetCallback, btn1, "BUTTON_CB", dllclbk(1, pProg, "MAIN::Btn1_T1", 3,IUP_DEFAULT,idat))
  dllcall(IupSetCallback, btn2, "ACTION", dllclbk(2, pProg, "MAIN::Btn2_T1", 1,IUP_DEFAULT,idat))
  dllcall(IupSetCallback, btn3, "ACTION", dllclbk(3, pProg, "MAIN::Btn3_T1", 1,IUP_DEFAULT,idat))
  dllcall(IupShow, win)
  Main=IupMainLoop
END FUNCTION
 

Thread #2 script

Code: Script BASIC

' Thread #2 Script
 
INCLUDE "dllcinc.sb"
 
iup = dllfile("iup.dll")
 
IupOpen          = dllproc(iup,"IupOpen          cdecl i = (i argc, i argv)")
IupCreate        = dllproc(iup,"IupCreate        cdecl i = (c *classname)")
IupSetAttributes = dllproc(iup,"IupSetAttributes cdecl i = (i ih, c *attr_str)")
IupAppend        = dllproc(iup,"IupAppend        cdecl i = (i ih, cdecl i new_child)")
IupSetCallback   = dllproc(iup,"IupSetCallback   cdecl i = (i ih, c*cb_name, i funcaddr)")
IupShow          = dllproc(iup,"IupShow          cdecl i = (i ih)")
IupMainLoop      = dllproc(iup,"IupMainLoop      cdecl i = ()")
IupClose         = dllproc(iup,"IupClose         cdecl     ()")
 
GLOBAL CONST IUP_DEFAULT = -2
 
FUNCTION Btn1_T2(ih)
  dllprnt"B1 - T2\n"
  Btn1_clicked = IUP_DEFAULT
END FUNCTION
 
FUNCTION Btn2_T2(ih)
  dllprnt"B2 - T2\n"
  Btn2_clicked = IUP_DEFAULT
END FUNCTION
 
FUNCTION Btn3_T2(ih)
  dllprnt"B3 - T2\n"
  Btn3_clicked = IUP_DEFAULT
END FUNCTION
 
FUNCTION main(pProg,idat)
  dllcall(IupOpen, 0, 0)
  win = dllcall(IupCreate, "dialog")
  dllcall(IupSetAttributes, win, "TITLE=\"Thread #2\", SIZE=300x")
  horzbox = dllcall(IupCreate, "hbox")
  dllcall(IupSetAttributes, horzbox, "GAP=5")
  btn1 = dllcall(IupCreate, "button")
  dllcall(IupSetAttributes, btn1, "TITLE=Button1, EXPAND=HORIZONTAL")
  btn2 = dllcall(IupCreate, "button")
  dllcall(IupSetAttributes, btn2, "TITLE=Button2, EXPAND=HORIZONTAL")
  btn3 = dllcall(IupCreate, "button")
  dllcall(IupSetAttributes, btn3, "TITLE=Button3, EXPAND=HORIZONTAL")
  dllcall(IupAppend, horzbox, btn1)
  dllcall(IupAppend, horzbox, btn2)
  dllcall(IupAppend, horzbox, btn3)
  dllcall(IupAppend, win, horzbox)
  dllcall(IupSetCallback, btn1, "ACTION", dllclbk(4, pProg, "MAIN::Btn1_T2", 1,IUP_DEFAULT,idat))
  dllcall(IupSetCallback, btn2, "ACTION", dllclbk(5, pProg, "MAIN::Btn2_T2", 1,IUP_DEFAULT,idat))
  dllcall(IupSetCallback, btn3, "ACTION", dllclbk(6, pProg, "MAIN::Btn3_T2", 1,IUP_DEFAULT,idat))
  dllcall(IupShow, win)
  Main=IupMainLoop
END FUNCTION
 

Start script

Code: Script BASIC

' Boot (Main / Launcher)
 
INCLUDE "dllcinc.sb"
bdat=string(8192,chr(0))
idat=dllsptr(bdat)
 
thrM1 = dlltran("T1.sb","main::main",1,idat)
thrM2 = dlltran("T2.sb","main::main",2,idat)
 
LINE INPUT wait
 
dllclos thrM1,thrM2
dllfile
 

110

What's New / Re: SBT - Thread Enhancements

« on: May 17, 2015, 07:52:50 PM »

I made a few improvement to the SBT extension module to allow threads to act more like the embedded API I started off with. A thread will not terminate at the end of its run. The script can be rerun in the thread if you like. You can access thread script variables, call FUNCTIONs and SUBs and use the MT extension module for thread status for the host or other threads.

tcallmain

Code: Script BASIC

IMPORT sbt.inc
 
sb = SB_ThreadStart("tcall.sb",undef,"/etc/scriba/basic.conf")
SB_SetInt sb, "main::a", 123
SB_SetDbl sb, "main::b", 1.23
SB_SetStr sb, "main::c", "One, Two, Three"
funcrtn = SB_CallSubArgs(sb, "main::prtvars", _
          SB_GetVar(sb, "main::a"), _
          SB_GetVar(sb, "main::b"), _
          SB_GetVar(sb, "main::c"))      
PRINT funcrtn,"\n"
SB_Destroy sb
 

tcall.sb

Code: Script BASIC

FUNCTION prtvars(a, b, c)    
  PRINT a,"\n"              
  PRINT FORMAT("%g\n", b)   
  PRINT c,"\n"              
  prtvars = "Function Return"
END FUNCTION                 
                             
a = 0                        
b = 0                        
c = ""                       
 

jrs@laptop:~/sb/sb22/sbt$ scriba tcallmain.sb 123 1.23 One, Two, Three Function Return jrs@laptop:~/sb/sb22/sbt$

Here is an example of rerunning a script in an existing thread.

Code: Script BASIC

IMPORT sbt.inc
 
sb = SB_ThreadStart("tprint.sb")
SB_Run(sb,"")
SB_Destroy(sb)
 

Code: Script BASIC

PRINT 123,"\n"
PRINT FORMAT("%g\n",1.23)
PRINT "One,Two,Three\n"
 

jrs@laptop:~/sb/sb22/sbt$ scriba tpmain.sb 123 1.23 One,Two,Three 123 1.23 One,Two,Three jrs@laptop:~/sb/sb22/sbt$

111

What's New / Re: SBT - Script BASIC Tutorial API extension module - Thread Support

« on: May 14, 2015, 06:50:20 PM »

I have added thread support to the SBT extension module. It also supports the MT multi-threaded shared (lockable R/W) variable and session manager.

Here is an example of using the MT extension module to communicate between threads and the host script. The command line and configuration file are optional arguments. If not passed, The threaded version of the script uses the internal defaults. This method doesn't provide the paths to the modules & include directory that the configuration file provides. As long as you IMPORT your extension modules in the host script, a simple DECLARE of the function is all that is needed.

ttmain.sb

Code: Script BASIC

IMPORT mt.bas
IMPORT sbt.inc
 
SB_ThreadStart("tt1.sb", "JRS","/etc/scriba/basic.conf")
PRINT "SB Host\n"
LINE INPUT wait
PRINT mt::GetVariable("thread_status"),"\n"
 

tt1.sb

Code: Script BASIC

' Test Thread
 
IMPORT mt.bas
IMPORT sbt.inc
 
cmd = COMMAND()
PRINT cmd,"\n"
 
FOR x = 1 TO 10
  PRINT "Thread 1: ",x,"\n"
NEXT
 
mt::SetVariable "thread_status","Completed"
 
SB_ThreadEnd
 

Output
jrs@laptop:~/sb/sb22/sbt$ scriba ttmain.sb SB Host JRS Thread 1: 1 Thread 1: 2 Thread 1: 3 Thread 1: 4 Thread 1: 5 Thread 1: 6 Thread 1: 7 Thread 1: 8 Thread 1: 9 Thread 1: 10 Completed jrs@laptop:~/sb/sb22/sbt$

112

What's New / dbgcon - Script BASIC remote debugger

« on: May 05, 2015, 07:47:55 PM »

A few years ago I made some bug fixes to Peter's Verhas's experimental sdbg remote Script BASIC debugger. I wrote my own console client in SB which works great. I plan on using some of Dave Zimmer's enhancements to his VB/COM IDE/Debugger preprocessor project to view array contents and trace the call stack. The remote socket based Script BASIC debugger works with both local desktop scripts and remote sbhttpd proxy server web applications.

dbgcon.sb

Code: Script BASIC

' ScriptBasic Remote Console Debugger
 
cmdln = TRIM(COMMAND())
IF cmdln = "" THEN
  PRINT "Usage: dbgcon [prog2debug]\n"
  END
END IF
exitcode = EXECUTE("/usr/bin/scriba -i sdbg " & cmdln,-1,PID)
OPEN "127.0.0.1:6647" FOR SOCKET AS #1
WHILE NOT EOF(1)
  LINE INPUT #1, dbgs
  IF dbgs = ".\n" THEN
    PRINT "-> "
    LINE INPUT dbgc
    IF LCASE(CHOMP(dbgc)) = "h" THEN
PRINT """h help
s step one line
S step one line, do not step into functions or subs
o step until getting out of the current function
  (if you stepped into but changed your mind)
? var  print the value of a variable
u step one level up in the stack
d step one level down in the stack (for variable printing)
D step down in the stack to current execution depth
G list all global variables
L list all local variables
l [n-m] list the source lines
r [n] run to line n
R [n] run to line n but do not stop in recursive function call
b [n] set breakpoint on the line n or the current line
B [n-m] remove breakpoints from lines
q quit the program
"""
    END IF 
    PRINT #1, dbgc
    IF CHOMP(dbgc) = "q" THEN GOTO Done
  ELSE
    dbgcmd = CHOMP(dbgs)
' l - List Source   
    IF INSTR(dbgcmd,"Break-Point: ")<>undef THEN
      p = INSTR(dbgcmd,"Break-Point: ")
      IF MID(dbgcmd,p+13,1) = "0" THEN
        PRINT " "
      ELSE
        PRINT "*"
      END IF
      GOTO IT
    END IF
    IF INSTR(dbgcmd,"Line-Number: ")<>undef THEN
      p = INSTR(dbgcmd,"Line-Number: ")
      PRINT FORMAT("%~[0000] ~",VAL(MID(dbgcmd,p+13)))
      online = TRUE
      GOTO IT
    END IF
    IF INSTR(dbgcmd,"Line: ")<>undef THEN
      p = INSTR(dbgcmd,"Line: ")
      IF online THEN
        PRINT MID(dbgcmd,p+6),"\n"
      ELSE
        PRINT MID(dbgcmd,p),"\n"
      END IF        
      online = FALSE
      GOTO IT
    END IF
    IF INSTR(dbgcmd,"Global-Variable")<>undef THEN
      p = INSTR(dbgcmd,"Global-Variable")
      PRINT "G-Var" & MID(dbgcmd,p+15) & "\n"
      GOTO IT
    END IF
' Unprocessed out
   PRINT dbgs
  END IF
IT:
WEND
 
Done:
PRINT #1,"q"
CLOSE(1)
PRINT "Debug session closed.\n"
END
 

testarray.sb

Code: Script BASIC

' Long / Double / String
i = 1
d = .99
s = "JRS"
' Indices array
a[0,0] = 0
a[0,1] = 123
a[0,2] = 1.23
a[0,3] = "One,Two,Three"
a[1,10] = "Zero"
a[1,11] = 321
a[1,12] = 32.1
a[1,13] = "Three,Two,One"
' Asscociative array
b{"One"} = 1
b{"Two"} = .2
b{"Three"} = "*3*"
' Mix asscociative & indices array
c{"JRS"}[1] = 1
c{"JRS"}[2] = .2
c{"JRS"}[3] = "*3*"
PRINT "Done\n"
 

Output
jrs@laptop:~/sb/sb22/sbt$ scriba dbgcon.sb testarray.sb Application: ScriptBasic Remote Debugger - Linux Version: 1.0 Source-File-Count: 1 Source-File: testarray.sb Line: 2 -> b15 Message: done Line: 2 -> l1- [0001] ' Long / Double / String [0002] i = 1 [0003] d = .99 [0004] s = "JRS" [0005] ' Indices array [0006] a[0,0] = 0 [0007] a[0,1] = 123 [0008] a[0,2] = 1.23 [0009] a[0,3] = "One,Two,Three" [0010] a[1,10] = "Zero" [0011] a[1,11] = 321 [0012] a[1,12] = 32.1 [0013] a[1,13] = "Three,Two,One" [0014] ' Asscociative array *[0015] b{"One"} = 1 [0016] b{"Two"} = .2 [0017] b{"Three"} = "*3*" [0018] ' Mix asscociative & indices array [0019] c{"JRS"}[1] = 1 [0020] c{"JRS"}[2] = .2 [0021] c{"JRS"}[3] = "*3*" [0022] PRINT "Done\n" Line: 2 -> r Line: 15 -> r22 Line: 22 -> G G-Var-Name: VT=0 @ 0x014BBD18 VN=main::i G-Var-Value: 1 G-Var-Name: VT=1 @ 0x014C9258 VN=main::d G-Var-Value: 0.990000 G-Var-Name: VT=2 @ 0x014C92B8 VN=main::s G-Var-Value: "JRS" G-Var-Name: VT=3 @ 0x014C9378 LB=0 : UB=1 VN=main::a G-Var-Value: LB=0 : UB=3 VN=[0] [0] VT=3 @ 0x014C9468 [0] VT=0 @ 0x014C9558 0 [1] VT=0 @ 0x014C96D8 123 [2] VT=1 @ 0x014C9898 1.230000 [3] VT=2 @ 0x014BC0A8 "One,Two,Three" LB=10 : UB=13 VN=[1] [1] VT=3 @ 0x014BC1C8 [10] VT=2 @ 0x014BC228 "Zero" [11] VT=0 @ 0x014BC3A8 321 [12] VT=1 @ 0x014BC568 32.100000 [13] VT=2 @ 0x014BC6D8 "Three,Two,One" G-Var-Name: VT=3 @ 0x014BC798 LB=0 : UB=5 VN=main::b G-Var-Value: [0] VT=2 @ 0x014BC7F8 "One" [1] VT=0 @ 0x014BC8B8 1 [2] VT=2 @ 0x014BC968 "Two" [3] VT=1 @ 0x014BCA28 0.200000 [4] VT=2 @ 0x014BCAE8 "Three" [5] VT=2 @ 0x014BCB48 "*3*" G-Var-Name: VT=3 @ 0x014BCBA8 LB=0 : UB=1 VN=main::c G-Var-Value: [0] VT=2 @ 0x014BCC08 "JRS" LB=1 : UB=3 VN=[1] [1] VT=3 @ 0x014BCCC8 [1] VT=0 @ 0x014BCD88 1 [2] VT=1 @ 0x014BCEA8 0.200000 [3] VT=2 @ 0x014BD5C8 "*3*" Line: 22 -> ?s Value: "JRS" Line: 22 -> ?b Value: [0] VT=2 @ 0x014BC7F8 "One" [1] VT=0 @ 0x014BC8B8 1 [2] VT=2 @ 0x014BC968 "Two" [3] VT=1 @ 0x014BCA28 0.200000 [4] VT=2 @ 0x014BCAE8 "Three" [5] VT=2 @ 0x014BCB48 "*3*" Line: 22 -> r Done Debug session closed. jrs@laptop:~/sb/sb22/sbt$

113

What's New / SBT - Script BASIC Tutorial API extension module

« on: May 05, 2015, 06:14:26 PM »

I have embedded Script BASIC into itself as an easy to use example of the embedding and extension API's. I used the C BASIC C preprocessor defines to extend Script BASIC's extensive macro and define definitions in the interface.c design for readability.

Current SBT Download Attached

SBT interface.c

Code: C

/*  SBT (Script BASIC Tutorial) - Extension Module */
 
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <ctype.h>
#include <math.h>
#include <time.h>
#include <unistd.h>
#include "../../basext.h"
#include "../../scriba.h"
#include "cbasic.h"
 
 
/****************************
 Extension Module Functions
****************************/
 
besVERSION_NEGOTIATE
  RETURN_FUNCTION((int)INTERFACE_VERSION);
besEND
 
besSUB_START
  DIM AS long PTR p;
  besMODULEPOINTER = besALLOC(sizeof(long));
  IF (besMODULEPOINTER EQ NULL) THEN_DO RETURN_FUNCTION(0);
  p = (long PTR)besMODULEPOINTER;
  RETURN_FUNCTION(0);
besEND
 
besSUB_FINISH
  DIM AS long PTR p;
  p = (long PTR)besMODULEPOINTER;
  IF (p EQ NULL) THEN_DO RETURN_FUNCTION(0);
  RETURN_FUNCTION(0);
besEND
 
 
/**********************
 Script BASIC Instance
**********************/
 
/******************
 Support Routines
******************/
 
struct _RunServiceProgram {
  char *pszProgramFileName;
  char *pszCmdLineArgs;
  char *pszConfigFileName;
  pSbProgram pTProgram;
  int iRestart;
  };
  
static void ExecuteProgramThread(void *p){
  pSbProgram pProgram;
  char szInputFile[1024];
  int iErrorCode;
  struct _RunServiceProgram *pRSP;
  pRSP = p;
  strcpy(szInputFile,pRSP->pszProgramFileName);
  pProgram = scriba_new(malloc,free);
  pRSP->pTProgram = pProgram;
  if( pProgram == NULL )return;
  scriba_SetFileName(pProgram,szInputFile);
  if (pRSP->pszConfigFileName != NULL){
        strcpy(szInputFile,pRSP->pszConfigFileName);
        scriba_LoadConfiguration(pProgram, pRSP->pszConfigFileName);
  }else{
        scriba_SetProcessSbObject(pProgram,pProgram);
  }     
  scriba_LoadSourceProgram(pProgram);
  if (pRSP->pszCmdLineArgs != NULL){
        strcpy(szInputFile,pRSP->pszCmdLineArgs);
    iErrorCode = scriba_Run(pProgram,pRSP->pszCmdLineArgs);
  }else{
    iErrorCode = scriba_Run(pProgram,NULL);
  }     
//  scriba_destroy(pProgram);
  return;
} 
 
besFUNCTION(SB_New)
  DIM AS pSbProgram sbobj;
  sbobj = scriba_new(malloc,free);
  besRETURN_LONG(sbobj);
besEND
 
besFUNCTION(SB_Configure)
  DIM AS unsigned long sbobj;
  DIM AS char PTR cfgfilename;
  DIM AS int rtnval = -1;
  besARGUMENTS("iz")
    AT sbobj, AT cfgfilename
  besARGEND
  rtnval = scriba_LoadConfiguration(sbobj, cfgfilename);
  besRETURN_LONG(rtnval);
besEND
 
besFUNCTION(SB_Load)
  DIM AS unsigned long sbobj;
  DIM AS char PTR sbfilename;
  DIM AS int rtnval = -1;
  besARGUMENTS("iz")
    AT sbobj, AT sbfilename
  besARGEND
  rtnval = scriba_SetFileName(sbobj, sbfilename);
  scriba_LoadSourceProgram(sbobj);
  besRETURN_LONG(rtnval);
besEND
 
besFUNCTION(SB_LoadStr)
  DIM AS unsigned long sbobj;
  DIM AS char PTR sbpgm;
  DIM AS int rtnval = -1;
  besARGUMENTS("iz")
    AT sbobj, AT sbpgm
  besARGEND
  scriba_SetFileName(sbobj, "fake");
  rtnval = scriba_LoadProgramString(sbobj, sbpgm, strlen(sbpgm));
  besRETURN_LONG(rtnval);
besEND
 
besFUNCTION(SB_Run)
  DIM AS unsigned long sbobj;
  DIM AS int rtnval;
  DIM AS char PTR sbcmdline;
  besARGUMENTS("iz")
    AT sbobj, AT sbcmdline
  besARGEND
  IF (besARGNR < 2) THEN_DO sbcmdline = "";
  rtnval = scriba_Run(sbobj, sbcmdline);
  besRETURN_LONG(rtnval);
besEND
 
besFUNCTION(SB_NoRun)
  DIM AS unsigned long sbobj;
  DIM AS int rtnval;
  besARGUMENTS("i")
    AT sbobj
  besARGEND
  rtnval = scriba_NoRun(sbobj);
  besRETURN_LONG(rtnval);
besEND
 
besFUNCTION(SB_ThreadStart)
  DIM AS struct _RunServiceProgram PTR pRSP;
  DIM AS THREADHANDLE T;
  DIM AS char PTR pszProgramFileName;
  DIM AS char PTR pszCmdLineArgs;
  DIM AS char PTR pszConfigFileName;
  DIM AS unsigned long rtnval;
  besARGUMENTS("z[z][z]")
    AT pszProgramFileName, AT pszCmdLineArgs, AT pszConfigFileName
  besARGEND
  pRSP = (struct _RunServiceProgram PTR)malloc( sizeof(struct _RunServiceProgram) );
  pRSP->pszProgramFileName = (char PTR)malloc(strlen(pszProgramFileName) + 1);  
  strcpy(pRSP->pszProgramFileName,pszProgramFileName);
  IF (pszCmdLineArgs NE NULL) THEN
    pRSP->pszCmdLineArgs = (char PTR)malloc(strlen(pszCmdLineArgs) + 1);  
    strcpy(pRSP->pszCmdLineArgs,pszCmdLineArgs);
  ELSE
        pRSP->pszCmdLineArgs = NULL;
  END_IF
  IF (pszConfigFileName NE NULL) THEN
    pRSP->pszConfigFileName = (char PTR)malloc(strlen(pszConfigFileName) + 1);  
    strcpy(pRSP->pszConfigFileName,pszConfigFileName);
  ELSE
        pRSP->pszConfigFileName = NULL;
  END_IF
  pRSP->iRestart = 0;
  thread_CreateThread(AT T,ExecuteProgramThread,pRSP);
  usleep(500);
  rtnval = pRSP->pTProgram;
  besRETURN_LONG(rtnval);
besEND
 
besFUNCTION(SB_ThreadEnd)
  thread_ExitThread();
  besRETURNVALUE = NULL;
besEND
 
besFUNCTION(SB_Destroy)
  DIM AS unsigned long sbobj;
  besARGUMENTS("i")
    AT sbobj
  besARGEND
  scriba_destroy(sbobj);
  RETURN_FUNCTION(0);
besEND
 
besFUNCTION(SB_CallSub)
  DIM AS unsigned long sbobj;
  DIM AS int funcsernum;
  DIM AS char PTR funcname;
  besARGUMENTS("iz")
    AT sbobj, AT funcname
  besARGEND
  funcsernum = scriba_LookupFunctionByName(sbobj, funcname);
  besRETURN_LONG(scriba_Call(sbobj, funcsernum));
besEND
 
besFUNCTION(SB_CallSubArgs)
  DIM AS VARIABLE Argument;
  DIM AS SbData ArgData[8];
  DIM AS SbData FunctionResult;
  DIM AS unsigned long sbobj;
  DIM AS char PTR funcname;
  DIM AS int i, sbtype, fnsn;
 
  Argument = besARGUMENT(1);
  besDEREFERENCE(Argument);
  sbobj = LONGVALUE(Argument);
 
  Argument = besARGUMENT(2);
  besDEREFERENCE(Argument);
  funcname = STRINGVALUE(Argument);
 
  DEF_FOR (i = 3 TO i <= besARGNR STEP INCR i)
  BEGIN_FOR
    Argument = besARGUMENT(i);
    besDEREFERENCE(Argument);
    SELECT_CASE (sbtype = TYPE(Argument))
    BEGIN_SELECT
      CASE VTYPE_LONG:
        ArgData[i-3] = PTR scriba_NewSbLong(sbobj, LONGVALUE(Argument));
        END_CASE
      CASE VTYPE_DOUBLE:
        ArgData[i-3] = PTR scriba_NewSbDouble(sbobj, DOUBLEVALUE(Argument));
        END_CASE
      CASE VTYPE_STRING:
        ArgData[i-3] = PTR scriba_NewSbString(sbobj, STRINGVALUE(Argument));
        END_CASE
      CASE_ELSE
        ArgData[i-3] = PTR scriba_NewSbUndef(sbobj);
        END_CASE
    END_SELECT
  NEXT
 
  fnsn = scriba_LookupFunctionByName(sbobj, funcname);
  scriba_CallArgEx(sbobj, fnsn, AT FunctionResult, besARGNR - 2, AT ArgData);
 
  SELECT_CASE (FunctionResult.type)
  BEGIN_SELECT
    CASE SBT_LONG:
      besRETURN_LONG(FunctionResult.v.l);
      END_CASE
    CASE SBT_DOUBLE:
      besRETURN_DOUBLE(FunctionResult.v.d);
      END_CASE
    CASE SBT_STRING:
      besRETURN_STRING(FunctionResult.v.s);
      END_CASE
    CASE SBT_UNDEF:
      besRETURNVALUE = NULL;
      END_CASE
  END_SELECT
besEND
 
besFUNCTION(SB_GetVar)
  DIM AS pSbData varobj;
  DIM AS unsigned long sbobj;
  DIM AS int vsn;
  DIM AS char PTR varname;
  besARGUMENTS("iz")
    AT sbobj, AT varname
  besARGEND
  vsn = scriba_LookupVariableByName(sbobj, varname);
  scriba_GetVariable(sbobj, vsn, AT varobj);
  SELECT_CASE (scriba_GetVariableType(sbobj, vsn))
  BEGIN_SELECT
    CASE SBT_LONG   :
      besRETURN_LONG(varobj[0].v.l);
      END_CASE
    CASE SBT_DOUBLE :
      besRETURN_DOUBLE(varobj[0].v.d);
      END_CASE
    CASE SBT_STRING :
      besRETURN_STRING(varobj[0].v.s);
      END_CASE
    CASE SBT_UNDEF  :
      besRETURNVALUE = NULL;;
      END_CASE
  END_SELECT
besEND
 
besFUNCTION(SB_SetUndef)
  DIM AS pSbData varobj;
  DIM AS unsigned long sbobj;
  DIM AS int vsn;
  DIM AS char PTR varname;
  besARGUMENTS("iz")
    AT sbobj, AT varname
  besARGEND
  vsn = scriba_LookupVariableByName(sbobj, varname);
  besRETURN_LONG(scriba_SetVariable(sbobj, vsn, SBT_UNDEF, NULL, 0, "", 0));
besEND
 
besFUNCTION(SB_SetInt)
  DIM AS VARIABLE Argument;
  DIM AS pSbData varobj;
  DIM AS unsigned long sbobj;
  DIM AS int vsn, usrval, i;
  DIM AS char PTR varname;
  IF (besARGNR < 3) THEN_DO RETURN_FUNCTION(EX_ERROR_TOO_FEW_ARGUMENTS);
  DEF_FOR (i = 1 TO i <= 3 STEP INCR i)
  BEGIN_FOR
    Argument = besARGUMENT(i);
    besDEREFERENCE(Argument);
    IF (i EQ 1) THEN_DO sbobj = LONGVALUE(Argument);
    IF (i EQ 2) THEN_DO varname = STRINGVALUE(Argument);
    IF (i EQ 3) THEN_DO usrval = LONGVALUE(Argument);
  NEXT
  vsn = scriba_LookupVariableByName(sbobj, varname);
  besRETURN_LONG(scriba_SetVariable(sbobj, vsn, SBT_LONG, usrval, 0, "", 0));
besEND
 
besFUNCTION(SB_SetDbl)
  DIM AS VARIABLE Argument;
  DIM AS pSbData varobj;
  DIM AS unsigned long sbobj;
  DIM AS int vsn, i;
  DIM AS char PTR varname;
  DIM AS double usrval;
  IF (besARGNR < 3) THEN_DO RETURN_FUNCTION(EX_ERROR_TOO_FEW_ARGUMENTS);
  DEF_FOR (i = 1 TO i <= 3 STEP INCR i)
  BEGIN_FOR
    Argument = besARGUMENT(i);
    besDEREFERENCE(Argument);
    IF (i EQ 1) THEN_DO sbobj = LONGVALUE(Argument);
    IF (i EQ 2) THEN_DO varname = STRINGVALUE(Argument);
    IF (i EQ 3) THEN_DO usrval = DOUBLEVALUE(Argument);
  NEXT
  vsn = scriba_LookupVariableByName(sbobj, varname);
  besRETURN_LONG(scriba_SetVariable(sbobj, vsn,  SBT_DOUBLE, 0, usrval, "", 0));
besEND
 
besFUNCTION(SB_SetStr)
  DIM AS VARIABLE Argument;
  DIM AS pSbData varobj;
  DIM AS unsigned long sbobj;
  DIM AS int vsn, i;
  DIM AS char PTR varname;
  DIM AS char PTR usrval;
  IF (besARGNR < 3) THEN_DO RETURN_FUNCTION(EX_ERROR_TOO_FEW_ARGUMENTS);
  DEF_FOR (i = 1 TO i <= 3 STEP INCR i)
  BEGIN_FOR
    Argument = besARGUMENT(i);
    besDEREFERENCE(Argument);
    IF (i EQ 1) THEN_DO sbobj = LONGVALUE(Argument);
    IF (i EQ 2) THEN_DO varname = STRINGVALUE(Argument);
    IF (i EQ 3) THEN_DO usrval = STRINGVALUE(Argument);
  NEXT
  vsn = scriba_LookupVariableByName(sbobj, varname);
  besRETURN_LONG(scriba_SetVariable(sbobj, vsn,  SBT_STRING, 0, 0, usrval, strlen(usrval)));
besEND
 
besFUNCTION(SB_ResetVars)
  DIM AS unsigned long sbobj;
  besARGUMENTS("i")
    AT sbobj
  besARGEND
  scriba_ResetVariables(sbobj);
  besRETURNVALUE = NULL;
besEND
 

sbt.inc

Code: Script BASIC

DECLARE SUB SB_New ALIAS "SB_New" LIB "sbt"
DECLARE SUB SB_Configure ALIAS "SB_Configure" LIB "sbt"
DECLARE SUB SB_Load ALIAS "SB_Load" LIB "sbt"
DECLARE SUB SB_LoadStr ALIAS "SB_LoadStr" LIB "sbt"
DECLARE SUB SB_Run ALIAS "SB_Run" LIB "sbt"
DECLARE SUB SB_NoRun ALIAS "SB_NoRun" LIB "sbt"
DECLARE SUB SB_ThreadStart ALIAS "SB_ThreadStart" LIB "sbt"
DECLARE SUB SB_ThreadEnd ALIAS "SB_ThreadEnd" LIB "sbt"
DECLARE SUB SB_GetVar ALIAS "SB_GetVar" LIB "sbt"
DECLARE SUB SB_SetUndef ALIAS "SB_SetUndef" LIB "sbt"
DECLARE SUB SB_SetInt ALIAS "SB_SetInt" LIB "sbt"
DECLARE SUB SB_SetDbl ALIAS "SB_SetDbl" LIB "sbt"
DECLARE SUB SB_SetStr ALIAS "SB_SetStr" LIB "sbt"
DECLARE SUB SB_ResetVars ALIAS "SB_ResetVars" LIB "sbt"
DECLARE SUB SB_CallSub ALIAS "SB_CallSub" LIB "sbt"
DECLARE SUB SB_CallSubArgs ALIAS "SB_CallSubArgs" LIB "sbt"
DECLARE SUB SB_Destroy ALIAS "SB_Destroy" LIB "sbt"
 

sbtdemo.sb

Code: Script BASIC

' SBT (Script BASIC Tutorial) - Example Script
 
IMPORT sbt.inc
 
sb_code = """
FUNCTION prtvars(a, b, c)
  PRINT a,"\\n"
  PRINT FORMAT("%g\\n", b)
  PRINT c,"\\n"
  prtvars = "Function Return"
END FUNCTION
 
a = 0
b = 0
c = ""
"""
 
sb = SB_New()
SB_Configure sb, "/etc/scriba/basic.conf"
SB_LoadStr sb, sb_code
SB_NoRun sb
funcrtn = SB_CallSubArgs(sb,"main::prtvars", 123, 1.23, "One, Two, Three")
PRINT funcrtn,"\n"
SB_Run sb, ""
SB_SetInt sb, "main::a", 321
SB_SetDbl sb, "main::b", 32.1
SB_SetStr sb, "main::c", "Three,Two,One"
SB_CallSubArgs sb, "main::prtvars", _
          SB_GetVar(sb, "main::a"), _
          SB_GetVar(sb, "main::b"), _
          SB_GetVar(sb, "main::c")      
SB_Destroy sb
 

Output
jrs@laptop:~/sb/sb22/sbt$ time scriba sbtdemo.sb 123 1.23 One, Two, Three Function Return 321 32.1 Three,Two,One real 0m0.007s user 0m0.007s sys 0m0.000s jrs@laptop:~/sb/sb22/sbt$

114

Business BASIC Migrations / Business BASIC Helper Library

« on: May 04, 2015, 01:30:51 AM »

Here are a few ProvideX Business Basic like functions that can be used to help with your conversion to Script BASIC.

Code: Script BASIC

' BB Function Helper Library
 
 
' BB_ATH - Business BASIC ATH() function
'
' Converts a text string of hex character pairs to ASCII values.
'
FUNCTION BB_ATH(HexStr)
 
  LOCAL LenHex, AsciiStr, HexTable, ScanPos, HiByte, LowByte
  LenHex = LEN(HexStr)
  IF LenHex % 2 = 0 THEN
    HexTable = "0123456789ABCDEF"
    FOR ScanPos = 1 TO LenHex STEP 2
      HiByte = INSTR(HexTable,UCASE(MID(HexStr, ScanPos, 1))) - 1
      LowByte = INSTR(HexTable,UCASE(MID(HexStr, ScanPos + 1, 1))) - 1
      IF ISINTEGER(HiByte) AND ISINTEGER(LowByte) THEN
        AsciiStr &= CHR(HiByte * 16 + LowByte)
      ELSE
        AsciiStr = ""
        GOTO Exit_For        
      END IF
    NEXT ScanPos
    Exit_For:
  ELSE
    AsciiStr = ""
  END IF
  BB_ATH = AsciiStr
 
END FUNCTION
 
 
' BB_CVS - Business Basic CVS() function
'
' Action:
'  1   = Remove Leading characters
'  2   = Remove Trailing characters
'  4   = Convert String to Upper Case
'  8   = Convert String to Lower Case
'  16  = Replace characters < 32 with the control character
'  32  = Replace multiple occurrence of the character with one
'  64  = * Replace $ with defined Windows currency symbol
'  128 = * Replace defined Windows currency, comma and thousand symbol
'  256 = * Ucase first char of each word, rest to lower
'    * = Not implemented yet.
'
FUNCTION BB_CVS(StrExpr, Action, CtrlChar)
 
  LOCAL Char, ExprLen, TempStr, ScanPos 
  IF CtrlChar = undef THEN CtrlChar = " "
  Char = ASC(CtrlChar)
  
  ' Remove Leading characters
  IF (Action AND 1) THEN   
    ExprLen = LEN(StrExpr)
    IF CtrlChar = " " THEN
      StrExpr = LTRIM(StrExpr)
    ELSE
      TempStr = ""
      FOR ScanPos = 1 TO ExprLen
        IF MID(StrExpr, ScanPos, 1) <> CtrlChar THEN TempStr &= MID(StrExpr, ScanPos, 1)
      NEXT ScanPos
      StrExpr = TempStr
    END IF
  END IF
  
  ' Remove Trailing characters
  IF (Action AND 2) THEN   
    ExprLen = LEN(StrExpr)
    IF CtrlChar = " " THEN
      StrExpr = RTRIM(StrExpr)
    ELSE
      TempStr = ""
      FOR ScanPos = ExprLen TO 1 STEP - 1
        IF MID(StrExpr, ScanPos, 1) = CtrlChar THEN TempStr = LEFT(StrExpr, ScanPos - 1)
      NEXT ScanPos
      IF LEN(TempStr) THEN StrExpr = TempStr
    END IF
  END IF
  
  ' Convert String to Upper Case
  IF (Action AND 4) THEN   
    StrExpr = UCASE(StrExpr)
  END IF
  
  ' Convert String to Lower Case
  IF (Action AND 8) THEN   
    StrExpr = LCASE(StrExpr)
  END IF
  
  ' Replace characters < 32 with the control character
  IF (Action AND 16) THEN  
    FOR ScanPos = 1 TO LEN(StrExpr)
         IF ASC(MID(StrExpr, ScanPos, 1)) < 32 THEN StrExpr = LEFT(StrExpr, ScanPos -1) & CtrlChar & MID(StrExpr, ScanPos + 1)
    NEXT ScanPos
  END IF
  
  ' Replace multiple occurence of the character with one
  IF (Action AND 32) THEN  
    HitCnt = 0
    StartPos = 1
    NextPos:
    ScanPos = INSTR(StrExpr,CtrlChar,StartPos)
    IF ISINTEGER(ScanPos) THEN
      IF HitCnt THEN   
        IF ASC(MID(StrExpr, ScanPos,1)) = CtrlChar THEN TeStrExpr = LEFT(StrExpr, ScanPos -1) & MID(StrExpr, ScanPos + 1)
      ELSE
        HitCnt += 1
      END IF
      StartPos += 1
      GOTO NextPos
    END IF
  END IF         
  BB_CVS = StrExpr
 
END FUNCTION
 
 
' BB_DEC - Business BASIC DEC() function
'
' Returns a two's complement binary equivalent of the string.
'
FUNCTION BB_DEC(BinStr)                                   
 
  LOCAL i, d                                       
  FOR i = LEN(BinStr) TO 1 STEP -1                         
    d += ASC(MID(BinStr,i,1)) * 256 ^ ABS(i - LEN(BinStr))
  NEXT i                                                    
  BB_DEC = d                                                
 
END FUNCTION                                               
 
 
' BB_HTA - Business BASIC HTA() function
'
' Returns the hexadecimal text string of the pasted argument string.
'
FUNCTION BB_HTA(AsciiStr)
  LOCAL AsciiLen,ScanPos,HexStr
  AsciiLen = LEN(AsciiStr)
  IF AsciiLen THEN
    FOR ScanPos = 1 TO AsciiLen
      HexStr &= RIGHT("0" & HEX(ASC(MID(AsciiStr, ScanPos, 1))),2)
    NEXT ScanPos
  ELSE
    HexStr = ""
  END IF
  BB_HTA = HexStr
END FUNCTION
 
 
' BB_JUL - Business BASIC JUL() function
'
' Converts a date from year, month, day to a Julian date.
'
FUNCTION BB_JUL(Y,M,D)
 
  IF Y = undef AND M = undef AND D = undef THEN
    BB_JUL = NOW
  ELSE
    BB_JUL = TIMEVALUE(Y,M,D)
  END IF
 
END FUNCTION
 
 
' BB_LRC - Business Basic LRC() function.
'
' Returns a one byte string containing the longitudinal redundancy checksum of a character string.
'
FUNCTION BB_LRC(ArgStr)
 
  LOCAL ArgStrLen, ScanPos, LRCVal
  LRCVal = 0
  ArgStrLen = LEN(ArgStr)
  IF ArgStrLen THEN
    FOR ScanPos = 1 TO ArgStrLen
      LRCVal += LRCVal XOR ASC(MID(ArgStr, ScanPos, 1))
    NEXT ScanPos
    BB_LRC = CHR(LRCVal)
  ELSE
    BB_LRC = CHR(&H00)
  END IF
 
END FUNCTION
 
 
' BB_PAD - Business BASIC PAD() funtion
'
' Returns a character string of the length specified (NumExpr)
'
' NOTE: StrExpr    = String to be processed
'       NewLen     = Desired length of string
'       HowToPad   = This parameter defines how to pad the string
'                     0 - Pad on left  (right justify)
'                     1 - Pad on right (left justify)
'                     2 - Center in string
'       StrPad     = First character of this string used to pad StrExpr
'
FUNCTION BB_PAD(StrExpr,NewLen,HowToPad,StrPad)
 
  LOCAL StrExpr,NewLen,HowToPad,StrPad,PadVal,StrExprLen,ResultStr,RLPLen
  IF HowToPad = undef THEN
    PadVal = 1 
  ELSE IF HowToPad = 0 OR UCASE(HowToPad) = "L" THEN
    PadVal = 0
  ELSE IF HowToPad = 1 OR UCASE(HowToPad) = "R" THEN  
    PadVal = 1
  ELSE IF HowToPad = 2 OR UCASE(HowToPad) = "C" THEN       
    PadVal = 2
  ELSE
    BB_ERR = 41
    BB_PAD = ""
    EXIT FUNCTION
  END IF
  
  IF StrPad = undef THEN StrPad = " "
  StrExprLen = LEN(StrExpr)
  
  IF PadVal = 0 THEN
    IF NewLen < StrExprLen THEN
      ResultStr = RIGHT(StrExpr, NewLen)
    ELSE
      ResultStr = STRING(NewLen - StrExprLen, StrPad) & StrExpr
    END IF
  END IF
 
  IF PadVal = 1 THEN
    IF NewLen < StrExprLen THEN
      ResultStr = LEFT(StrExpr, NewLen)
    ELSE
      ResultStr = StrExpr & STRING(NewLen - StrExprLen, StrPad)
    END IF
  END IF
 
  IF PadVal = 2 THEN
    IF NewLen < StrExprLen THEN
      ResultStr = LEFT(StrExpr, NewLen)
    ELSE
      RLPLen = (NewLen - StrExprLen) / 2
      IF RLPLen % 2 THEN
        ResultStr = STRING(FIX(RLPLen),StrPad) & StrExpr & STRING(FIX(RLPLen) + 1,StrPad)
      ELSE
        ResultStr = STRING(RLPLen,StrPad) & StrExpr & STRING(RLPLen,StrPad)
      END IF
    ENDIF
  END IF
 
  BB_PAD = ResultStr
  
END FUNCTION
 
 
' BB_POS - Business Basic POS() function
' 
' BB_POS follows these logic steps:
'
' 1. If stringA or StringB is null, return 0
' 2. Start with first byte in stringB if intA is positive, or the Nth byte
'    from the end of stringB if intA is negatine (-N).
' 3. If past either the begining or end of stringB then return 0
'    (or occurrence count if intB is 0)
' 4. Compare stringA with the substring at the current position in stringB.
'    The length of substring will be either the length of stringA or the
'    remainder of stringB, whichever is shorter.
' 5. If a given releationship is true and if this was the Nth successful
'    try (specified by intB=N) then return the current scan position.
' 6. If the relation was not satisfied then bump the scan position
'    (possibly backwards if intA is negative) and go to step 3 and try again.
'
' Relationship Operators:
'
' "="   -   Equal To
' "<"   -   Less Than
' ">"   -   Greater Than
' "<="  -   Less Than Or Equal To
' ">="  -   Greater Than Or Equal To
' "<>"  -   Not Equal To
' ":"   -   Equal to Any
' "^"   -   Not Equal To Any
'
FUNCTION BB_POS(MatchStr,ScanStr,Relate,IncVal,OccurVal)
 
  LOCAL LenMatchStr,LenScanStr,ScanPos,OccurCnt,Item,StartVal,EndVal
  IF Relate = undef THEN Relate = "="
  IF IncVal = undef  THEN IncVal = 1
  IF OccurVal = undef  THEN OccurVal = 1
  LenMatchStr = LEN(MatchStr)
  IF INSTR(":^", Relate) THEN LenMatchStr = 1
  LenScanStr = LEN(ScanStr)
  IF LenMatchStr = 0 OR LenScanStr = 0 OR OccurVal < 0 THEN
    BB_POS = 0
    EXIT FUNCTION
  END IF
  IF IncVal > 0 THEN
    StartVal = 1
    EndVal = LenScanStr
  ELSE
    StartVal = LenScanStr
    EndVal = 1
  END IF
  FOR ScanPos = StartVal TO EndVal STEP IncVal
    Item = MID(ScanStr, ScanPos, LenMatchStr)
    IF Relate = "=" THEN
      IF MatchStr = Item THEN OccurCnt += 1
    ELSE IF Relate = "<" THEN
      IF MatchStr < Item THEN OccurCnt += 1
    ELSE IF Relate = ">" THEN
      IF MatchStr > Item THEN OccurCnt += 1
    ELSE IF Relate = "<=" OR Relate = "=<" THEN
      IF MatchStr <= Item THEN OccurCnt += 1
    ELSE IF Relate = ">=" OR Relate = "=>" THEN
      IF MatchStr >= Item THEN OccurCnt += 1
    ELSE IF Relate = "<>" OR Relate = "><" THEN
      IF MatchStr <> Item THEN OccurCnt += 1
    ELSE IF Relate = ":" THEN
      IF INSTR(MatchStr, Item) THEN OccurCnt += 1
    ELSE IF Relate = "^" THEN
      IF NOT ISNUMERIC(INSTR(MatchStr, Item)) THEN OccurCnt += 1
    ELSE
      BB_POS = 0
      EXIT FUNCTION
    END IF
    IF OccurVal > 0 THEN
      IF OccurCnt = OccurVal THEN GOTO Done
    END IF
  NEXT ScanPos
 
  Done:
 
  IF OccurVal = 0 THEN
    BB_POS = OccurCnt
  ELSE IF OccurCnt THEN
    BB_POS = ScanPos
  ELSE
    BB_POS = 0  
  END IF
 
END FUNCTION
 

bbtest.sb

Code: Script BASIC

' bb.inc test script
 
IMPORT bb.inc
 
 
PRINT "HTA()\n"
hta = BB_HTA("Script BASIC")
PRINT hta,"\n\n"
PRINT "ATH()\n"
PRINT BB_ATH(hta),"\n\n"
PRINT "PAD()\n"
s = BB_PAD("BASIC",10,2," ")
PRINT "|" & s & "|\n\n"
PRINT "POS()\n"
s = "The quick brown fox"
' yields 5
PRINT BB_POS("q",s,"="),"\n"
' yields 0
PRINT BB_POS("z",s,"="),"\n" 
' yields 13
PRINT BB_POS("o",s,"=") ,"\n"
' yields 18 - Scan from end (fox)
PRINT BB_POS("o",s,"=",-1),"\n"
' yields 18 - Second occurrence (fox)
PRINT BB_POS("o",s,"=",1,2),"\n" 
' yields 13 - Checks every 2nd position
PRINT BB_POS("o",s,"=",2),"\n" 
' yields 6 - "u" is first char. > "r"
PRINT BB_POS("r",s,"<"),"\n" 
PRINT "CVS()\n"
s = "  sb  "
PRINT "|" & BB_CVS(s,3," "),"|\n"
PRINT "|" & BB_CVS(s,4,""),"|\n\n"
 

115

MY-BASIC / MY-BASIC Extension Module

« on: April 24, 2015, 09:35:40 PM »

Here is an example of the new MY-BASIC extension module for Script BASIC. Attached is the Windows 32 bit and Linux (Ubuntu) 64 bit shared objects. (dll/so)

interface.c

Code: C

// MY-BASIC - Script BASIC extension module
 
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <stdarg.h>
#include <ctype.h>
#include <math.h>
#include <time.h>
#include "../../basext.h"
#include "cbasic.h"
 
#include "my_basic.h"
 
 
/****************************
 Extension Module Functions
****************************/
 
besVERSION_NEGOTIATE
  RETURN_FUNCTION((int)INTERFACE_VERSION);
besEND
 
besSUB_START
  DIM AS long PTR p;
  besMODULEPOINTER = besALLOC(sizeof(long));
  IF (besMODULEPOINTER EQ NULL) THEN_DO RETURN_FUNCTION(0);
  p = (long PTR)besMODULEPOINTER;
  RETURN_FUNCTION(0);
besEND
 
besSUB_FINISH
  DIM AS long PTR p;
  p = (long PTR)besMODULEPOINTER;
  IF (p EQ NULL) THEN_DO RETURN_FUNCTION(0);
  RETURN_FUNCTION(0);
besEND
 
 
/********************
 MY-BASIC Functions
********************/
 
static struct mb_interpreter_t* bas = 0;
 
static int watch(struct mb_interpreter_t* s, void** l) {
  int result = MB_FUNC_OK;
  int_t arg = 0;
  mb_assert(s && l);
  mb_check(mb_attempt_open_bracket(s, l));
  mb_check(mb_pop_int(s, l, &arg)); // That's it!
  mb_check(mb_attempt_close_bracket(s, l));
  // arg is what you want.
  return result;
}
 
besFUNCTION(mbas_init)
  besRETURN_LONG(mb_init());
besEND
 
besFUNCTION(mbas_dispose)
  besRETURN_LONG(mb_dispose());
besEND
 
besFUNCTION(mbas_open)
  besRETURN_LONG(mb_open(AT bas));
besEND
 
besFUNCTION(mbas_close)
  besRETURN_LONG(mb_close(AT bas));
besEND
 
besFUNCTION(mbas_load_str)
  DIM AS const char PTR pgm;
  besARGUMENTS("z")
    AT pgm
  besARGEND
  besRETURN_LONG(mb_load_string(bas, pgm));
besEND
 
besFUNCTION(mbas_load_file)
  DIM AS const char PTR pgm;
  besARGUMENTS("z")
    AT pgm
  besARGEND
  besRETURN_LONG(mb_load_file(bas, pgm));
besEND
 
besFUNCTION(mbas_run)
  besRETURN_LONG(mb_run(bas));
besEND
 
besFUNCTION(mbas_reset)
  besRETURN_LONG(mb_reset(bas, false));
besEND
 
besFUNCTION(mbas_getint)
  DIM AS mb_value_t mbval;
  DIM AS const char PTR varname;
  besARGUMENTS("z")
    AT varname
  besARGEND
  mbval.type = MB_DT_INT;
  mb_debug_get(bas, varname, &mbval);
  besRETURN_LONG(mbval.value.integer);
besEND
 
besFUNCTION(mbas_getdbl)
  DIM AS mb_value_t mbval;
  DIM AS const char PTR varname;
  besARGUMENTS("z")
    AT varname
  besARGEND
  mbval.type = MB_DT_REAL;
  mb_debug_get(bas, varname, &mbval);
  besRETURN_DOUBLE(mbval.value.float_point);
besEND
 
besFUNCTION(mbas_getstr)
  DIM AS mb_value_t mbval;
  DIM AS const char PTR varname;
  besARGUMENTS("z")
    AT varname
  besARGEND
  mbval.type = MB_DT_STRING;
  mb_debug_get(bas, varname, &mbval);
  besRETURN_STRING(mbval.value.string);
besEND
 
besFUNCTION(mbas_setint)
  DIM AS VARIABLE Argument;
  DIM AS mb_value_t mbval;
  DIM AS int usrval, i, rtnval;
  DIM AS const char PTR varname;
  IF (besARGNR < 2) THEN_DO RETURN_FUNCTION(EX_ERROR_TOO_FEW_ARGUMENTS);
  DEF_FOR (i = 1 TO i <= 2 STEP INCR i)
  BEGIN_FOR
    Argument = besARGUMENT(i);
    besDEREFERENCE(Argument);
    IF (i EQ 1) THEN_DO varname = STRINGVALUE(Argument);
    IF (i EQ 2) THEN_DO usrval = LONGVALUE(Argument);
  NEXT
  mbval.type = MB_DT_INT;
  mbval.value.integer = usrval;
  rtnval = mb_debug_set(bas, varname, mbval);
  besRETURN_LONG(rtnval);
besEND
 
besFUNCTION(mbas_setdbl)
  DIM AS VARIABLE Argument;
  DIM AS mb_value_t mbval;
  DIM AS int i, rtnval;
  DIM AS double usrval;
  DIM AS const char PTR varname;
  IF (besARGNR < 2) THEN_DO RETURN_FUNCTION(EX_ERROR_TOO_FEW_ARGUMENTS);
  DEF_FOR (i = 1 TO i <= 2 STEP INCR i)
  BEGIN_FOR
    Argument = besARGUMENT(i);
    besDEREFERENCE(Argument);
    IF (i EQ 1) THEN_DO varname = STRINGVALUE(Argument);
    IF (i EQ 2) THEN_DO usrval = DOUBLEVALUE(Argument);
  NEXT
  mbval.type = MB_DT_REAL;
  mbval.value.float_point = usrval;
  rtnval = mb_debug_set(bas, varname, mbval);
  besRETURN_LONG(rtnval);
besEND
 
besFUNCTION(mbas_setstr)
  DIM AS VARIABLE Argument;
  DIM AS mb_value_t mbval;
  DIM AS int i, rtnval;
  DIM AS const char PTR varname;
  DIM AS const char PTR usrval;
  IF (besARGNR < 2) THEN_DO RETURN_FUNCTION(EX_ERROR_TOO_FEW_ARGUMENTS);
  DEF_FOR (i = 1 TO i <= 2 STEP INCR i)
  BEGIN_FOR
    Argument = besARGUMENT(i);
    besDEREFERENCE(Argument);
    IF (i EQ 1) THEN_DO varname = STRINGVALUE(Argument);
    IF (i EQ 2) THEN_DO usrval = STRINGVALUE(Argument);
  NEXT
  mbval.type = MB_DT_STRING;
  usrval = mb_memdup(usrval, strlen(usrval) + 1);
  mbval.value.string = usrval;
  besRETURN_LONG(mb_debug_set(bas, varname, mbval));
besEND
 

mbvars.sb

Code: Script BASIC

DECLARE SUB mb_init ALIAS "mbas_init" LIB "mb"
DECLARE SUB mb_dispose ALIAS "mbas_dispose" LIB "mb"
DECLARE SUB mb_open ALIAS "mbas_open" LIB "mb"
DECLARE SUB mb_close ALIAS "mbas_close" LIB "mb"
DECLARE SUB mb_load_str ALIAS "mbas_load_str" LIB "mb"
DECLARE SUB mb_load_file ALIAS "mbas_load_file" LIB "mb"
DECLARE SUB mb_run ALIAS "mbas_run" LIB "mb"
DECLARE SUB mb_getint ALIAS "mbas_getint" LIB "mb"
DECLARE SUB mb_getdbl ALIAS "mbas_getdbl" LIB "mb"
DECLARE SUB mb_getstr ALIAS "mbas_getstr" LIB "mb"
DECLARE SUB mb_setint ALIAS "mbas_setint" LIB "mb"
DECLARE SUB mb_setdbl ALIAS "mbas_setdbl" LIB "mb"
DECLARE SUB mb_setstr ALIAS "mbas_setstr" LIB "mb"
DECLARE SUB mb_reset ALIAS "mbas_reset" LIB "mb"
 
mb_init
mb_open
mb_load_file "setvars.bas"
mb_run
mb_setint "A", 123
mb_setdbl "B", 1.23
mb_setstr "C$", "One,Two,Three"
PRINT mb_getint("A"),"\n"
PRINT FORMAT("%g\n", mb_getdbl("B"))
PRINT mb_getstr("C$"),"\n"
mb_close
mb_dispose
 

setvars.bas

Code: [Select]

a = 0
b = 0.0
c$ = ""

Output - Linux 64 bit
jrs@laptop:~/sb/sb22/mybasic$ time scriba mbvars.sb 123 1.23 One,Two,Three real 0m0.006s user 0m0.005s sys 0m0.005s jrs@laptop:~/sb/sb22/mybasic$

Output - Windows 32 bit
C:\sb22\mybasic>scriba mbvars.sb 123 1.23 One,Two,Three C:\sb22\mybasic>

116

TinyScheme / Re: TinyScheme Extension Module

« on: April 21, 2015, 07:12:46 PM »

Here is a Prime Number example done in TinyScheme by Mike (FBSL author)

Code: Script BASIC

IMPORT ts.inc
 
sc = TS_New()
TS_Cmd sc, "(load \"init.scm\")"
ts_src = """
(define (prime? n)
  (if (< n 4) (> n 1)
      (and (odd? n)
           (let loop ((k 3))
             (or (> (* k k) n)
                 (and (positive? (remainder n k))
                      (loop (+ k 2))))))))
 
(define (main)
  (do ((i 3 (+ i 2)))
    ((> i 4999) #t)
      (if (prime? i) (begin (display i)(display " ")) "")
  )
  (newline)
)
 
(main)
"""
PRINT TS_Cmd(sc, ts_src),"\n"
TS_Close sc
 

Output
jrs@laptop:~/sb/sb22/TS$ time scriba tspnmike.sb 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97 101 103 107 109 113 127 131 137 139 149 151 157 163 167 173 179 181 191 193 197 199 211 223 227 229 233 239 241 251 257 263 269 271 277 281 283 293 307 311 313 317 331 337 347 349 353 359 367 373 379 383 389 397 401 409 419 421 431 433 439 443 449 457 461 463 467 479 487 491 499 503 509 521 523 541 547 557 563 569 571 577 587 593 599 601 607 613 617 619 631 641 643 647 653 659 661 673 677 683 691 701 709 719 727 733 739 743 751 757 761 769 773 787 797 809 811 821 823 827 829 839 853 857 859 863 877 881 883 887 907 911 919 929 937 941 947 953 967 971 977 983 991 997 1009 1013 1019 1021 1031 1033 1039 1049 1051 1061 1063 1069 1087 1091 1093 1097 1103 1109 1117 1123 1129 1151 1153 1163 1171 1181 1187 1193 1201 1213 1217 1223 1229 1231 1237 1249 1259 1277 1279 1283 1289 1291 1297 1301 1303 1307 1319 1321 1327 1361 1367 1373 1381 1399 1409 1423 1427 1429 1433 1439 1447 1451 1453 1459 1471 1481 1483 1487 1489 1493 1499 1511 1523 1531 1543 1549 1553 1559 1567 1571 1579 1583 1597 1601 1607 1609 1613 1619 1621 1627 1637 1657 1663 1667 1669 1693 1697 1699 1709 1721 1723 1733 1741 1747 1753 1759 1777 1783 1787 1789 1801 1811 1823 1831 1847 1861 1867 1871 1873 1877 1879 1889 1901 1907 1913 1931 1933 1949 1951 1973 1979 1987 1993 1997 1999 2003 2011 2017 2027 2029 2039 2053 2063 2069 2081 2083 2087 2089 2099 2111 2113 2129 2131 2137 2141 2143 2153 2161 2179 2203 2207 2213 2221 2237 2239 2243 2251 2267 2269 2273 2281 2287 2293 2297 2309 2311 2333 2339 2341 2347 2351 2357 2371 2377 2381 2383 2389 2393 2399 2411 2417 2423 2437 2441 2447 2459 2467 2473 2477 2503 2521 2531 2539 2543 2549 2551 2557 2579 2591 2593 2609 2617 2621 2633 2647 2657 2659 2663 2671 2677 2683 2687 2689 2693 2699 2707 2711 2713 2719 2729 2731 2741 2749 2753 2767 2777 2789 2791 2797 2801 2803 2819 2833 2837 2843 2851 2857 2861 2879 2887 2897 2903 2909 2917 2927 2939 2953 2957 2963 2969 2971 2999 3001 3011 3019 3023 3037 3041 3049 3061 3067 3079 3083 3089 3109 3119 3121 3137 3163 3167 3169 3181 3187 3191 3203 3209 3217 3221 3229 3251 3253 3257 3259 3271 3299 3301 3307 3313 3319 3323 3329 3331 3343 3347 3359 3361 3371 3373 3389 3391 3407 3413 3433 3449 3457 3461 3463 3467 3469 3491 3499 3511 3517 3527 3529 3533 3539 3541 3547 3557 3559 3571 3581 3583 3593 3607 3613 3617 3623 3631 3637 3643 3659 3671 3673 3677 3691 3697 3701 3709 3719 3727 3733 3739 3761 3767 3769 3779 3793 3797 3803 3821 3823 3833 3847 3851 3853 3863 3877 3881 3889 3907 3911 3917 3919 3923 3929 3931 3943 3947 3967 3989 4001 4003 4007 4013 4019 4021 4027 4049 4051 4057 4073 4079 4091 4093 4099 4111 4127 4129 4133 4139 4153 4157 4159 4177 4201 4211 4217 4219 4229 4231 4241 4243 4253 4259 4261 4271 4273 4283 4289 4297 4327 4337 4339 4349 4357 4363 4373 4391 4397 4409 4421 4423 4441 4447 4451 4457 4463 4481 4483 4493 4507 4513 4517 4519 4523 4547 4549 4561 4567 4583 4591 4597 4603 4621 4637 4639 4643 4649 4651 4657 4663 4673 4679 4691 4703 4721 4723 4729 4733 4751 4759 4783 4787 4789 4793 4799 4801 4813 4817 4831 4861 4871 4877 4889 4903 4909 4919 4931 4933 4937 4943 4951 4957 4967 4969 4973 4987 4993 4999 real 0m0.394s user 0m0.392s sys 0m0.000s jrs@laptop:~/sb/sb22/TS$

117

What's New / Re: Perl Extension Module

« on: April 08, 2015, 11:56:17 PM »

Here is the above Perl example using the Script BASIC re (regx) extension module. This example is in 32 Windows XP as re seq faults under 64 bit. $:-\$

Code: Script BASIC

IMPORT re.bas
 
SUB test(regx, target)
  IF re::match(target,regx) THEN
    PRINT regx," is in ",target,"      <",re::dollar(0),">\n"
  ELSE
    PRINT regx," is NOT in ",target,"\n"
  END IF
END SUB
 
test("st.v.", "steve was here")
test("st.v.", "kitchen stove")
test("st.v.", "kitchen store")
 
PRINTNL  
 

Output

C:\sb22\test>scriba testregx.sb st.v. is in steve was here <steve> st.v. is in kitchen stove <stove> st.v. is NOT in kitchen store C:\sb22\test>

118

What's New / Re: Perl Extension Module

« on: April 08, 2015, 09:41:40 PM »

The following is a Perl example of using regular expression parsing. (regx)

Code: Script BASIC

DECLARE SUB pl_Init ALIAS "pl_Init" LIB "sbperl"
DECLARE SUB pl_Eval ALIAS "pl_Eval" LIB "sbperl"
DECLARE SUB pl_GetInt ALIAS "pl_GetInt" LIB "sbperl"
DECLARE SUB pl_GetDbl ALIAS "pl_GetDbl" LIB "sbperl"
DECLARE SUB pl_GetStr ALIAS "pl_GetStr" LIB "sbperl"
DECLARE SUB pl_Destroy ALIAS "pl_Destroy" LIB "sbperl"
 
pl_Init
 
pl_code = """
sub test($$)
        {
        my $lookfor = shift;
        my $string = shift;
        print "\n$lookfor ";
        if($string =~ m/($lookfor)/)
                {
                print " is in ";
                }
        else
                {
                print " is NOT in ";
                }
        print "$string.";
        if(defined($1))
                {
                print "      <$1>";
                }
        print "\n";
        }
 
test("st.v.", "steve was here");
test("st.v.", "kitchen stove");
test("st.v.", "kitchen store");
"""
PRINTNL
 
pl_Eval pl_code
 
pl_Destroy
 

Output

jrs@laptop:~/sb/sb22/test$ time scriba perlmatch.sb st.v. is in steve was here. <steve> st.v. is in kitchen stove. <stove> st.v. is NOT in kitchen store. real 0m0.004s user 0m0.000s sys 0m0.004s jrs@laptop:~/sb/sb22/test$

119

What's New / Re: Perl Extension Module

« on: April 08, 2015, 10:45:31 AM »

Perl has an console interactive (debugger) mode you can play with.

jrs@laptop:~/sb/sb22/test$ perl -d -e 1 Loading DB routines from perl5db.pl version 1.39_10 Editor support available. Enter h or 'h h' for help, or 'man perldebug' for more help. main::(-e:1): 1 DB<1> h List/search source lines: Control script execution: l [ln|sub] List source code T Stack trace - or . List previous/current line s [expr] Single step [in expr] v [line] View around line n [expr] Next, steps over subs f filename View source in file <CR/Enter> Repeat last n or s /pattern/ ?patt? Search forw/backw r Return from subroutine M Show module versions c [ln|sub] Continue until position Debugger controls: L List break/watch/actions o [...] Set debugger options t [n] [expr] Toggle trace [max depth] ][trace expr] <[<]|{[{]|>[>] [cmd] Do pre/post-prompt b [ln|event|sub] [cnd] Set breakpoint ! [N|pat] Redo a previous command B ln|* Delete a/all breakpoints H [-num] Display last num commands a [ln] cmd Do cmd before line = [a val] Define/list an alias A ln|* Delete a/all actions h [db_cmd] Get help on command w expr Add a watch expression h h Complete help page W expr|* Delete a/all watch exprs |[|]db_cmd Send output to pager ![!] syscmd Run cmd in a subprocess q or ^D Quit R Attempt a restart Data Examination: expr Execute perl code, also see: s,n,t expr x|m expr Evals expr in list context, dumps the result or lists methods. p expr Print expression (uses script's current package). S [[!]pat] List subroutine names [not] matching pattern V [Pk [Vars]] List Variables in Package. Vars can be ~pattern or !pattern. X [Vars] Same as "V current_package [Vars]". i class inheritance tree. y [n [Vars]] List lexicals in higher scope <n>. Vars same as V. e Display thread id E Display all thread ids. For more help, type h cmd_letter, or run man perldebug for all docs. DB<1>

120

What's New / Re: Perl Extension Module

« on: April 08, 2015, 09:11:33 AM »

Here is the current Script BASIC interface.c (sbperl.so) extension module source.

Perl Embedding API Documentation

Code: C

/* Perl - Script BASIC extension module
 
UXLIBS: -lperl
 
*/
 
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <ctype.h>
#include <math.h>
#include <time.h>
#include "../../basext.h"
#include "cbasic.h"
 
#include <EXTERN.h>
#include <perl.h>
 
static PerlInterpreter *my_perl;
 
/****************************
 Extension Module Functions
****************************/
 
besVERSION_NEGOTIATE
  RETURN_FUNCTION((int)INTERFACE_VERSION);
besEND
 
besSUB_START
  DIM AS long PTR p;
  besMODULEPOINTER = besALLOC(sizeof(long));
  IF (besMODULEPOINTER EQ NULL) THEN_DO RETURN_FUNCTION(0);
  p = (long PTR)besMODULEPOINTER;
  RETURN_FUNCTION(0);
besEND
 
besSUB_FINISH
  DIM AS long PTR p;
  p = (long PTR)besMODULEPOINTER;
  IF (p EQ NULL) THEN_DO RETURN_FUNCTION(0);
  RETURN_FUNCTION(0);
besEND
 
 
/****************
 Perl Functions
****************/
 
besFUNCTION(pl_Init)
  DIM AS char *embedding[] = { "", "-e", "0" };
  my_perl = perl_alloc();
  perl_construct(my_perl);
  perl_parse(my_perl, NULL, 3, embedding, NULL);
  perl_run(my_perl);
  besRETURN_LONG(my_perl);
besEND
 
besFUNCTION(pl_Eval)
  DIM AS const char PTR cmdstr;
  besARGUMENTS("z")
    AT cmdstr
  besARGEND
  eval_pv(cmdstr, TRUE);
  besRETURNVALUE = NULL;
besEND
 
besFUNCTION(pl_GetInt)
  DIM AS const char PTR cmdstr;
  DIM AS int rtnval;
  besARGUMENTS("z")
    AT cmdstr
  besARGEND
  rtnval = SvIV(get_sv(cmdstr, FALSE));
  besRETURN_LONG(rtnval);
besEND
 
besFUNCTION(pl_GetDbl)
  DIM AS const char PTR cmdstr;
  DIM AS double rtnval;
  besARGUMENTS("z")
    AT cmdstr
  besARGEND
  rtnval = SvNV(get_sv(cmdstr, FALSE));
  besRETURN_DOUBLE(rtnval);
besEND
 
besFUNCTION(pl_GetStr)
  DIM AS const char PTR cmdstr;
  DIM AS char PTR rtnval;
  DIM AS STRLEN n_a;
  besARGUMENTS("z")
    AT cmdstr
  besARGEND
  rtnval = SvPV(get_sv(cmdstr, FALSE), n_a);
  besRETURN_STRING(rtnval);
besEND
 
besFUNCTION(pl_Destroy)
  perl_destruct(my_perl);
  perl_free(my_perl);
  besRETURNVALUE = NULL;
besEND
 

Pages: 1 ... 6 7 [8] 9 10 ... 59

News:

Show Posts

Messages - Support

What's New / SBx 3 Forms

What's New / IUP Threaded - Linux 64 bit - SBT 3*3

What's New / IUP Threaded - Linux 64 bit - SBT

What's New / IUP Threaded - Windows 32 bit - DLLC

What's New / Re: SBT - Thread Enhancements

What's New / Re: SBT - Script BASIC Tutorial API extension module - Thread Support

What's New / dbgcon - Script BASIC remote debugger

What's New / SBT - Script BASIC Tutorial API extension module

Business BASIC Migrations / Business BASIC Helper Library

MY-BASIC / MY-BASIC Extension Module

TinyScheme / Re: TinyScheme Extension Module

What's New / Re: Perl Extension Module

What's New / Re: Perl Extension Module

What's New / Re: Perl Extension Module

What's New / Re: Perl Extension Module

**What's New / IUP Threaded - Linux 64 bit - SBT 3*3**