QB code > FreeBasic fblite HELP

DOS specific questions.
Post Reply
Cpcdos
Posts: 207
Joined: Mar 06, 2013 13:52
Location: France - LYON 69003
Contact:

QB code > FreeBasic fblite HELP

Post by Cpcdos »

Hello people !

I would know if possible, you can to convert a QuickBasic (4.5) code to FreeBasic with fblite for me ? :-)


This is the Qb4.5 code :

Code: Select all

' WebServ 0.9 beta (c)2006 Mike Chambers
' Simple single-threaded web server written in QuickBASIC.
' Visit http://rubbermallet.org for updated
'
' QB must be loaded with QB.QLB quicklibrary like this:
' QB.EXE /L QB.QLB

TYPE Registers
     ax AS INTEGER
     bx AS INTEGER
     cx AS INTEGER
     dx AS INTEGER
     bp AS INTEGER
     si AS INTEGER
     di AS INTEGER
     flags AS INTEGER
     ds AS INTEGER
     es AS INTEGER
END TYPE

'Define custom data type for nTCP-related data.
TYPE nTCP
        Enabled AS INTEGER
        IntVector AS INTEGER
        ErrorCode AS INTEGER
        LocalIP AS LONG
        LocalNetmask AS LONG
        LocalGateway AS LONG
        LocalDNS AS LONG
        LocalDomain AS STRING * 256
        DomainLen AS INTEGER
        Timeserver AS LONG
        MTU AS INTEGER
        TTL AS INTEGER
        TOS AS INTEGER
        MSS AS INTEGER
        RWIN AS INTEGER
        FreeInputPkts AS INTEGER
        FreeOutputPkts AS INTEGER
        Timeout AS INTEGER
END TYPE

'Define custom error type constants and other frequently used values.
CONST errBadCall = 1
CONST errCritical = 2
CONST errNoHandles = 3
CONST errBadHandle = 4
CONST errTimeout = 5
CONST errBadSession = 6

CONST sckListening = 1
CONST sckOpen = 4
CONST sckClosed = 7

DECLARE FUNCTION Conv2IP$ (DWord AS LONG)
DECLARE FUNCTION Conv2DWord$ (inString AS STRING)
DECLARE FUNCTION HighByte% (Word AS INTEGER)
DECLARE FUNCTION LowByte% (Word AS INTEGER)

'IMPORTANT: DO NOT USE THE tcpFindInt FUNCTION AS IT IS NOW!
'IT DOES NOT WORK RIGHT. I AM WORKING ON IT.
DECLARE FUNCTION tcpFindInt% (startSegment AS INTEGER, endSegment AS INTEGER)
DECLARE FUNCTION tcpInit% (Vector AS INTEGER)
DECLARE FUNCTION tcpConnect% (RemoteIP AS STRING, RemotePort AS INTEGER)
DECLARE FUNCTION tcpStatus% (tcpHandle AS INTEGER)
DECLARE FUNCTION MakeReg% (h AS INTEGER, l AS INTEGER)
DECLARE FUNCTION tcpListen% (ListenPort AS INTEGER)
DECLARE SUB AddBuffer (textadd AS STRING)
DECLARE SUB DrawScreen ()
DECLARE SUB tcpUnload ()
DECLARE SUB tcpSetTimeout (TimeoutSeconds AS INTEGER)
DECLARE SUB RegBlank ()
DECLARE FUNCTION tcpGetData$ (tcpHandle AS INTEGER)
DECLARE SUB tcpClose (tcpHandle AS INTEGER)
DECLARE FUNCTION tcpInBuffer% (tcpHandle AS INTEGER)
DECLARE FUNCTION tcpInputQueue% (tcpHandle AS INTEGER)
DECLARE FUNCTION tcpRemoteIP$ (tcpHandle AS INTEGER)
DECLARE SUB tcpSendData (tcpHandle AS INTEGER, Data2Send AS STRING)
DECLARE SUB tcpDoIO ()
DECLARE SUB showErrorMsg ()

DECLARE SUB interruptx (intnum AS INTEGER, inreg AS Registers, outreg AS Registers)

'The debugShowReturn subroutine simply prints all the register values
'stored in tcpReturn to the screen. You really shouldn't have any reason
'to use it unless you are curious about the specifics behind NTCPDRV.
'It is mainly here for my own purposes.
DECLARE SUB debugShowReturn ()

DEFINT A-Z

'Dimension variables that are shared between all subroutines and functions.
DIM SHARED tcpCall AS Registers
DIM SHARED tcpReturn AS Registers
DIM SHARED tcpDriver AS nTCP
DIM SHARED isActive AS INTEGER
DIM SHARED strGetData AS STRING * 1500
DIM SHARED strSendData AS STRING * 1500

