download: libTCPUDP.zip
Joshy
file: tcpudp.bi
Code: Select all
' file: tcpudp.bi
#include once "crt.bi" ' memcpy
#inclib "TCPUDP"
extern "c"
' lib
declare function NetInit as integer
' server
declare function NetCreateTCPServer (port as integer) as integer
declare function NetCreateUDPServer (port as integer) as integer
declare function NetDeleteServer (hServer as integer) as integer
declare function NetClientConnected (hServer as integer) as integer
declare function NetClientDisconnected (hServer as integer) as integer
declare function NetClientData (hServer as integer) as integer
declare function NetClientIP (hClient as integer) as uinteger
declare function NetClientPort (hClient as integer) as integer
' client
declare function NetCreateTCPClient (host as zstring ptr,port as integer) as integer
declare function NetCreateUDPClient (host as zstring ptr,port as integer) as integer
declare function NetDeleteClient (hClient as integer) as integer
declare function NetServerData (hClient as integer) as integer
declare function NetServerIdle (hClient as integer) as integer
' client and server
declare function NetWrite (hClientServer as integer, pBuffer as any ptr, BufferSize as integer) as integer
declare function NetRead (hClientServer as integer, pBuffer as any ptr, BufferSize as integer) as integer
end externCode: Select all
#ifdef TCPUDP_DEBUG
#define dprint(msg) open err for output as #99 : print #99,msg : close #99
#else
#define dprint(msg) :
#endif
' ########################
' # TCP and HTTP helpers #
' ########################
const as integer TCP_BUFFER_SIZE = 1024*8
const as string LINE_END = chr(13,10)
const as string HEADER_END = chr(13,10,13,10)
const as string MIME_HTM = "text/html"
const as string MIME_TXT = "text/plain"
const as string MIME_BMP = "image/bmp"
const as string MIME_GIF = "image/gif"
const as string MIME_JPG = "image/jpeg"
const as string MIME_PNG = "image/png"
const as string MIME_TIF = "image/tiff"
const as string MIME_WAV = "audio/wav"
const as string MIME_MP3 = "audio/mpeg"
const as string MIME_OGG = "audio/ogg"
const as string MIME_PDF = "application/pdf"
const as string MIME_ZIP = "application/x-compressed"
const as string MIME_GZ = "application/gzip"
' ...
' url encoding
function HTTPUrl(url as string) as string
static as string * 63 an = "abcdefghijklmnopqrstuvwxyz" & _
"ABCDEFGHIJKLMNOPQRSTUVWXYZ" & _
"0123456789/"
dim as integer nChars = len(trim(url))
if nChars<1 then return ""
dim as string encoded
for i as integer = 1 to nChars
dim as string char = mid(url,i,1)
if instr(an,char)>0 then
encoded &= char
else
encoded &= "%" & lcase(hex(asc(char),2))
end if
next
return encoded
end function
' build an HTTP GET request: e.g. ("domain.com", "/test.txt", "text/plain")
function HTTPGet(host as string,pathfile as string,accept as string="") as string
dim as string msg
msg = "GET " & pathfile & " HTTP/1.1" & LINE_END
msg &= "Host: " & host & LINE_END
if len(accept)>0 then
msg &= "Accept: " & accept & LINE_END
end if
msg &= LINE_END
return msg
end function
' build an HTTP HEAD request: e.g. ("domain.com", "/test.jpg", "image/jpg")
function HTTPHead(host as string,pathfile as string,accept as string="") as string
dim as string msg
msg = "HEAD " & pathfile & " HTTP/1.1" & LINE_END
msg &= "Host: " & host & LINE_END
if len(accept)>0 then
msg &= "Accept: " & accept & LINE_END
end if
msg &= LINE_END
return msg
end function
' build an HTTP POST request: e.g. ("domain.com", "/script.php", "key1=value&key2=value")
function HTTPPost(host as string, pathfile as string, query as string, UseReferer as integer=1) as string
dim as string msg
msg = "POST " & pathfile & " HTTP/1.1" & LINE_END
msg &= "Host: " & host & LINE_END
if UseReferer then
msg &= "Referer: http://" & host & pathfile & "?" & LINE_END
end if
msg &= "Content-type: application/x-www-form-urlencoded" & LINE_END
msg &= "Content-length: " & len(query) & LINE_END
msg &= "Connection: close" & HEADER_END
msg &= query
return msg
end function
function NetWaitForData(hTCP as integer, _
timeout as integer, _
FromClient as integer=0) as integer
if hTCP=0 then return 1
if timeout<100 then timeout=100
if FromClient then
while (NetClientData(hTCP)=0) andalso (timeout>-1)
sleep(100):timeout-=100:
wend
else
while (NetServerData(hTCP)=0) andalso (timeout>-1)
sleep(100):timeout-=100
wend
end if
return (timeout<0)
end function
function NetReadString(hTCP as integer, _
TheString as string , _
FromClient as integer=0) as integer
TheString = ""
if hTCP=0 then return 0
dim as integer nBytes,flag
dim as zstring ptr pTmp = allocate(TCP_BUFFER_SIZE)
do
dim as integer nReceived = NetRead(hTCP,pTmp,TCP_BUFFER_SIZE)
if nReceived>0 then
TheString &= left(*pTmp,nReceived)
nBytes+=nReceived
if (nReceived = TCP_BUFFER_SIZE) or (flag=1) then
flag = iif(nReceived = TCP_BUFFER_SIZE,1,0)
if NetWaitForData(hTCP,2000,FromClient) then exit do
else
exit do
end if
else
exit do
end if
loop
deallocate pTmp
return nBytes
end function
' pBuffer will be reallocated
' return number of bytes reallocated and readed.
function NetReadBuffer(hTCP as integer, _
byref pBuffer as any ptr, _
FromClient as integer=0) as integer
if hTCP=0 then return 0
dim as integer nBytes,flag
dim as zstring ptr pTmp = Allocate(TCP_BUFFER_SIZE)
dim as any ptr pWrite
do
dim as integer nReceived = NetRead(hTCP,pTmp,TCP_BUFFER_SIZE)
if (nReceived>0) then
pBuffer=Reallocate(pBuffer,nBytes+nReceived)
pWrite=pBuffer:pWrite+=nBytes
memcpy pWrite,pTmp,nReceived
nBytes+=nReceived
if (nReceived = TCP_BUFFER_SIZE) or (flag=1) then
flag = iif (nReceived = TCP_BUFFER_SIZE,1,0)
if NetWaitForData(hTCP,2000,FromClient) then exit do
else
exit do
end if
else
exit do
end if
loop
Deallocate pTmp
return nBytes
end function
' return number of bytes written
function NetWriteString(hTCP as integer,msg as string) as integer
if hTCP=0 then return 0
dim as integer nBytes,nSize = len(msg)
dim as ubyte ptr p = strptr(msg)
while nSize>0
dim as integer n = NetWrite(hTCP,p,nSize)
if n<1 then exit while
nBytes+=n:nSize-=n:p+=n
wend
return nBytes
end function
' return -1 for Net error
' otherwise return number of bytes
function GetConntentSize(hTCP as integer,_
host as string, _
pathfile as string, _
accept as string) as integer
if hTCP=0 then return -1
dim as string req = HTTPHead(host,pathfile,accept)
NetWriteString(hTCP,req)
if NetWaitForData(hTCP,10000) then return -1
NetReadString(hTCP,req)
req=lcase(req)
if instr(req," 200 ok")=0 then
dprint("GetConntentSize() missing ok message !")
dprint(req)
return -1
end if
dim as integer p=instr(req,"content-length:")
if p=0 then return -1
p+=len("content-length:")
dim as integer nBytes=val(mid(req,p,10))
return nBytes
end function
' get complete site or file with header
' pBuffer will be reallocated
' return -1 for Net error
' otherwise return number of bytes
function GetConntent(hTCP as integer,_
host as string, _
pathfile as string, _
accept as string, _
byref pBuffer as any ptr) as integer
if (hTCP) then
if NetWriteString(hTCP,HTTPGet(host,pathfile,accept))>0 then
if NetWaitForData(hTCP,10000) then
dprint("GetConntent() timeout !")
return -1
end if
dim as integer nBytesReaded = NetReadBuffer(hTCP,pBuffer)
if nBytesReaded<0 then
dprint("GetConntent() NetReadBuffer() failed !")
end if
return nBytesReaded
end if
end if
return -1
end function
' download complete site or file (with header)
' save only the content local as file.
' e.g. size = HTTPSaveContent("domain.com","/images/picture.png","/mypath/logo.png")
' return -1 if Net error
' return -2 if File error
' otherwise return the number of bytes saved
function HTTPSaveContent(host as string,pathfile as string,file as string) as integer
host =trim(host) :if len(host) <5 then return -1
pathfile=trim(pathfile):if len(pathfile)<5 then return -1
file =trim(file) :if len(file) <1 then return -1
dim as integer hTCP = NetCreateTCPClient(host,80)
if hTCP=0 then
dprint( "NetCreateTCPClient(" & host & ",80) failed !" )
return -1
end if
dim as string accept
dim as integer p=instrrev(pathfile,".")
if p>0 then
dim as string ext = lcase(right(pathfile,len(pathfile)-p))
select case ext
case "htm" :accept=MIME_HTM
case "html":accept=MIME_HTM
case "txt" :accept=MIME_TXT
case "bmp" :accept=MIME_BMP
case "gif" :accept=MIME_GIF
case "jpg" :accept=MIME_JPG
case "jpeg":accept=MIME_JPG
case "png" :accept=MIME_PNG
case "tif" :accept=MIME_TIF
case "tiff":accept=MIME_TIF
case "mp3" :accept=MIME_MP3
case "ogg" :accept=MIME_OGG
case "wav" :accept=MIME_WAV
case "pdf" :accept=MIME_PDF
case "gz" :accept=MIME_GZ
case "zip" :accept=MIME_ZIP
end select
end if
dim as integer ContSize = GetConntentSize(hTCP,host,pathfile,accept)
if ContSize<0 then
dprint("HTTPSaveContent() GetConntentSize() failed !")
NetDeleteClient(hTCP)
return -1
end if
dim as zstring ptr pCont
dim as integer nBytes = GetConntent(hTCP,host,pathfile,accept,pCont)
NetDeleteClient(hTCP)
if nBytes<ContSize then
dprint("GetConntent()<>ContenSize !")
deallocate pCont
return -1
end if
p=instr(*pCont,HEADER_END)
if p<1 then
dprint("GetConntent() missing HEADER_END !")
deallocate pCont
return -1
end if
p+=3
dim as integer hFile = FreeFile()
if open(file,for binary,access write,as #hFile) then
dprint("HTTPSaveContent() can't write " & file)
return -2
end if
dim as ubyte ptr pBuffer = pCont
pBuffer+=p
put #hFile,,*pBuffer,ContSize
close #hFile
deallocate pCont
return ContSize
end function