DIM SHARED mime(1 TO 100, 1 TO 2) AS STRING
DIM SHARED mimetotal AS INTEGER

DIM SHARED stat(0 TO 1) AS STRING
DIM SHARED scrlog(0 TO 17) AS STRING
DIM SHARED logfile$

'This makes all CPU-blocking calls timeout after 5 seconds.
tcpSetTimeout 5

SCREEN 0: WIDTH 80, 25: CLS
logfile$ = "%none"

AddBuffer "---------------------------------------"
AddBuffer "WebServ v0.9 beta (c)2006 Mike Chambers"
AddBuffer "http://www.rubbermallet.org"
AddBuffer "---------------------------------------"
AddBuffer "Please direct all bug reports to: half_eaten@yahoo.com"
AddBuffer ""
AddBuffer "Loading WEBSERV.INI configuration..."
DrawScreen
OPEN "WEBSERV.INI" FOR BINARY AS #1: filsiz = LOF(1): CLOSE #1
IF filsiz = 0 THEN
        AddBuffer "FATAL ERROR: Can't find configuration!"
        AddBuffer "Press any key to quit to DOS..."
        DO: LOOP UNTIL INKEY$ <> ""
        COLOR 7, 0: CLS : END
END IF

OPEN "WEBSERV.INI" FOR INPUT AS #1
mimenum = 1
DO UNTIL EOF(1)
        INPUT #1, directive$
        IF LEFT$(directive$, 1) <> "#" THEN
        SELECT CASE LCASE$(directive$)
        CASE "tcpvector"
                LINE INPUT #1, vect$
                tcpVect% = VAL("&H" + vect$)
                AddBuffer "Using TCPDRV interrupt vector " + HEX$(tcpVect%) + "h."
       
        CASE "folder"
                LINE INPUT #1, htdocs$
                AddBuffer "Using documents folder " + htdocs$
        
        CASE "port"
                INPUT #1, portnr%
                AddBuffer "Serving on port" + STR$(portnr%) + "."

        CASE "logfile"
                LINE INPUT #1, logtemp$
                AddBuffer "Using output text log file " + logtemp$

        CASE "mime"
                INPUT #1, fileext$
                LINE INPUT #1, mimename$
                'AddBuffer "Adding mimetype: " + fileext$ + " = " + mimename$
                mime(mimenum, 1) = fileext$
                mime(mimenum, 2) = mimename$
                mimenum = mimenum + 1

        CASE "error"
                LINE INPUT #1, err404$
                AddBuffer "Using error page " + err404$
       
        CASE "hostname"
                LINE INPUT #1, localname$
        END SELECT
        DrawScreen
        END IF
LOOP
CLOSE #1
mimetotal = mimenum - 1
AddBuffer "Loaded" + STR$(mimenum) + " mime types from configuration file."
DrawScreen

IF tcpInit(tcpVect%) <> 1 THEN END
AddBuffer ""
logfile$ = logtemp$
IF logfile$ <> "%none" THEN
        OPEN logfile$ FOR BINARY AS #2: CLOSE #2
        'Make sure file exists before opening FOR APPEND to avoid errors.
        OPEN logfile$ FOR APPEND AS #2
        PRINT #2,
        PRINT #2, "----[ LOG SECTION BEGIN @ " + TIME$ + " ON " + DATE$ + " ]----"
        CLOSE #2
END IF

AddBuffer "Web server initialized."
IF LCASE$(localname$) = "%ip" THEN localname$ = Conv2IP$(tcpDriver.LocalIP)

DO
stat(0) = "Waiting for connection on port" + STR$(portnr%) + "..."
stat(1) = STRING$(76, "°")
DrawScreen
hand% = tcpListen(portnr%)
DO
        IF INKEY$ = CHR$(27) THEN tcpClose hand%: END
LOOP UNTIL tcpStatus(hand%) = sckOpen

header$ = ""
DO
        nd$ = tcpGetData(hand%)
        IF nd$ <> "" THEN header$ = header$ + nd$
        tcpDoIO
        retn% = tcpStatus(hand%)
        IF retn% = sckClosed OR retn% = 0 THEN EXIT DO
LOOP UNTIL INSTR(1, header$, CHR$(13) + CHR$(10) + CHR$(13) + CHR$(10))
xp = INSTR(1, LCASE$(header$), "get ")
IF xp THEN
        header$ = MID$(header$, xp + 4)
        IF LEFT$(header$, 1) <> "/" THEN header$ = "/" + header$
        xp = INSTR(1, header$, " ")
        IF xp THEN header$ = LEFT$(header$, xp - 1)
        filename$ = ""
        FOR n = 1 TO LEN(header$)
                cc$ = MID$(header$, n, 1)
                SELECT CASE cc$
                CASE ""
                CASE "/"
                        filename$ = filename$ + "\"
                CASE ELSE
                        filename$ = filename$ + cc$
                END SELECT
        NEXT n
                IF RIGHT$(filename$, 1) = "\" THEN filename$ = filename$ + "INDEX.HTM"
                             
                shl$ = "DIR " + htdocs$ + filename$ + " /b >exist.tmp"
                LOCATE 1, 1: SHELL shl$
                OPEN "exist.tmp" FOR BINARY AS #1: CLOSE #1
                OPEN "exist.tmp" FOR INPUT AS #1
                IF LOF(1) THEN LINE INPUT #1, check$ ELSE check$ = ""
                CLOSE #1
                KILL "exist.tmp"
                IF check$ = "" THEN errorpage = 1 ELSE errorpage = 0

                FOR n = LEN(filename$) TO 1 STEP -1
                        IF MID$(filename$, n, 1) = "." THEN EXIT FOR
                NEXT n
                FOR num = 1 TO mimetotal
                        IF LCASE$(MID$(filename$, n)) = LCASE$(mime(num, 1)) THEN
                                content$ = mime(num, 2)
                                EXIT FOR
                        END IF
                NEXT num
                IF num > mimetotal THEN content$ = "text/text"
                IF errorpage = 1 THEN content$ = "text/html"
               
                buffadd$ = DATE$ + " " + TIME$ + " - " + tcpRemoteIP(hand%) + " GET " + filename$
                IF errorpage = 0 THEN
                        OPEN htdocs$ + filename$ FOR BINARY AS #1
                        buffadd$ = buffadd$ + " (" + MID$(STR$(LOF(1)), 2) + " bytes)"
                ELSE
                        OPEN err404$ FOR BINARY AS #1
                        buffadd$ = buffadd$ + " (404 not found)"
                END IF
                AddBuffer buffadd$
                DrawScreen

                tcpSendData hand%, "HTTP/1.1 200 OK" + CHR$(13) + CHR$(10)
                tcpSendData hand%, "Content-type: " + content$ + CHR$(13) + CHR$(10)
                tcpSendData hand%, "Content-length:" + STR$(LOF(1)) + CHR$(13) + CHR$(10) + CHR$(13) + CHR$(10)

                ratio! = 76 / 100
                exitserv = 0
                DO UNTIL EOF(1) OR LOF(1) <= LOC(1)
                IF INKEY$ = CHR$(27) THEN exitserv = 1: EXIT DO
                a$ = SPACE$(1500)
                IF LOF(1) - LOC(1) < 1500 THEN a$ = SPACE$(LOF(1) - LOC(1))
                GET #1, , a$
                IF errorpage = 1 THEN
                        xp = INSTR(1, a$, "%date")
                        IF xp THEN a$ = LEFT$(a$, xp - 1) + DATE$ + MID$(a$, xp + 5)

                        xp = INSTR(1, a$, "%time")
                        IF xp THEN a$ = LEFT$(a$, xp - 1) + TIME$ + MID$(a$, xp + 5)

                        xp = INSTR(1, a$, "%host")
                        IF xp THEN a$ = LEFT$(a$, xp - 1) + localname$ + MID$(a$, xp + 5)
                END IF
                tcpSendData hand%, a$
               
                retn% = tcpStatus(hand%)
                IF retn% = 0 OR retn% = sckClosed THEN EXIT DO

                pct% = FIX((LOC(1) / LOF(1)) * 100)
                stat(0) = "Sending file: " + filename$ + " (" + MID$(STR$(LOC(1)), 2) + " of" + STR$(LOF(1)) + ") -" + STR$(pct%) + "%"
                stat(1) = STRING$(FIX(pct% * ratio!), "²") + STRING$(76 - FIX(pct% * ratio!), "°")
                LOCATE 2, 1
                PRINT "º " + LEFT$(stat(0) + SPACE$(76), 76) + " º";
                PRINT "º " + LEFT$(stat(1) + SPACE$(76), 76) + " º";
                LOOP
                CLOSE #1
                IF exitserv = 1 THEN EXIT DO
END IF
tcpClose hand%
LOOP
tcpClose hand% 'Just to make sure.
END

SUB AddBuffer (textadd AS STRING)
IF logfile$ <> "%none" THEN OPEN logfile$ FOR APPEND AS #2

DIM tempText AS STRING
tempText = textadd
DO
FOR tn = 1 TO 17
        scrlog(tn - 1) = scrlog(tn)
NEXT tn
scrlog(17) = LEFT$(tempText, 76)
IF logfile$ <> "%none" THEN PRINT #2, LEFT$(tempText, 76)

tempText = MID$(tempText, 77)
LOOP UNTIL tempText = ""
IF logfile$ <> "%none" THEN CLOSE #2
END SUB

DEFSNG A-Z
FUNCTION Conv2DWord$ (inString AS STRING)
'The inString variable should be an IPv4 address in the standard
'format of x.x.x.x

DIM tempArray(3) AS STRING * 1
DIM tempVal AS INTEGER

tempVal = INSTR(1, inString, ".")
IF tempVal THEN
        tempArray(0) = CHR$(VAL(LEFT$(inString, tempVal)))
        inString = MID$(inString, tempVal + 1)
ELSE
        EXIT FUNCTION
END IF

tempVal = INSTR(1, inString, ".")
IF tempVal THEN
        tempArray(1) = CHR$(VAL(LEFT$(inString, tempVal)))
        inString = MID$(inString, tempVal + 1)
ELSE
        EXIT FUNCTION
END IF

tempVal = INSTR(1, inString, ".")
IF tempVal THEN
        tempArray(2) = CHR$(VAL(LEFT$(inString, tempVal)))
        inString = MID$(inString, tempVal + 1)
ELSE
        EXIT FUNCTION
END IF

tempArray(3) = CHR$(VAL(inString))
Conv2DWord$ = tempArray(0) + tempArray(1) + tempArray(2) + tempArray(3)
END FUNCTION

FUNCTION Conv2IP$ (DWord AS LONG)
DIM tempStr AS STRING * 4

tempStr = MKL$(DWord)
Conv2IP$ = MID$(STR$(ASC(LEFT$(tempStr, 1))), 2) + "." + MID$(STR$(ASC(MID$(tempStr, 2, 1))), 2) + "." + MID$(STR$(ASC(MID$(tempStr, 3, 1))), 2) + "." + MID$(STR$(ASC(RIGHT$(tempStr, 1))), 2)
END FUNCTION

SUB debugShowReturn
PRINT "   ax:" + STR$(tcpReturn.ax) + " (" + HEX$(tcpReturn.ax) + "h)"
PRINT "   bx:" + STR$(tcpReturn.bx) + " (" + HEX$(tcpReturn.bx) + "h)"
PRINT "   cx:" + STR$(tcpReturn.cx) + " (" + HEX$(tcpReturn.cx) + "h)"
PRINT "   dx:" + STR$(tcpReturn.dx) + " (" + HEX$(tcpReturn.dx) + "h)"
PRINT "   bp:" + STR$(tcpReturn.bp) + " (" + HEX$(tcpReturn.bp) + "h)"
PRINT "   si:" + STR$(tcpReturn.si) + " (" + HEX$(tcpReturn.si) + "h)"
PRINT "   di:" + STR$(tcpReturn.di) + " (" + HEX$(tcpReturn.di) + "h)"
PRINT "flags:" + STR$(tcpReturn.flags) + " (" + HEX$(tcpReturn.flags) + "h)"
PRINT "   ds:" + STR$(tcpReturn.ds) + " (" + HEX$(tcpReturn.ds) + "h)"
PRINT "   es:" + STR$(tcpReturn.es) + " (" + HEX$(tcpReturn.es) + "h)"
END SUB

DEFINT A-Z
SUB DrawScreen
COLOR 7, 0: LOCATE 1, 1
PRINT "É͹ Transfer Ì" + STRING$(65, "Í") + "»";
PRINT "º " + LEFT$(stat(0) + SPACE$(76), 76) + " º";
PRINT "º " + LEFT$(stat(1) + SPACE$(76), 76) + " º";
PRINT "È" + STRING$(78, "Í") + "¼";
PRINT "É͹ Log Ì" + STRING$(70, "Í") + "»";
FOR tn = 0 TO 17
        PRINT "º " + LEFT$(scrlog(tn) + SPACE$(76), 76) + " º";
NEXT tn
PRINT "È" + STRING$(78, "Í") + "¼";
LOCATE 25, 45
PRINT "To shut down this server, hit ESC.";
END SUB

DEFSNG A-Z
FUNCTION HighByte% (Word AS INTEGER)
HighByte% = ASC(RIGHT$(MKI$(Word), 1))
END FUNCTION

FUNCTION LowByte% (Word AS INTEGER)
LowByte% = ASC(LEFT$(MKI$(Word), 1))
END FUNCTION

FUNCTION MakeReg% (h AS INTEGER, l AS INTEGER)
MakeReg% = CVI(CHR$(l) + CHR$(h))
END FUNCTION

SUB RegBlank
tcpCall.ax = 0
tcpCall.bx = 0
tcpCall.cx = 0
tcpCall.dx = 0
tcpCall.bp = 0
tcpCall.si = 0
tcpCall.di = 0
tcpCall.flags = 0
tcpCall.ds = 0
tcpCall.es = 0
END SUB

SUB showErrorMsg
PRINT "ERROR CODE" + STR$(tcpDriver.ErrorCode) + "!!! ";
SELECT CASE tcpDriver.ErrorCode
        CASE errBadCall
                PRINT "err_badcall"
        CASE errCritical
                PRINT "err_critical"
        CASE errNoHandles
                PRINT "err_nohandles"
        CASE errBadHandle
                PRINT "err_badhandle"
        CASE errTimeout
                PRINT "err_timeout"
        CASE errBadSession
                PRINT "err_badsession"
END SELECT
END SUB

SUB tcpClose (tcpHandle AS INTEGER)
tcpCall.ax = MakeReg(&H11, 1)
tcpCall.bx = tcpHandle
tcpCall.dx = 0

CALL interruptx(tcpDriver.IntVector, tcpCall, tcpReturn)
tcpDriver.ErrorCode = LowByte(tcpReturn.dx)
END SUB

FUNCTION tcpConnect% (RemoteIP AS STRING, RemotePort AS INTEGER)
DIM tempRemoteIP AS STRING
tempRemoteIP = Conv2DWord(RemoteIP)

tcpCall.ax = MakeReg(&H10, 0)
tcpCall.bx = 0
tcpCall.cx = RemotePort
tcpCall.dx = tcpDriver.Timeout
tcpCall.di = CVI(LEFT$(tempRemoteIP, 2))
tcpCall.si = CVI(RIGHT$(tempRemoteIP, 2))
CALL interruptx(tcpDriver.IntVector, tcpCall, tcpReturn)

dummyLocalPortNr% = tcpReturn.ax
'PRINT "Local port:"; dummyLocalPortNr%

tcpConnect% = tcpReturn.bx 'Makes this function return the TCPDRV handle number.
tcpDriver.ErrorCode = LowByte(tcpReturn.dx)
END FUNCTION

SUB tcpDoIO
'Allows TCPDRV to perform processing of data. THIS MUST BE CALLED REGULARLY
'for packets to be processed! If you don't do this, TCPDRV will eventually
'crash when it runs out of storage space for input and output queues.

'RegBlank
tcpCall.ax = MakeReg(&H2, 0)
tcpCall.dx = 0 'tcpDriver.Timeout
CALL interruptx(tcpDriver.IntVector, tcpCall, tcpReturn)

tcpDriver.ErrorCode = LowByte(tcpReturn.dx)
END SUB

FUNCTION tcpFindInt% (startSegment AS INTEGER, endSegment AS INTEGER)
'If either or both startSegment or endSegment is zero, use standard NTCPDRV
'segment range of 60h to 7Fh for scanning.
IF startSegment = 0 OR endSegment = 0 THEN
        startSegment = &H60
        endSegment = &H7F
END IF

DIM tempScan AS INTEGER
DIM tempScan2 AS LONG

FOR tempScan = startSegment TO endSegment
        DEF SEG = tempScan
        FOR tempScan2 = 0 TO 65535
                'If current offset in this segment is the letter T
                '(ASCII value 84), then check the next 7 bytes for "CP_DRVR"
                '(excluding quotes). If they are, we've found our NTCPDRV
                'interrupt vector! :)
                IF PEEK(tempScan2) = 84 THEN
                        'This next line is huge, sorry. I know I could have had
                        'it convert each of these bytes to its ASCII string value
                        'with CHR$(PEEK(blah)) and put them together as tempStr$
                        'then say `IF tempStr$ = "CP_DRVR" THEN' for much sexier
                        'looking code, but I want these routines to be as fast as
                        'possible. We would waste valuable CPU cycles with that
                        'process. What if somebody is running this on an 8088? :)
                        IF PEEK(tempScan2 + 1) = 67 AND PEEK(tempScan2 + 2) = 80 AND PEEK(tempScan2 + 3) = 95 AND PEEK(tempScan2 + 4) = 68 AND PEEK(tempScan2 + 5) = 82 AND PEEK(tempScan2 + 6) = 86 AND PEEK(tempScan2 + 7) = 82 THEN
                                'Got our segment, so return it!
                                tcpFindInt% = tempScan + 1
                                EXIT FUNCTION
                        END IF

                END IF
        NEXT tempScan2
NEXT tempScan
tcpFindInt% = 0
'Yeah, yeah... I know tcpFindInt% should already be zero since we could
'not locate a NTCPDRV interrupt segment in the given range, but now we
'KNOW it is, right? Can't go wrong with that! :)
END FUNCTION

FUNCTION tcpGetData$ (tcpHandle AS INTEGER)
tcpCall.ax = MakeReg(&H12, 1)
tcpCall.bx = tcpHandle
tcpCall.es = VARSEG(strGetData)
tcpCall.di = VARPTR(strGetData)
tcpCall.cx = 1500
tcpCall.dx = 0
CALL interruptx(tcpDriver.IntVector, tcpCall, tcpReturn)
tcpGetData$ = LEFT$(strGetData, tcpReturn.ax)

tcpDriver.ErrorCode = LowByte(tcpReturn.dx)
END FUNCTION

FUNCTION tcpInBuffer% (tcpHandle AS INTEGER)
dummy1% = tcpStatus%(tcpHandle)
IF isActive > 0 THEN
        tcpInBuffer% = tcpReturn.ax
END IF
tcpDriver.ErrorCode = LowByte(tcpReturn.dx)
END FUNCTION

FUNCTION tcpInit% (Vector AS INTEGER)
'If given vector value is zero, assume the usual vector 61h.
IF Vector = 0 THEN Vector = &H61

tcpCall.ax = MakeReg(&H0, &HFF)
CALL interruptx(Vector, tcpCall, tcpReturn)

'This next line sets tcpDriver.Enabled to zero, sets the tcpInit function
'return value to zero, and exits the function immediately if the interrupt
'call did not return the expected value of zero for a functional TCPDRV
'vector at the specified segment.
IF tcpReturn.ax <> 0 THEN tcpDriver.Enabled = 0: tcpInit% = 0: EXIT FUNCTION

tcpInit% = 1
tcpDriver.Enabled = 1
tcpDriver.IntVector = Vector
DEF SEG = tcpReturn.es
offset = tcpReturn.di

'The following lines of code parse all of the network-related data
'from the pointer value returned by TCPDRV.
tcpDriver.LocalIP = CVL(CHR$(PEEK(offset)) + CHR$(PEEK(offset + 1)) + CHR$(PEEK(offset + 2)) + CHR$(PEEK(offset + 3)))
offset = offset + 4

tcpDriver.LocalNetmask = CVL(CHR$(PEEK(offset)) + CHR$(PEEK(offset + 1)) + CHR$(PEEK(offset + 2)) + CHR$(PEEK(offset + 3)))
offset = offset + 4

tcpDriver.LocalGateway = CVL(CHR$(PEEK(offset)) + CHR$(PEEK(offset + 1)) + CHR$(PEEK(offset + 2)) + CHR$(PEEK(offset + 3)))
offset = offset + 4

tcpDriver.LocalDNS = CVL(CHR$(PEEK(offset)) + CHR$(PEEK(offset + 1)) + CHR$(PEEK(offset + 2)) + CHR$(PEEK(offset + 3)))
offset = offset + 4

tcpDriver.Timeserver = CVL(CHR$(PEEK(offset)) + CHR$(PEEK(offset + 1)) + CHR$(PEEK(offset + 2)) + CHR$(PEEK(offset + 3)))
offset = offset + 4

tcpDriver.MTU = CVI(CHR$(PEEK(offset)) + CHR$(PEEK(offset + 1)))
offset = offset + 2

tcpDriver.TTL = PEEK(offset)
tcpDriver.TOS = PEEK(offset + 1)
offset = offset + 4 'Skip two unused bytes after TTL and TOS data.

tcpDriver.MSS = CVI(CHR$(PEEK(offset)) + CHR$(PEEK(offset + 1)))
offset = offset + 2

tcpDriver.RWIN = CVI(CHR$(PEEK(offset)) + CHR$(PEEK(offset + 1)))
offset = offset + 4 'Skip two unused bytes after RWIN data.

'The following code segment gets the local domain string.
'TCPDRV allocates 256 bytes for this string, because that is the maximum
'allowed length of a domain name. If the string is shorter than 256 bytes,
'then TCPDRV fills the remainder of the string with ASCII code 255. The
'following code stops reading from the domain string as soon is it sees
'the first byte with a value of 255 for performance reasons.
DIM tempNum AS INTEGER
DIM tempCurByte AS STRING * 1
DIM tempStr AS STRING
FOR tempNum = offset TO offset + 255
        tempCurByte = CHR$(PEEK(tempNum))
        IF tempCurByte = CHR$(255) THEN
                tcpDriver.DomainLen = tempNum - offset
                tcpDriver.LocalDomain = tempStr
        ELSE
                tempStr = tempStr + tempCurByte
        END IF
NEXT tempNum

tcpDriver.ErrorCode = LowByte(tcpReturn.dx)
END FUNCTION

FUNCTION tcpListen% (ListenPort AS INTEGER)
tcpCall.ax = MakeReg(&H10, 1)
tcpCall.bx = ListenPort
tcpCall.cx = 0
tcpCall.dx = tcpDriver.Timeout
tcpCall.si = 0
tcpCall.di = 0
CALL interruptx(tcpDriver.IntVector, tcpCall, tcpReturn)

tcpListen% = tcpReturn.bx
tcpDriver.ErrorCode = LowByte(tcpReturn.dx)
END FUNCTION

DEFINT A-Z
FUNCTION tcpRemoteIP$ (tcpHandle AS INTEGER)
checkstat% = tcpStatus(tcpHandle)
IF checkstat% <> sckOpen THEN tcpRemoteIP$ = "0.0.0.0": EXIT FUNCTION

DEF SEG = tcpReturn.es
stateoffset = tcpReturn.di
ipdest$ = Conv2IP(CVL(CHR$(PEEK(stateoffset + 6)) + CHR$(PEEK(stateoffset + 7)) + CHR$(PEEK(stateoffset + 8)) + CHR$(PEEK(stateoffset + 9))))
'ipsrce$ = Conv2IP(CVL(CHR$(PEEK(stateoffset)) + CHR$(PEEK(stateoffset + 1)) + CHR$(PEEK(stateoffset + 2)) + CHR$(PEEK(stateoffset + 3))))

tcpRemoteIP$ = ipdest$
END FUNCTION

DEFSNG A-Z
SUB tcpSendData (tcpHandle AS INTEGER, Data2Send AS STRING)
strSendData = Data2Send

tcpCall.ax = MakeReg(&H13, 4)
tcpCall.bx = tcpHandle
tcpCall.es = INT(VARSEG(strSendData))
tcpCall.di = INT(VARPTR(strSendData))
tcpCall.cx = INT(LEN(Data2Send))
tcpCall.dx = tcpDriver.Timeout
CALL interruptx(tcpDriver.IntVector, tcpCall, tcpReturn)

tcpDriver.ErrorCode = LowByte(tcpReturn.dx)
tcpDoIO
END SUB

SUB tcpSetTimeout (TimeoutSeconds AS INTEGER)
tcpDriver.Timeout = INT(TimeoutSeconds * 18.2)
END SUB

FUNCTION tcpStatus% (tcpHandle AS INTEGER)
tcpCall.ax = MakeReg(&H14, 0)
tcpCall.bx = tcpHandle
CALL interruptx(tcpDriver.IntVector, tcpCall, tcpReturn)

DEF SEG = tcpReturn.es
stateoffset = tcpReturn.di
ipsrce$ = Conv2IP(CVL(CHR$(PEEK(stateoffset)) + CHR$(PEEK(stateoffset + 1)) + CHR$(PEEK(stateoffset + 2)) + CHR$(PEEK(stateoffset + 3))))
ipdest$ = Conv2IP(CVL(CHR$(PEEK(stateoffset + 4)) + CHR$(PEEK(stateoffset + 5)) + CHR$(PEEK(stateoffset + 6)) + CHR$(PEEK(stateoffset + 7))))
ipprot% = PEEK(stateoffset + 8)
active% = PEEK(stateoffset + 9)
ifActive = active%
'PRINT "======================"
'PRINT "Debug: Status data return values for TCP handle"; tcpHandle
'PRINT
'PRINT "Error code:"; LowByte(tcpReturn.dx)
'PRINT "TCP state:"; HighByte(tcpReturn.dx)
'PRINT
'PRINT "Bytes available for reading:"; tcpReturn.ax
'PRINT "Bytes still being transmitted:"; tcpReturn.cx
'PRINT
'PRINT "Session info gathered from pointer" + STR$(tcpReturn.es) + ":" + MID$(STR$(tcpReturn.di), 2)
'PRINT "IP source: " + ipsrce$
'PRINT "IP dest: " + ipsrce$
'PRINT "IP prot:"; ipprot%
'PRINT "Active:"; active%
'PRINT "======================"
tcpStatus% = HighByte(tcpReturn.dx)
tcpDriver.ErrorCode = LowByte(tcpReturn.dx)
END FUNCTION

SUB tcpUnload
tcpCall.ax = MakeReg(&H1, 0)
CALL interruptx(tcpDriver.IntVector, tcpCall, tcpReturn)

tcpDriver.Enabled = 0
END SUB

Thank you :-)
counting_pine
Site Admin
Posts: 6323
Joined: Jul 05, 2005 17:32
Location: Manchester, Lancs

Re: QB code > FreeBasic fblite HELP

Post by counting_pine »

If you are not using Lang qb it will be necessary to use Short or Integer<16> instead of Integer. String*N in types will break because in DB they currently use N+1 bytes, so byte arrays or something will be needed instead.. And types may need to be packed with 'field=1' to prevent padding between elements.
I suspect Call Interruptx may be harder to translate though. That's probably where most of the magic is happening..
Cpcdos
Posts: 207
Joined: Mar 06, 2013 13:52
Location: France - LYON 69003
Contact:

Re: QB code > FreeBasic fblite HELP

Post by Cpcdos »

Okay thank you for your reply

I have translated interruptx in asm bloc

Code: Select all

tcpcAX = tcpCall.ax
tcpcBX = tcpCall.bx
tcprAX = 0
tcprBX = 0
asm 

	mov ax, [tcpcAX]
	mov bx, [tcpcBX]
	int 0x60
	mov [tcprAX], ax
	mov [tcprBX], bx

end asm
tcpReturn.ax = tcprAX
tcpReturn.bx = tcprBX
i can compile ! this program work but crash

thank you anyway :-)

i will write a new topic
DOS386
Posts: 798
Joined: Jul 02, 2005 20:55

Re: QB code > FreeBasic fblite HELP

Post by DOS386 »

> I would know if possible, you can to convert a QuickBasic (4.5)
> code to FreeBasic with fblite for me ? :-)

Code: Select all

tcpCall.es = VARSEG(strGetData) '' !!! BIG PROBLEM HERE !!!
tcpCall.di = VARPTR(strGetData)
tcpCall.cx = 1500
tcpCall.dx = 0
CALL interruptx(tcpDriver.IntVector, tcpCall, tcpReturn)
It's possible, but much work. The chief problem is not the BASIC dialect, but the real mode INT and the segmented memory model. You need the Int $31 / AX=$0300 "Simulate Real Mode Interrupt" hack and a buffer in low memory. You cannot simply do INT from PM code, this works always only if passing simple numbers (like handles), in some (not your) "privileged cases" it works with addresses in DPMI memory (EDX -> DX, "True DPMI"), but this never works for segment registers.

http://www.freebasic.net/wiki/wikka.php?wakka=KeyPgAsm
http://www.freebasic.net/wiki/wikka.php?wakka=FaqDOS
http://www.delorie.com/djgpp/doc/dpmi/api/310300.html

> I have translated interruptx in asm bloc

Good, but not sufficient.

> i can compile ! this program work but crash

Unsurprisingly, since you can't write any garbage into segment registers in PM.

> i will write a new topic

Why?

- Allocate a buffer in low memory
...
- Write you data into the buffer ("DOSMEMPUT")
- Fill in the "Simulate Real Mode Interrupt" structure
- Call your INT ($60 ???) through $31 / AX=$0300 "Simulate Real Mode Interrupt" hack
- Read out your data from low memory ("DOSMEMGET")

http://freebasic.net/forum/viewtopic.ph ... 74#p103774 <- "Simulate Real Mode Interrupt" example
Cpcdos
Posts: 207
Joined: Mar 06, 2013 13:52
Location: France - LYON 69003
Contact:

Re: QB code > FreeBasic fblite HELP

Post by Cpcdos »

Hello, Thank you for your reply !

For the problem

Code: Select all

tcpCall.es = VARSEG(strGetData) '' !!! BIG PROBLEM HERE !!!
I have translated to

Code: Select all

tcpCall.es = int(sizeof(strSendData)/16)+1
i have called int 0x60 for network card, this program create a web server for dos (someone have a source for freebasic ?)


Okay thank you, I know interpret the assembler, but i most do not know what results :/
DOS386
Posts: 798
Joined: Jul 02, 2005 20:55

Re: QB code > FreeBasic fblite HELP

Post by DOS386 »

Cpcdos wrote:

Code: Select all

tcpCall.es = VARSEG(strGetData) '' !!! BIG PROBLEM HERE !!!
I have translated to

Code: Select all

tcpCall.es = int(sizeof(strSendData)/16)+1
I don't understand why ... most like it won't work like that ... you have to set:

1. ES in the structure for INT $31 / AX=$0300
and
2. to the segment address of your buffer in low memory (that you have to allocate before)

This

Code: Select all

DIM SHARED tcpCall AS Registers
DIM SHARED tcpReturn AS Registers
must go away ... in favor of the bigger structure for INT $31 / AX=$0300 ... then you will call INT $31 with AX=$0300 and BL=$60 and EDI pointing to your structure.
Cpcdos
Posts: 207
Joined: Mar 06, 2013 13:52
Location: France - LYON 69003
Contact:

Re: QB code > FreeBasic fblite HELP

Post by Cpcdos »

Hmm :/

okay thank you!
Post Reply