'Generated with PluriBASIC 6.0.6.293216
$ filename "C:\Users\Diamante\Documents\PluriBASIC\Clean\forms.exe"
uses rtl64
%NoConsole
uses console
' Sripting engine (CGI).
DECLARE FUNCTION ¤GetTokenContents(int hm, string v) as string
MACRO ¤TokenArrays
string name[1]
int vidx[1]
int vtyp[1]
int hmod[1]
sys hadr[1]
string vstr[1]
wstring vwst[0]
short vint[0]
word vwrd[0]
dword vdwd[0]
long vlng[0]
quad vqud[0]
byte vbyt[0]
single vsng[0]
double vdbl[0]
extended vext[0]
string vgui[0]
double vcur[0]
double vcux[0]
sys vhdl[0]
sys vadr[0]
END MACRO
DIM STRING ¤SYSTEM_UDT_OFFSETS(0)
STRING ¤TMPS = "" ' a temporary string.
LONG ¤CNTR = 0 ' a temporary counter.
DECLARE FUNCTION ¤GetLastError Lib "Kernel32.dll" Alias "GetLastError" () AS LONG
DECLARE FUNCTION ¤GetAsyncKeyState Lib "User32.dll" Alias "GetAsyncKeyState" (ByVal vKey AS LONG) AS short
DECLARE SUB ¤Sleep lib "Kernel32.dll" alias "Sleep" (dword mSec)
function ¤INI_QUAD(dword v1, v2) as quad
quad v = 0
copy(@v+0, @v2, 4)
copy(@v+4, @v1, 4)
return v
end function
DECLARE FUNCTION ¤OpenProcess Lib "KERNEL32.DLL" Alias "OpenProcess" (ByVal dwDesiredAccess AS DWORD, ByVal bInheritHandle AS LONG, ByVal dwProcessId AS SYS) AS SYS
DECLARE FUNCTION ¤TerminateProcess Lib "KERNEL32.DLL" Alias "TerminateProcess" ( ByVal hProcess AS SYS, ByVal uExitCode AS DWORD) AS LONG
DECLARE FUNCTION ¤CloseHandle Lib "KERNEL32.DLL" Alias "CloseHandle" (ByVal hObject AS SYS) AS LONG
DECLARE FUNCTION ¤GetCurrentProcessId Lib "KERNEL32.DLL" Alias "GetCurrentProcessId" () AS SYS
MACRO ¤SET_ERR(n)
Err.err = n
Err.erl = Err.erp
END MACRO
MACRO ¤ONERR(l, e)
Err.err = e
IF (Err.err>0) THEN
Err.ers = Err.erp
Err.erl = l
IF Err.Oe1 THEN
JMP Err.Oe1
ELSEIF Err.Oe2 THEN
CALL Err.Oe2
END IF
else
Err.ers = ""
Err.erl = 0
END IF
END MACRO
MACRO ERRCLEAR
Err.err = 0
Err.erl = 0
Err.ers = ""
END MACRO
CLASS ¤SYSERR
public sys Oe1 = 0
public sys Oe2 = 0
public int err = 0
public int erl = 0
public string erp = ""
public string ers = ""
END CLASS
declare FUNCTION ¤CloseHandle LIB "KERNEL32.DLL" ALIAS "CloseHandle" (byval fHandle AS SYS) AS DWORD
DECLARE FUNCTION ¤CreateFileA LIB "KERNEL32.DLL" ALIAS "CreateFileA" ( _
ByVal lpFileName AS DWORD, _
ByVal dwDesiredAccess AS DWORD, _
ByVal dwShareMode AS DWORD, _
ByVal lpSecurityAttributes AS DWORD, _
ByVal dwCreationDisposition AS DWORD, _
ByVal dwFlagsAndAttributes AS DWORD, _
BYVAL hTemplateFile AS DWORD) AS DWORD
DECLARE FUNCTION ¤CreateFileW LIB "KERNEL32.DLL" ALIAS "CreateFileW" ( _
ByVal lpFileName AS DWORD, _
ByVal dwDesiredAccess AS DWORD, _
ByVal dwShareMode AS DWORD, _
ByVal lpSecurityAttributes AS DWORD, _
ByVal dwCreationDisposition AS DWORD, _
ByVal dwFlagsAndAttributes AS DWORD, _
BYVAL hTemplateFile AS DWORD) AS DWORD
DECLARE FUNCTION ¤SetFilePointer LIB "KERNEL32.DLL" ALIAS "SetFilePointer" ( _
BYVAL hFile AS SYS, _
BYVAL lDistanceToMove AS LONG, _
BYval lpDistanceToMoveHigh AS LONG, _
BYVAL dwMoveMethod AS DWORD) AS DWORD
DECLARE FUNCTION ¤SetFilePointerEx LIB "KERNEL32.DLL" ALIAS "SetFilePointerEx" ( _
BYVAL hFile AS SYS, _
BYVAL lDistanceToMove AS SYS, _
BYREF lpNewFilePointer AS SYS, _
BYVAL dwMoveMethod AS DWORD) AS INT
DECLARE FUNCTION ¤WriteFile LIB "Kernel32.dll" ALIAS "WriteFile" ( _
BYVAL hFile AS SYS, BYVAL lpBuffer AS SYS, _
BYVAL nNumberOfBytesToWrite AS DWORD, lpNumberOfBytesWritten AS DWORD, _
lpOverlapped AS DWORD) AS DWORD
DECLARE FUNCTION ¤ReadFile LIB "Kernel32.dll" ALIAS "ReadFile" ( _
BYVAL hFile AS SYS, BYVAL lpBuffer AS SYS, _
BYVAL nNumberOfBytesToRead AS DWORD, lpNumberOfBytesRead AS DWORD, _
lpOverlapped AS DWORD) AS DWORD
DECLARE FUNCTION ¤SetConsoleMode Lib "Kernel32.dll" ALIAS "SetConsoleMode" ( _
ByVal hConsoleOutput As SYS, _
dwMode As Long) As Long
DECLARE FUNCTION ¤GetConsoleMode Lib "Kernel32.dll" ALIAS "GetConsoleMode" ( _
ByVal hConsoleOutput As SYS, _
BYREF dwMode As SYS) As Long
DECLARE FUNCTION ¤GetFileSizeEx Lib "Kernel32.dll" ALIAS "GetFileSizeEx" (
BYVAL hFile AS SYS, lpFileSize AS SYS) AS LONG
DECLARE FUNCTION ¤SetEndOfFile Lib "Kernel32.dll" ALIAS "SetEndOfFile" (
BYVAL hFile AS SYS) AS LONG
declare function ¤srand lib "msvcrt.dll" alias "srand" (int seed)
declare function ¤rand lib "msvcrt.dll" alias "rand" () as INT
declare function ¤GetTickCount lib "kernel32.dll" alias "GetTickCount" () as dword
DOUBLE ¤LRNGN = 0
INT ¤LRNLB = 0
INT ¤LRNUB = 0
declare function ¤FindFirstFile alias "FindFirstFileA" lib "kernel32.dll" (lpFileName AS ASCIIZ, BYVAL lpFindFileData AS SYS) AS SYS
declare function ¤FindNextFile alias "FindNextFileA" lib "kernel32.dll" (BYVAL hFindFile AS SYS, BYVAL lpFindFileData AS SYS) AS SYS
declare function ¤FindClose alias "FindClose" lib "kernel32.dll" '(BYVAL hFindFile AS SYS) AS SYS
declare function ¤DisableRdr alias "Wow64DisableWow64FsRedirection" lib "kernel32.dll" '(BYVAL hFindFile AS SYS) AS SYS
DECLARE FUNCTION GetEnvironmentVariable LIB "Kernel32.dll" ALIAS "GetEnvironmentVariableA" (lpName AS ASCIIZ, lpBuffer AS ASCIIZ, BYVAL nSize AS DWORD) AS DWORD
DECLARE FUNCTION GetEnvironmentStrings LIB "Kernel32.dll" ALIAS "GetEnvironmentStringsA" () AS SYS
DECLARE FUNCTION FreeEnvironmentStrings LIB "Kernel32.dll" ALIAS "FreeEnvironmentStringsA" (sys e) AS long
DECLARE FUNCTION GetCommandLineA LIB "KERNEL32.DLL" ALIAS "GetCommandLineA" () AS DWORD
DECLARE FUNCTION ¤ReadFile LIB "KERNEL32.DLL" ALIAS "ReadFile" (dword hFile, lpBuffer, nNumberOfBytesToRead, byref dword lpNumberOfBytesRead, byval dword lpOverlapped) AS LONG
DECLARE FUNCTION ¤GetFileSizeEx LIB "KERNEL32.DLL" Alias "GetFileSizeEx" (dword hFile, byref quad lpFileSize) as long
DECLARE FUNCTION ¤LoadStringA LIB "User32.dll" ALIAS "LoadStringA" (BYVAL hInstance AS DWORD, BYVAL uID AS DWORD, lpBuffer AS ASCIIZ, BYVAL nBufferMax AS LONG) AS LONG
DECLARE FUNCTION ¤LoadStringW LIB "User32.dll" ALIAS "LoadStringW" (BYVAL hInstance AS DWORD, BYVAL uID AS DWORD, lpBuffer AS WZSTRING, BYVAL nBufferMax AS LONG) AS LONG
DECLARE FUNCTION ¤FindResourceA LIB "Kernel32.dll" ALIAS "FindResourceA" (BYVAL hInstance AS SYS, lpName AS ASCIIZ, lpType AS ASCIIZ) AS LONG
DECLARE FUNCTION ¤LoadResource LIB "Kernel32.dll" ALIAS "LoadResource" (BYVAL hInstance AS SYS, BYVAL hResInfo AS sys) AS SYS
DECLARE FUNCTION ¤FreeResource LIB "Kernel32.dll" ALIAS "FreeResource" (BYVAL hResData AS SYS) AS LONG
DECLARE FUNCTION ¤LockResource LIB "Kernel32.dll" ALIAS "LockResource" (BYVAL hResData AS SYS) AS SYS
DECLARE FUNCTION ¤SizeofResource LIB "Kernel32.dll" ALIAS "SizeofResource" (BYVAL hInstance AS SYS, BYVAL hResInfo AS SYS) AS SYS
DECLARE FUNCTION ¤WriteConsole LIB "KERNEL32.DLL" ALIAS "WriteFile" (BYVAL hFile AS SYS, lpBuffer AS ANY, BYVAL nNumberOfBytesToWrite AS dword, lpNumberOfBytesWritten AS dword, lpReserved AS long) AS LONG
DECLARE FUNCTION ¤AllocConsole LIB "KERNEL32.DLL" ALIAS "AllocConsole" () AS LONG
DECLARE FUNCTION ¤FlushFileBuffers LIB "KERNEL32.DLL" ALIAS "FlushFileBuffers" (BYVAL hFile AS SYS) AS LONG
DECLARE FUNCTION ¤GetStdHandle LIB "KERNEL32.DLL" Alias "GetStdHandle" (ByVal nStdHandle AS DWORD) AS SYS
DECLARE SUB ¤PRINTSTR(STRING c, byval int cr)
DECLARE FUNCTION ¤GETFIELD(string f, n) AS STRING
DECLARE FUNCTION ¤FORMFIELD(string f, int nm) AS STRING
DECLARE FUNCTION ¤CreateThreadTL lib "Kernel32.dll" alias "CreateThread"
sys ¤TIMELIMIT = ¤CreateThreadTL(byval 0, byval 0, byval @¤TIMELIMITPROC, byval 0, byval 67, byval 0)
FUNCTION ¤TIMELIMITPROC(SYS »x) AS INT EXTERNAL
¤Sleep(10000)
sys hProcess = ¤OpenProcess(1, 0, ¤GetCurrentProcessId())
IF (hProcess<>0) And (hProcess <> 0xFFFFFFFF) Then
¤TerminateProcess(hProcess, 0)
¤CloseHandle(hProcess)
End If
END FUNCTION
' STARTS PLURIBASIC_PREPARE.BIN
' This code is executed before anything else, if you want to do something after defining other things, see PLURIBASIC_INIT
int ¤i = 0
' STARTS SYSTEM_OPERATORS.BIN
FUNCTION ¤BytOvf(byte b) AS byte
return b
END FUNCTION
FUNCTION ¤NOT(byval quad v1) AS QUAD
dword w1
dword w2
quad r
copy @w1, @v1, 4
copy @w2, @v1+4, 4
w1 = not(w1)
w2 = not(w2)
copy @r, @w1, 4
copy @r+4, @w2, 4
return r
END FUNCTION
FUNCTION ¤AND(byval quad v1, v2) as quad
dword w1
dword w2
quad r
copy @w1, @v1, 4
copy @w2, @v2, 4
w1 = (w1 and w2)
copy @r, @w1, 4
copy @w1, @v1+4, 4
copy @w2, @v2+4, 4
w1 = (w1 and w2)
copy @r+4, @w1, 4
return r
end function
FUNCTION ¤OR(byval quad v1, v2) as quad
dword w1
dword w2
quad r
copy @w1, @v1, 4
copy @w2, @v2, 4
w1 = (w1 or w2)
copy @r, @w1, 4
copy @w1, @v1+4, 4
copy @w2, @v2+4, 4
w1 = (w1 or w2)
copy @r+4, @w1, 4
return r
end function
FUNCTION ¤IMP(byval quad v1, v2) as quad
if v1 then return -1
if v2 then return -1
end function
FUNCTION ¤EQV(byval quad v1, v2) as quad
if v1=0 then return 0
if v2=0 then return 0
return -1
end function
FUNCTION ¤MOD(quad v1, v2) as quad
return MOD(v1, v2)
end function
' END OF SYSTEM_OPERATORS.BIN
' CONTINUES (17) PLURIBASIC_PREPARE.BIN
#DEF HANDLE SYS
' Tested, OK.
MACRO ¤UDT_RESET(s, u)
copy(u, news(s), s)
END MACRO
' Tested, OK.
MACRO ¤UDT_COPY(s, u, n)
copy(u, n, s)
END MACRO
' Tested, OK.
macro ¤UDT_SETV(vu, ai, of, dt, nv, ln a, c)
sys a = vu.hBuffer + (ai + of)
dt c = nv
copy(a, @c, ln)
end macro
' Tested, OK.
macro ¤UDT_SETA(vu, ai, of, nv, ln a, c)
sys a = ai + of
string c = left(nv, ln)
c = (c + news(ln-len(c)))
copy(a, strptr(c), ln)
end macro
'Tested, OK.
macro ¤UDT_SETW(vu, ai, of, nv, ln a, c)
sys a = ai + of
wstring c = left(nv, ln)
c = (c + news(ln-len(c)))
copy(a, strptr(c), ln*2)
end macro
' Tested, OK.
macro ¤MEM_SETV(vu, of, dt, nv, ln c)
dt c = nv
copy((@vu + of), @c, ln)
end macro
' Tested, OK.
macro ¤MEM_MODV(vu, of, dt, op, nv, ln c, e)
dt e
copy(@e, (@vu + of), ln)
dt c = e op nv
copy((@vu + of), @c, ln)
end macro
' Tested, OK.
macro ¤MEM_SUBV(vu, of, dt, nv, ln c, e)
dt e
copy(@e, @vu + of, ln)
dt c = e - nv
copy(@vu + of, @c, ln)
end macro
' Tested, OK.
macro ¤MEM_SETA(vu, of, nv, ln c)
string c = left(nv, ln)
c = (c + news(ln-len(c)))
copy(@vu + of, strptr(c), ln)
end macro
' Tested, OK.
macro ¤MEM_SETW(vu, of, nv, ln c)
wstring c = left(nv, ln)
c = (c + news(ln-len(c)))
copy(@vu + of, strptr(c), ln*2)
end macro
' Tested, OK.
macro ¤UDT_INCR(vu, ai, of, dt, nv a, c)
sys a = (vu.hBuffer + ai + of)
dt c = 0
copy(@c, a, sizeof(c))
c = (c + nv)
copy(a, @c, sizeof(c))
end macro
' Tested, OK.
macro ¤UDT_DECR(vu, ai, of, dt, nv a, c)
sys a = (vu.hBuffer + ai + of)
dt c = 0
copy(@c, a, sizeof(c))
c = (c - nv)
copy(a, @c, sizeof(c))
end macro
' Tested, OK.
macro ¤MEM_INCR(vu, of, dt, nv a)
dt a = 0
copy(@a, (@vu + of), sizeof(a))
a = (a + nv)
copy((@vu + of), @a, sizeof(a))
end macro
' Tested, OK.
macro ¤MEM_DECR(vu, of, dt, nv a)
dt a = 0
copy(@a, @vu + of, sizeof(a))
a = (a - nv)
copy((@vu + of), @a, sizeof(a))
end macro
' Tested, OK.
macro ¤SDT_VAL(nm, dt)
function nm(sys hBuffer, of) as dt
sys a = hBuffer + of
dt r
copy(@r, a, sizeof(dt))
return r
end function
end macro
function ¤TRIMNUL(string bb) as string
byte c at strptr(bb)
int i = 0
for i = 1 to len(bb)
if c[i] = 0 then
return left(bb, i-1)
end if
next i
return bb
end function
macro ¤SDT_STR(nm)
function nm(sys hBuffer, offset, byval int ln) as string
sys addr = (hBuffer + offset)
if ln = 0 then ln = 255
string bb = space(ln+1)
copy(strptr(bb), addr, ln)
return ¤TRIMNUL(bb)
end function
end macro
macro ¤SDT_WST(nm)
function nm(sys hBuffer, of, byval int ln) as wstring
sys addr = (hBuffer + of)
if ln = 0 then ln = 255
wstring bb = news(ln)
copy(strptr(bb), addr, ln*2)
return bb
end function
end macro
TYPE ¤SYSNMHDR
hwndFrom AS SYS
idFrom AS SYS
Code AS DWORD
END TYPE
' flags for internal file system.
% ·SYSFILE = 1
% ·SYSTCP = 2
% ·SYSUDP = 4
% ·SYSCOMM = 8
'% ·SYS?? = 16 ' RESERVED
% ·ASSIGN = 32
% ·ASSIGNED = 64
% ·HANDLE = 128
'% ·????? = 512 ' RESERVED
% ·BINARY = 1024
% ·RANDOM = 2048
% ·INPUT = 4096
% ·OUTPUT = 8192
% ·APPEND = 16384
% ·ANSI = 32768
% ·WIDE = 65536
% ·LOCK_WRITE = 131072
% ·LOCK_READ = 262144
% ·BASE_ZERO = 524288
% ·BASE_ONE = 1048576
class ¤SYSF
public int CURHN
public int FHNDL[32767] ' File handle.
public int FFLAG[32767] ' Socket flags.
public int FRLEN[32767] ' Record length
' Default UDT member bounds...
function m(int d1) as long {return d1}
function m(int d1, d2) as long {return (d1 * d2)}
function m(int d1, d2, d3) as long {return ((d1 * d2) + d3)}
' Custom UDT member bounds...
' UDT member readers.
¤SDT_VAL(byt, byte)
¤SDT_VAL(wrd, word)
¤SDT_VAL(int, int)
¤SDT_VAL(lng, long)
¤SDT_VAL(sys, sys)
¤SDT_VAL(dwd, dword)
¤SDT_VAL(qud, quad)
¤SDT_VAL(ext, extended)
¤SDT_VAL(cur, extended)
¤SDT_VAL(cux, extended)
¤SDT_VAL(sng, single)
¤SDT_VAL(dbl, double)
¤SDT_STR(asz)
¤SDT_STR(chr)
¤SDT_STR(str)
¤SDT_WST(wsz)
FUNCTION CONSTRUCTOR()
this.CURHN = 1
END FUNCTION
END CLASS
new ¤SYSF EXE()
FUNCTION ¤InvalidFHandle(SYS fn) AS LONG
IF fn < 1 THEN
FUNCTION = -1
EXIT FUNCTION
END IF
IF fn > 32767 THEN
FUNCTION = -1
EXIT FUNCTION
END IF
IF ((EXE.FFLAG[fn] and ·ASSIGNED) <> ·ASSIGNED) THEN
FUNCTION = -1
EXIT FUNCTION
END IF
END FUNCTION
' STARTS CGI.BIN
' STARTS RND.BIN
FUNCTION RND() AS DOUBLE
¤LRNGN = (¤rand() / 32767)
return ¤LRNGN
END FUNCTION
FUNCTION RND(int l1) AS DOUBLE
double rv = 0
if l1 = 0 then
return ¤LRNGN
elseif l1 < 0 then
int s = ¤GetTickCount()
¤srand(s)
rv = (¤rand() / 32767)
¤LRNGN = floor((rv * (¤LRNUB - ¤LRNLB)) + ¤LRNLB)
return ¤LRNGN
else
rv = (¤rand() / 32767)
¤LRNGN = floor((rv * (¤LRNUB - ¤LRNLB)) + ¤LRNLB)
return ¤LRNGN
end if
END FUNCTION
FUNCTION RND(byval int l1, l2) AS LONG
if l1 > l2 then
int l3 = l1
l1 = l2
l2 = l3
end if
¤LRNLB = l1
¤LRNUB = l2
double rv = (¤rand() / 32767)
¤LRNGN = floor(l1 + (rv * ((l2+1) - l1)))
return ¤LRNGN
END FUNCTION
' END OF RND.BIN
' CONTINUES (1) CGI.BIN
' STARTS DIR$.BIN
type ¤FILETIME
DWORD dwLowDateTime
DWORD dwHighDateTime
end type
type ¤WIN32_FIND_DATA
DWORD dwFileAttributes
¤FILETIME ftCreationTime
¤FILETIME ftLastAccessTime
¤FILETIME ftLastWriteTime
DWORD nFileSizeHigh
DWORD nFileSizeLow
DWORD dwReserved0
DWORD dwReserved1
CHAR cFileName[MAX_PATH]
CHAR cAlternateFileName[14]
CHAR Buffer[512]
end type
' Returns the first file that matches the specs.
FUNCTION ¤DIR(string specs, int o, flg, r) AS STRING
static string pspec
static int flags
static sys hSearch
static int nomatch
static int oy
int nErr = 0
int i = 0
¤WIN32_FIND_DATA f
if o=2 then ' find next file
if hSearch then
if nomatch then
return ""
end if
o = oy
if ¤FindNextFile(hSearch, @f) then
goto .¤ContinueSearch
else
nomatch = 1
end if
end if
else ' find first file.
pspec = specs
flags = flg
oy = o
nomatch = 0
if hSearch then
¤FindClose(hSearch)
end if
'asciiz spcs[256] = specs + chr(0)
hSearch = ¤FindFirstFile(specs, BYVAL @f)
if hSearch then
byte b at @f.cFileName
if b=46 then ¤FindNextFile(hSearch, @f)
byte b at @f.cFileName
if b=46 then ¤FindNextFile(hSearch, @f)
' do
' if (f.cFileName <> ".") and (f.cFileName <> "..") then
' exit do
' end if
' if ¤FindNextFile(hSearch, @f) = 0 then
' nomatch = 2
' return ""
' end if
' loop
..¤ContinueSearch
do
if o then ' do we force matching flags?
i = 1
do
if ((flags and i) = i) then ' do we force this style?
if ((f.dwFileAttributes and i) <> i) then
goto .¤NoMatchContinueSearch
end if
else
if ((f.dwFileAttributes and i) = i) then
goto .¤NoMatchContinueSearch
end if
end if
i *= 2
if i > 32 then
exit do
end if
loop
else
if flags then
i = 1
do
if ((flags and i) = i) then ' do we need this style?
if ((f.dwFileAttributes and i) <> i) then ' do the file have it?
goto .¤NoMatchContinueSearch
end if
end if
i *= 2
if i > 32 then
exit do
end if
loop
end if
end if
return ltrim(rtrim(f.cFileName))
..¤NoMatchContinueSearch
if ¤FindNextFile(hSearch, @f) = 0 then
nomatch = 3
exit do
end if
loop
end if
end if
return ""
END FUNCTION
' Returns the next matching file.
FUNCTION ¤DIR(int specs, f, g) AS STRING
return ¤DIR("", 2, 0, 0)
END FUNCTION
' Returns the first matching file (with flags)
FUNCTION ¤DIR(string specs, int f, g) AS STRING
if specs <> "" then
return ¤DIR(specs, 0, 0, 0)
end if
END FUNCTION
' END OF DIR$.BIN
' CONTINUES (2) CGI.BIN
' STARTS ENVIRON$.BIN
FUNCTION ¤ENVIRON(string v) AS STRING
ASCIIZ bf[2048]
GetEnvironmentVariable(bycopy v, bf, 2048)
'byte ptr b
'int i
'@b = @bf
return bf
'
'for i = 1 to len(bf)
' if b[i] = 61 then
' return mid(bf, i+1)
' end if
'next i
'return b
END FUNCTION
FUNCTION ¤ENVIRON(byval int v) AS STRING
if v < 1 then
return ""
end if
sys e
string o
int i, idx, p
e = GetEnvironmentStrings()
byte ptr b
@b = e
for i = 0 to 99999990
if b[i] = 0 then
i += 1
if b[i] <> 61 then
exit for
end if
end if
next i
idx = 1
p = i
for i = i to 99999990
if b[i] = 0 then
if v = idx then
o = news(i-p)
copy o, @b[p], (i-p)
exit for
end if
idx += 1
p = i+1
if b[i+1] = 0 then
exit for
end if
end if
next i
FreeEnvironmentStrings(e)
return o
END FUNCTION
' END OF ENVIRON$.BIN
' CONTINUES (3) CGI.BIN
' STARTS PARSE$.BIN
// returns a field of data given a separator.
FUNCTION PARSE(string src, long a, string sep, long fldnum) as string
if sep = "" then
return src
end if
indexbase 1
byte srcchar at strptr(src)
byte sepchar at strptr(sep)
long p1 = 1
long pos = 1
long curfld = 1
long index
long seps
for index = 1 to len(src)
if a then
for seps = 1 to len(sep)
if srcchar[index] = sepchar[seps] then
goto match
end if
next
if index = len(src) then
index += 1
else
goto nomatch
end if
elseif index = len(src) then
index += 1
else
for seps = 1 to len(sep)
if srcchar[index+seps-1] <> sepchar[seps] then
goto nomatch
end if
next
end if
match:
p1 = pos
pos = index
if fldnum = curfld then
return mid(src, p1, (pos-p1))
end if
curfld += 1
if a then
pos = index + 1
else
pos = index + len(sep)
end if
nomatch:
next
if fldnum = 1 then
return src
end if
END FUNCTION
' END OF PARSE$.BIN
' CONTINUES (4) CGI.BIN
' STARTS TRIM$.BIN
' STARTS LTRIM$.BIN
// returns a trimed string
FUNCTION LTRIM(string src, long a = 0, string ch = " ") as string
if len(src) = 0 then return ""
if len(ch) = 0 then return ""
byte srcchar at strptr(src)
byte trichar at strptr(ch)
long p1 = 1
long index
long cha
if a then
for index = 1 to len(src)
for cha = 1 to len(ch)
if srcchar[index] = trichar[cha] then
goto checknextchar
end if
next
p1 = index
exit for
checknextchar:
next
return mid(src, p1)
else
for index = 1 to len(src)
for cha = 1 to len(ch)
if srcchar[index+cha-1] <> trichar[cha] then
goto nomorematches
end if
next
p1 += len(ch)
next
nomorematches:
return mid(src, p1)
end if
END FUNCTION
' END OF LTRIM$.BIN
' CONTINUES (1) TRIM$.BIN
' STARTS RTRIM$.BIN
// returns a trimed string
FUNCTION RTRIM(string src, long a = 0, string ch = " ") as string
if len(src) = 0 then return ""
if len(ch) = 0 then return ""
byte srcchar at strptr(src)
byte trichar at strptr(ch)
long p1 = len(src)
long index
long cha
if a then
for index = len(src) TO 1 step -1
for cha = 1 to len(ch)
if srcchar[index] = trichar[cha] then
goto checknextchar
end if
next
p1 = index
exit for
checknextchar:
next
return mid(src, 1, p1)
else
for index = len(src)-len(ch) TO 1 step -1
for cha = 1 to len(ch)
if srcchar[index+cha-1] <> trichar[cha] then
goto nomorematches
end if
next
p1 = index-1
next
nomorematches:
return mid(src, 1, p1)
end if
END FUNCTION
' END OF RTRIM$.BIN
' CONTINUES (2) TRIM$.BIN
// returns a trimed string
FUNCTION TRIM(string inp, int a = 0, string chrs = " ") as string
RETURN RTRIM(LTRIM(inp, a, chrs), a, chrs)
END FUNCTION
' END OF TRIM$.BIN
' CONTINUES (5) CGI.BIN
' STARTS PARSECOUNT.BIN
' returns the number of fields separated by this separator.
FUNCTION PARSECOUNT(string src, int a, string sep) AS LONG
byte s at strptr(src)
byte c at strptr(sep)
int i
int j
int f = 1
if a then ' any?
for i = 1 to len(src)
for j = 1 to len(sep)
if s[i] = c[j] then
f += 1
exit for
end if
next j
next i
else
for i = 1 to len(src)
if s[i] = c[1] then
for j = 2 to len(sep)
if s[i+j-1] <> c[j] then
goto nomatch
end if
next j
f += 1
i += len(sep)
nomatch:
end if
next i
end if
return f
END FUNCTION
' END OF PARSECOUNT.BIN
' CONTINUES (6) CGI.BIN
' STARTS FREEFILE.BIN
' returns the next free handle.
FUNCTION FREEFILE() AS LONG
int i = EXE.CURHN
for i = i to 32767
if EXE.FFLAG[i] = 0 then
EXE.CURHN = i
EXE.FFLAG[i] = ·ASSIGN
EXE.FHNDL[i] = 0
EXE.FRLEN[i] = 0
return i
end if
next
for i = 1 to EXE.CURHN
if EXE.FFLAG[i] = 0 then
EXE.CURHN = i
EXE.FFLAG[i] = ·ASSIGN
EXE.FHNDL[i] = 0
EXE.FRLEN[i] = 0
return i
end if
next
return 0
END FUNCTION
' END OF FREEFILE.BIN
' CONTINUES (7) CGI.BIN
' STARTS OPEN.BIN
'h = handle must be an open file handle.
'fn = filename.
'm = input mode
'a = access mode
'l = lock mode
'ff = filenumber.
'ln = record lenght
'bs = base address
'ch = 1 = anso, 2 = WIDE
' Opens a file by its already opened handle.
SUB ¤OPENHANDLE(int h, int m, a, l, ff, ln, bs, ch, ¤SYSERR Err)
IF (ff < 1) OR (ff > 32767) THEN ¤SET_ERR(57) : EXIT FUNCTION
IF EXE.FFLAG[ff] <> ·ASSIGN THEN ¤SET_ERR(57) : EXIT FUNCTION
EXE.FFLAG[ff] = (EXE.FFLAG[ff] OR ·ASSIGNED OR ·SYSFILE OR ·HANDLE)
END SUB
'========================================================================================
' Opens a file by its filename.
SUB ¤OPENFILENM(string fn, int m, a, l, ff, ln, bs, ch, BYREF ¤SYSERR Err)
IF (ff < 1) OR (ff > 32767) THEN
¤SET_ERR(57)
EXIT FUNCTION
END IF
IF EXE.FFLAG[ff] <> ·ASSIGN THEN
¤SET_ERR(57)
EXIT FUNCTION
END IF
EXE.FFLAG[ff] = 0
string fname = fn + chr(0)
long fAccess = 0
long fLock = 0
long fCreation = 0
long fFlags = 0
Select CASE m ' Mode
CASE 1 ' input
EXE.FFLAG[ff] = ·INPUT
fCreation = 3 ' open existing
fAccess = 2
if (a = 0) then
a = 1
elseif ((a and 2) = 2) THEN ' access WRITE?
¤SET_ERR(701)
EXIT FUNCTION
end if
CASE 2 ' output
EXE.FFLAG[ff] = ·OUTPUT
fCreation = 4 ' create
fAccess = 2
if (a = 0) then
a = 2
elseif ((a and 1) = 1) THEN ' access READ?
¤SET_ERR(70)
EXIT FUNCTION
end if
case 3 ' append
EXE.FFLAG[ff] = ·APPEND
fCreation = 4 ' create
fAccess = 2
if ((a and 1) = 1) THEN ' access READ??
¤SET_ERR(70)
EXIT FUNCTION
end if
case 4 ' binary
EXE.FFLAG[ff] = ·BINARY
fCreation = 4 ' create
if a = 0 then a = 3
CASE ELSE
fCreation = 3 ' open_existing
END SELECT
if ((a and 1) = 1) then fAccess = (fAccess or 0x80000000) ' access read
if ((a and 2) = 2) then fAccess = (fAccess or 0x40000000) ' access write
if (fLock <> 0) then
if ((l and 1) <> 1) then fLock = (fLock or 0x80000000) ' lock read operations
if ((l and 2) <> 2) then fLock = (flock or 0x40000000) ' lock write operations
end if
IF ch = 1 THEN
EXE.FHNDL[ff] = ¤CreateFileA(strptr(fName), fAccess, fLock, 0, fCreation, fFlags, 0)
'PRINTR(¤STR(fAccess) + ¤STR(m) + ¤STR(fLock) + ¤STR(fCreation), chr(10, 13))
IF EXE.FHNDL[ff] = -1 THEN
¤SET_ERR(702)
ELSE
EXE.FFLAG[ff] = (EXE.FFLAG[ff] OR ·ASSIGNED OR ·SYSFILE OR ·ANSI)
END IF
ELSE
EXE.FHNDL[ff] = ¤CreateFileW(StrPtr(fName), fAccess, fLock, 0, fCreation, fFlags, 0)
IF EXE.FHNDL[ff] = -1 THEN
¤SET_ERR(70)
ELSE
EXE.FFLAG[ff] = (EXE.FFLAG[ff] OR ·ASSIGNED OR ·SYSFILE OR ·WIDE)
END IF
END IF
IF bs = 1 then
EXE.FFLAG[ff] = (EXE.FFLAG[ff] OR ·BASE_ONE)
ELSE
EXE.FFLAG[ff] = (EXE.FFLAG[ff] OR ·BASE_ZERO)
END IF
if m = 3 then
' set append position here.
'¤SetFilePointer(EXE.FHNDL[ff], 0, byval 0, FILE_END)
end if
END SUB
' END OF OPEN.BIN
' CONTINUES (8) CGI.BIN
' STARTS PUT.BIN
' This file contains all the variations of use for the PUT statement.
' Writes a string to an open file.
SUB ¤WriteBinary(byval long fn, quad fp, byval sys st, int sl, byref ¤SYSERR Err)
IF ¤InvalidFHandle(fn) THEN
¤SET_ERR(70)
EXIT SUB
END IF
IF ((EXE.FFLAG[fn] and ·BINARY) <> ·BINARY) AND ((EXE.FFLAG[fn] and ·RANDOM) <> ·RANDOM) THEN
¤SET_ERR(70)
return
END IF
int w = 0
IF (sl>0) OR (LEN(st)>0) THEN
IF fp > -1 then
¤SetFilePointerEx(EXE.FHNDL[fn], byval (fp-1), byval 0, byval 0)
end if
¤WriteFile(EXE.FHNDL[fn], st, sl, w, null)
IF w = 0 THEN
¤SET_ERR(70)
END IF
END IF
END SUB
MACRO ¤PUTUDT(vt, fn, fp, var, ts, nm, el c)
vt c = var
¤WriteBinary(fn, fp, @c, ts, Err)
END MACRO
MACRO ¤PUTST2(vt, fn, fp, var, sl, nm, el t)
string t
IF sl>0 then
t = left(var + space(sl), sl)
else
t = var
end if
¤WriteBinary(fn, fp, strptr(t), len(t), Err)
END MACRO
MACRO ¤PUTST3(vt, fn, fp, var, sl, nm, el t)
wstring t
IF sl then
t = left(var + space(sl*2), sl*2)
else
t = var
end if
¤WriteBinary(fn, fp, strptr(t), len(t)*2, Err)
END MACRO
MACRO ¤PUTSTR(vt, fn, fp, var, sl, nm, el t)
string t
if sl>0 then
t = left(var + space(sl), sl)
else
t = var
end if
¤WriteBinary(fn, fp, strptr(t), len(t), Err)
END MACRO
MACRO ¤PUTVAR(vt, fn, fp, var, sl, nm, el c)
vt c = var
¤WriteBinary(fn, fp, byval @c, sizeof(c), Err)
END MACRO
' END OF PUT.BIN
' CONTINUES (9) CGI.BIN
' STARTS SETEOF.BIN
' Truncates a file to the current pointer position.
FUNCTION SETEOF(byval sys fn) AS LONG
if ¤InvalidFHandle(fn) THEN EXIT FUNCTION
IF ((EXE.FFLAG[fn] and ·ASSIGNED) = ·ASSIGNED) THEN
¤SetEndOfFile(EXE.FHNDL[fn])
END IF
END FUNCTION
' END OF SETEOF.BIN
' CONTINUES (10) CGI.BIN
' STARTS CLOSE.BIN
' Closes an opened file.
FUNCTION CLOSE(int ff, BYREF ¤SYSERR Err) AS LONG
IF (ff < 1) OR (ff > 32767) THEN
¤SET_ERR(57)
EXIT FUNCTION
END IF
IF EXE.FFLAG[ff] = ·ASSIGN THEN
¤SET_ERR(57)
EXIT FUNCTION
END IF
IF ((EXE.FFLAG[ff] and ·HANDLE) <> ·HANDLE) THEN
if (¤CloseHandle(EXE.FHNDL[ff]) = 0) then
¤SET_ERR(70)
EXIT FUNCTION
end if
END IF
EXE.FFLAG[ff] = 0
EXE.FHNDL[ff] = 0
EXE.FRLEN[ff] = 0
END FUNCTION
' END OF CLOSE.BIN
' CONTINUES (11) CGI.BIN
' STARTS COMMAND$.BIN
' Returns the full command or a parameter of the command line.
FUNCTION COMMAND(int n = 0) AS string
string o,c
int i, p, s, l, q
byte ptr b
c = ltrim((char*) GetCommandLineA) & " "
@b = strptr(c)
if n < 0 then
return ""
elseif n = 0 then
return c
else
s = 1
for i = 1 to len(c)
select case b[i]
case 34
q = (q = 0)
l = 1
case 32
if q = 0 then
if n then
if l then
p += 1
if p = n then
o = ltrim(mid(c, s, i-s))
@b = strptr(o)
i = len(o)
if b[1] = 34 then b[1] = 32
if b[i] = 34 then b[i] = 32
return ltrim(rtrim(o))
end if
s = i
l = 0
end if
end if
end if
case else
l = 1
end select
next i
end if
END FUNCTION
' END OF COMMAND$.BIN
' CONTINUES (12) CGI.BIN
redim string ¤FFLD(1)
redim long ¤FNUM(1)
redim string ¤FCNT(1)
redim string ¤FCTT(1)
redim string ¤FFLN(1)
redim string ¤FTMF(1)
redim string ¤FERR(1)
class ¤cgi
string lheaderssent = 0
string lhtmlstatus = ""
string lcookies = ""
string lbase = ""
string lbody = ""
string lfooter = ""
string lHeader = ""
string luseragent = ""
string lsessid = ""
string lcontenttype = ""
string FORMDATA = ""
string et[380]
long numFormFields = 0
method constructor()
' Default headers
lhtmlstatus = "HTTP/1.1 200 OK"
luseragent = "User-Agent: PluriBASIC CGI 6.0"
lcontenttype = "Content-type: text/html"
' Entities.
String s = "!,!,!|" + chr(34) + "," ","|#,#,#|$,$,$|%,%,%|&,& &,&|',','|(,(,(|),),)|*,* *,*|+,+,+|,,,,,|.,.,.|/,/,/|:,:,:|;,;,;|<,< <,<|=,=,=|>,> >,>|?,?,?|@,@,@|[,[ [,[|\,\,\|],] ],]|^,^,^|_,_,_|`,` `,`|{,{ {,{||,| | |,||},} },}| , , |¡,¡,¡|¢,¢,¢|£,£,£|¤,¤,¤|¥,¥,¥|¦,¦,¦|§,§,§|¨,¨ ¨ ¨ ¨,¨|©,© ©,©|ª,ª,ª|«,«,«|¬,¬,¬|,,|®,® ® ®,®|¯,¯ ‾ ¯,¯|°,°,°|±,± ± ±,±|²,²,²|³,³,³|´,´ ´,´|µ,µ,µ|¶,¶,¶|·,· · ·,·|¸,¸ ¸,¸|¹,¹,¹|º,º,º|»,»,»|¼,¼,¼|½,½ ½,½|¾,¾,¾|¿,¿,¿|À,À,À|Á,Á,Á|Â,Â,Â|Ã,Ã,Ã|Ä,Ä,Ä|Å,Å,Å|Æ,Æ,Æ|Ç,Ç,Ç|È,È,È|É,É,É|Ê,Ê,Ê|Ë,Ë,Ë|Ì,Ì,Ì|Í,Í,Í|Î,Î,Î|Ï,Ï,Ï|Ð,Ð,Ð|Ñ,Ñ,Ñ|Ò,Ò,Ò|Ó,Ó,Ó|Ô,Ô,Ô|Õ,Õ,Õ|Ö,Ö,Ö|×,×,×|Ø,Ø,Ø|Ù,Ù,Ù|Ú,Ú,Ú|Û,Û,Û|Ü,Ü,Ü|Ý,Ý,Ý|Þ,Þ,Þ|ß,ß,ß|à,à,à|á,á,á|â,â,â|ã,ã,ã|ä,ä,ä|å,å,å|æ,æ,æ|ç,ç,ç|è,è,è|é,é,é|ê,ê,ê|ë,ë,ë|ì,ì,ì|í,í,í|î,î,î|ï,ï,ï|ð,ð,ð|ñ,ñ,ñ|ò,ò,ò|ó,ó,ó|ô,ô,ô|õ,õ,õ|ö,ö,ö|÷,÷ ÷,÷|ø,ø,ø|ù,ù,ù|ú,ú,ú|û,û,û|ü,ü,ü|ý,ý,ý|þ,þ,þ|ÿ,ÿ,ÿ|"
int p = 1
int e = 1
int i = 1
byte ptr b = strptr(s)
for i = 1 to len(s)
do while b[i] <> 44 : i += 1 : loop
et[e] = mid(s, p, i-p) : e += 1 : i += 1 : p = i
do while b[i] <> 44 : i += 1 : loop
et[e] = mid(s, p, i-p) : e += 1 : i += 1 : p = i
do while b[i] <> 124 : i += 1 : loop
et[e] = mid(s, p, i-p) : e += 1 : i += 1 : p = i
next i
' Load form data here.
IF ¤ENVIRON("REQUEST_METHOD") = "POST" THEN
sys sBuffer = getmemory(33000)
quad fSize
dword iRead
dword iResult
dword iToRead
int Index
sys hInput
string buffer = ""
hInput = ¤GetStdHandle(byval -10)
iToRead = Val(¤Environ("CONTENT_LENGTH"))
if iToRead < 1 then iToRead = 9999999
For Index = 1 to 10
¤GetFileSizeEx(hInput, byval @fSize)
if fSize then exit for
¤Sleep(200)
Next Index
if fSize then
Do
copy sBuffer, news(32000), 32000
iResult = ¤ReadFile(hInput, byval sBuffer, 32000, byval @iRead, byval 0)
IF iResult=0 THEN EXIT do
IF iRead < 1 THEN
For Index = 1 to 20
iResult = ¤ReadFile(hInput, byval sBuffer, 32000, byval @iRead, byval 0)
IF iRead > 0 THEN EXIT FOR
IF iResult = 0 THEN EXIT FOR
¤Sleep(50)
Next Index
End if
IF iRead<1 THEN EXIT DO
buffer = space(iRead)
copy buffer, sBuffer, iRead
FORMDATA += buffer
If Len(FORMDATA) >= iToRead Then Exit Do
IF iResult=0 THEN EXIT do
Loop
end if
freememory(sBuffer)
END IF
return this.processFormData()
end method
function RootDir() AS LONG
if len(¤ENVIRON("DOCUMENT_ROOT")) then
return ¤ENVIRON("DOCUMENT_ROOT")
elseif len(¤ENVIRON("PATH_TRANSLATED")) then
return ¤ENVIRON("PATH_TRANSLATED")
end if
end function
function ProcessFormData() AS LONG
¤SYSERR Err
string Boundary = ""
string Extension = ""
string LastType = ""
string ContentType = rtrim(ltrim(ucase(parse(¤ENVIRON("CONTENT_TYPE"), 0, "/", 1))))
long MaxItems = 0
Long Index = 0
Long CurItem = -1
Long iLoc = 0
Long FF = 0
Long MaxSize = 2000000
IF FormData = "" THEN
return 0
END IF
if ContentType = "APPLICATION" then
Boundary = "&"
MaxItems = parsecount(FormData, 0, Boundary)
numFormFields = MaxItems
gosub DefaultDimension
for Index = 1 To MaxItems
¤FFLD[Index] = ucase(Parse(Parse(FormData, 0, Boundary, Index), 0, "=", 1))
gosub ManageNumbering
¤FCNT[Index] = ltrim(rtrim(Parse(Parse(FormData, 0, Boundary, Index), 0, "=", 2), 0, chr(0)))
next Index
elseif ContentType = "MULTIPART" then
Boundary = parse(¤ENVIRON("CONTENT_TYPE"), 0, "boundary=", 2)
FormData = trim(FormData, 0, Boundary)
gosub CustomDimension
numFormFields = MaxItems
For Index = 1 To MaxItems
¤FFLD(Index) = trim(ucase(Parse(Parse(Parse(FormData, 0, Boundary, Index+1), 0, "name=", 2), 1, chr(13, 10) + ";", 1)), 1, chr(0, 34))
Gosub ManageNumbering
¤FFLN(Index) = trim(Parse(Parse(Parse(FormData, 0, Boundary, Index+1), 0, "filename=", 2), 1, chr(13, 10, 59), 1), 1, chr(0, 34))
¤FCNT(Index) = parse(FormData, 0, Boundary, Index+1)
iLoc = instr(¤FCNT(Index), chr(13, 10, 13, 10))+4
¤FCNT(Index) = mid(¤FCNT(Index), iLoc, (LEN(¤FCNT(Index))-iLoc)-3)
IF UCASE(rtrim(lTRIM(¤FFLD(Index)))) = "MAX_FILE_SIZE" THEN MaxSize = VAL(¤FCNT(Index))
¤FERR(Index) = "4"
If Len(¤FFLN(Index)) Then
IF LEN(¤FCNT(Index)) > MaxSize THEN
¤FERR(Index) = "2"
ELSE
Extension = parse(¤FFLN(Index), 0, ".", parsecount(¤FFLN(Index), 0, "."))
string td = ¤ENVIRON("TEMP") + "\"
int s = ¤GetTickCount()
¤srand(s)
Do
¤FTMF(Index) = (td + "tmp" & ltrim(str(RND(10000, 99999))) + "." + Extension)
IF LEN(¤DIR(¤FTMF(Index), 0, 0)) = 0 THEN
EXIT DO
END IF
Loop
ff = FREEFILE()
Err.err = 0
¤OPENFILENM(¤FTMF(Index), 4, 0, 0, ff, 128, 1, 1, Err)
¤PUTSTR(string, ff, -1, ¤FCNT(Index), 0, 0, 0)
SETEOF(ff)
CLOSE(ff, Err)
IF Err.err THEN
¤FERR(Index) = "7"
ELSE
¤FCTT(Index) = trim(parse(parse(lcase(parse(FormData, 0, Boundary, Index+1)), 0, "content-type:", 2), 0, chr(13, 10), 1), 1, chr(0))
¤FERR(Index) = "0"
END IF
END IF
End If
Next Index
end if
return -1
ManageNumbering:
if right(¤FFLD(Index), 2) = "[]" THEN
CurItem += 1
¤FFLD(Index) = rtrim(¤FFLD(Index), 0, "[]")
if LastType <> lcase(ltrim(¤FFLD(Index))) then
CurItem = 0
end if
¤FNUM(Index) = CurItem
LastType = lcase(ltrim(¤FFLD(Index)))
ELSE
¤FNUM(Index) = 0
LastType = ""
END IF
RET
CustomDimension:
MaxItems = ParseCount(FormData, 0, Boundary)-1
GOSUB DefaultDimension
RET
DefaultDimension:
redim string ¤FFLD(MaxItems)
redim long ¤FNUM(MaxItems)
redim string ¤FCNT(MaxItems)
redim string ¤FCTT(MaxItems)
redim string ¤FFLN(MaxItems)
redim string ¤FTMF(MaxItems)
redim string ¤FERR(MaxItems)
RET
END FUNCTION
function headerssent(int v)
lheaderssent = v
end function
function headerssent() as int
return lheaderssent
end function
function httpstatus(string v)
if val(v) > 0 then
lhtmlstatus = "HTTP/1.1 " + ltrim(rtrim(str(val(v))))
else
lhtmlstatus = v
end if
end function
function httpstatus() as string
return lhtmlstatus
end function
function cookies() as string
return lcookies
end function
function cookies(string v)
if len(lcookies) then
lcookies += chr(13, 10)
end if
lcookies += v
end function
function useragent() as string
return luseragent
end function
function useragent(string v)
luseragent = v
end function
function contenttype() as string
return lcontenttype
end function
function contenttype(string v)
lcontenttype = v
end function
function Header(string v)
'string p = ""
'return "Set-Cookie: PHPSESSID=" + lsessid + "; path=/;"
lheader = v
end function
function Header() as string
return lheader
end function
function uri(string f, int n) as string
Local Index As Long
Local sParm As String
Local Qry As String
string sParam = ucase(f) + "="
Qry = ¤ENVIRON("QUERY_STRING")
if len(Qry) = 0 then
Qry = COMMAND()
end if
For Index = 1 To parsecount(Qry, 0, "&")
sParm = parse(Qry, 0, "&", Index)
If UCase(Left(sParm, len(sParam))) = sParam Then
return this.entitydecode(this.urldecode(mid(sParm, Len(sParam)+1)))
End If
Next
end function
function cookie(string f) as string
end function
function files(string f, m, optional int num) as string
int Index,Index2,Number,maxn
string sField = f
string Mode = m
string Extra = ""
sField = ucase(ltrim(rtrim(sField)))
for Index = 1 to numFormFields
if ¤FFLD(Index) = sField then
if @num THEN
Do
If ¤FNUM(Index) = num Then Exit Do
Index += 1
If Index > numFormFields then return ""
if ¤FFLD(Index) <> sField then
return ""
end if
Loop
End If
if m = "name" then return ¤FFLN(Index)
if m = "ext" then return "." + lcase(parse(¤FFLN(Index), 0, ".", parsecount(¤FFLN(Index), 0, ".")))
if m = "tmp_name" then return ¤FTMF(Index)
if m = "size" then return ltrim(str(len(¤FCNT(Index))))
if m = "type" then return ¤FCTT(Index)
if m = "error" then return ¤FERR(Index)
if m = "data" then return ¤FCNT(Index)
return ""
end if
next Index
end function
function request(string f) as string
end function
function entitydecode(string t) as string
string o = t
string w = ""
byte ptr b = strptr(o)
int i = 0
int j = 0
int p = 1
int n = 0
for i = 1 to len(t)
if b[i] = 38 then
for j = (i+1) to (i+8)
if b[j] = 59 then
w = mid(t, i, (j-i)+1)
for n = 2 to 380 step 3
if instr(et[n], w) then
o = mid(o, p, i-p) + et[n-1] + mid(o, j+1)
@b = strptr(o)
goto wordreplaced
end if
next n
end if
next j
wordreplaced:
p = i
end if
next i
return o
end function
function entityencode(string t) as string
string o = t
string w = ""
byte ptr b = strptr(o)
int i = 0
int p = 1
int n = 0
for n = 1 to 380 step 3
p = instr(o, et[n])
if p then
w = et[n+1]
@b = strptr(w)
for i = 1 to len(et[n+1])
if b[i] = 32 then
w = mid(w, 1, i-1)
exit for
end if
next i
o = mid(o, 1, p-1) + w + mid(o, p+1)
@b = strptr(o)
end if
next n
return o
end function
function urldecode(ByVal sINP As String) As String
byte ptr pINP
byte ptr pOUT
long nINP, nOUT, nHEX
string th = ""
nINP = Len(sINP)
If nINP = 0 Then return ""
@pINP = strptr(sINP)
@pOUT = @pINP
Do
Select Case pINP
Case 37
@pINP += 1
nINP -= 1
nHEX = nINP
if nHEX > 2 then nHEX = 2
if nHEX Then
th = space(nHex)
copy th, @pInp, nHex
pOUT = Val("0x" + th)
end if
@pINP += nHEX
nINP -= nHEX
Case 43
pOUT = 32
@pINP += 1
nINP -= 1
Case Else
pOUT = pINP
@pINP += 1
nINP -= 1
End Select
@pOUT += 1
nOUT += 1
loop while nINP
return mid(sINP, 1, nOUT)
end function
Function URLENCODE(string sINT) As String
long cTIN = 1
long cTOU = 1
Long cLEN
byte ptr pBIN
byte ptr pBOU
Local sOut As String
string sHex = ""
cLEN = Len(sINT)
sOut = space((cLEN*)+1)
@pBIN = StrPtr(sINT)
@pBOU = StrPtr(sOut)
do
select Case pBIN[cTIN]
Case 48 To 57
pBOU[cTOU] = pBIN[cTIN]
case 65 To 90
pBOU[cTOU] = pBIN[cTIN]
case 97 To 122
pBOU[cTOU] = pBIN[cTIN]
case 46
pBOU[cTOU] = pBIN[cTIN]
Case 32
pBOU[cTOU] = 43
Case Else
If pBIN[cTIN] < 16 Then
pBOU[cTOU] = 37
pBOU[cTOU+1] = 48
pBOU[cTOU+2] = asc(hex(pBIN[cTIN]))
Else
pBOU[cTOU] = 37
sHex = hex(pBIN[cTIN], 2)
pBOU[cTOU+1] = asc(mid(sHex, 1, 1))
pBOU[cTOU+2] = asc(mid(sHex, 2, 1))
End If
cTOU += 2
end select
cTIN += 1
cTOU += 1
if (cTIN > cLEN) then
exit do
end if
loop
return mid(sOut, 1, cTou)
END FUNCTION
function formfield(string f, optional int num) as string
string o = ""
if @num THEN
o = this.files(f, "data", num)
ELSE
o = this.files(f, "data", 0)
END IF
if len(trim(o)) then
return this.entitydecode(this.urldecode(o))
end if
end function
function FileName(string f, optional int num) as string
string o = ""
if @num THEN
o = this.files(f, "name", num)
ELSE
o = this.files(f, "name", 0)
END IF
if len(trim(o)) then
return this.entitydecode(this.urldecode(o))
end if
end function
function TempName(string f, optional int num) as string
string o = ""
if @num THEN
o = this.files(f, "tmp_name", num)
ELSE
o = this.files(f, "tmp_name", 0)
END IF
if len(trim(o)) then
return this.entitydecode(this.urldecode(o))
end if
end function
function FileError(string f, optional int num) as long
string o = ""
if @num THEN
o = this.files(f, "error", num)
ELSE
o = this.files(f, "error", 0)
END IF
if len(trim(o)) then
return val(o)
end if
end function
function FileSize(string f, optional int num) as long
string o = ""
if @num THEN
o = this.files(f, "size", num)
ELSE
o = this.files(f, "size", 0)
END IF
if len(trim(o)) then
return val(o)
end if
end function
function FileType(string f, optional int num) as string
string o = ""
if @num THEN
o = this.files(f, "type", num)
ELSE
o = this.files(f, "type", 0)
END IF
if len(trim(o)) then
return this.entitydecode(this.urldecode(o))
end if
end function
function FileExt(string f, optional int num) as string
string o = ""
if @num THEN
o = this.files(f, "ext", num)
ELSE
o = this.files(f, "ext", 0)
END IF
return o
end function
function gensessid() as string
string o = ""
int Index = 0
¤rand()
For Index = 1 To 32
IF rnd(0, 1) then
o += chr(rnd(65, 90))
ELSE
o += chr(rnd(97, 122))
END IF
Next
return o
end function
function sessid() as string
if lsessid = "" then lsessid = this.formfield("PHPSESSID")
if lsessid = "" then lsessid = this.cookie("PHPSESSID")
if lsessid = "" then lsessid = this.gensessid()
return "Set-Cookie: PHPSESSID=" + lsessid + "; path=/;"
end function
function sessid(string v)
lsessid = v
end function
function getheaders() as string
string o = ""
o += lhtmlstatus + chr(13, 10)
if len(lcookies) then o += lcookies + chr(13, 10)
if len(luseragent) then o += luseragent + chr(13, 10)
if len(lsessid) then o += lsessid + chr(13, 10)
if len(lcontenttype) then o += lcontenttype + chr(13, 10)
if len(lheader) then o += lheader + chr(13, 10)
return o + chr(13, 10)
end function
function getword(string so) as string
string s = lcase(ltrim(rtrim(so)))
if s = "base" then return lbase
if s = "body" then return lbody
if s = "footer" then return lfooter
if s = "sessid" then return lsessid
if s = "useragent" then return luseragent
if s = "contenttype" then return lcontenttype
if s = "httpstatus" then return lhtmlstatus
end function
end class
new ¤cgi cgi
FUNCTION ¤GETFIELD(string f, int n) AS STRING
return cgi.uri(f, n)
END FUNCTION
FUNCTION ¤FORMFIELD(string f, int nm) AS STRING
return cgi.formfield(f, nm)
END FUNCTION
' END OF CGI.BIN
' CONTINUES (671) PLURIBASIC_PREPARE.BIN
' STARTS TERMINATE.BIN
FUNCTION ¤TERMINATE(string sText = "") as long
sys hProcess = ¤OpenProcess(1, 0, ¤GetCurrentProcessId())
IF (hProcess<>0) And (hProcess <> 0xFFFFFFFF) Then
¤TerminateProcess(hProcess, 0)
¤CloseHandle(hProcess)
End If
END FUNCTION
' END OF TERMINATE.BIN
' CONTINUES (674) PLURIBASIC_PREPARE.BIN
' STARTS SLEEP.BIN
SUB SLEEP(dword mSec)
¤Sleep(mSec)
END SUB
' END OF SLEEP.BIN
' CONTINUES (675) PLURIBASIC_PREPARE.BIN
' END OF PLURIBASIC_PREPARE.BIN
' STARTS TOKEN.BIN
' Scripting engine stuff (CGI).
def support_function
function %1w(byval int n, %3 %2 v) {v%1[vidx[n]] = v}
function %1r(byval int n) as %2 {return v%1[vidx[n]]}
function %1p(byval int n) as sys {return @v%1[vidx[n]]}
end def
class ¤Tokens
¤TokenArrays
int numtti = 0
int numstr = 0
int numwst = 0
function constructor(int tti, ast, wst)
numtti = tti
numstr = ast
numwst = wst
int i = 0
for i = 1 to tti
name[i] = ""
next i
for i = 1 to ast
vstr[i] = ""
next i
for i = 1 to wst
vwst[i] = ""
next i
end function
function destructor()
int i = 0
for i = 1 to numtti
del name[i]
next i
for i = 1 to numstr
del vstr[i]
next i
for i = 1 to numwst
del vwst[i]
next i
end function
function declare(byval int i, v, t, m, byval sys h, string n) as long
' i = index of the variable.
name[i] = n ' name of the variable.
vidx[i] = v ' Index of the variable type.
vtyp[i] = t ' type of data.
hmod[i] = m ' module number.
hAdr[i] = h ' address (for udt's).
end function
function udtmember(sys h, d, string m) as string
string s = ¤SYSTEM_UDT_OFFSETS(d)
int i
int j
int l
int f
int q
int Sectn
string sName = ""
string sType = ""
int Offse = 0
int Index = 0
int Lenth = 0
int Offse = 0
int Elems = 0
int lBnd = 0
string Conds = ""
int p = instr(s, "|") + 1
string t = ""
string r = ""
string e = ""
byte ptr c = strptr(s)
string mn = ltrim(rtrim(lcase(m)))
string rs = ""
string sx = ""
int ix = 0
if instr(mn, ".") then
rs = ltrim(rtrim(mid(mn, instr(mn, ".")+1)))
mn = ltrim(rtrim(mid(mn, 1, instr(mn, ".")-1)))
end if
if instr(mn, "(") then
rs = ltrim(rtrim(mid(mn, instr(mn, ")")+1)))
sx = mid(mn, instr(mn, "(")+1)
sx = rtrim(ltrim(mid(sx, 1, instr(sx, ")")-1)))
ix = val(sx)
mn = ltrim(rtrim(mid(mn, 1, instr(mn, "(")-1)))
elseif instr(mn, "[") then
rs = ltrim(rtrim(mid(mn, instr(mn, "]")+1)))
sx = mid(mn, instr(mn, "[")+1)
sx = rtrim(ltrim(mid(sx, 1, instr(sx, "]")-1)))
ix = val(sx)
mn = ltrim(rtrim(mid(mn, 1, instr(mn, "[")-1)))
end if
for i = p to len(s)
if c[i] = asc(";") then
f += 1 ' Increase field.
e = mid(s, p, i-p)
p = (i+1)
byte b at strptr(e)
Sectn = 0
q = 1
for j = 1 to len(e)
if b[j] = asc(":") then
t = mid(e, q, j-q)
Sectn += 1
Select case Sectn
case 1 : sName = t
case 2 : sType = t
case 3 : Index = val(t)
case 4 : Lenth = val(t)
case 5 : Offse = val(t)
case 6 : Elems = val(t)
case 7 : Conds = t
case 8 : lBnd = val(t)
end select
q = j+1
end if
next j
FOR l = 1 TO Elems
if (lBnd = ix) then
if lcase(sName) = mn then
IF sType="CHAR" THEN
string stp = space(Lenth)
copy stp, h+Offse, Lenth
if instr(stp, chr(0)) then
return mid(stp, 1, instr(stp, chr(0))-1)
else
return stp
end if
ELSEIF sType="WCHAR" THEN
wstring stp = space(Lenth)
copy stp, h+Offse, Lenth
if instr(stp, chr(0, 0)) then
return mid(stp, 1, instr(stp, chr(0, 0))-1)
else
return stp
end if
ELSEIF sType="INTEGER" then
short itp = 0
copy @itp, h+Offse, sizeof(itp)
return str(itp)
ELSEIF sType="WORD" then
word itp = 0
copy @itp, h+Offse, sizeof(itp)
return str(itp)
ELSEIF sType="BYTE" then
byte itp = 0
copy @itp, h+Offse, sizeof(itp)
return str(itp)
ELSEIF sType="DWORD" then
dword itp = 0
copy @itp, h+Offse, sizeof(itp)
return str(itp)
ELSEIF sType="INT" then
int itp = 0
copy @itp, h+Offse, sizeof(itp)
return str(itp)
ELSEIF sType="QUAD" then
quad itp = 0
copy @itp, h+Offse, sizeof(itp)
return str(itp)
ELSEIF sType="SINGLE" then
single itp = 0
copy @itp, h+Offse, sizeof(itp)
numberformat(2,1,0,1,0,1)
r = str(itp)
numberformat
return r
ELSEIF sType="DOUBLE" then
double itp = 0
copy @itp, h+Offse, sizeof(itp)
numberformat(4,1,0,1,0,1)
r = str(itp)
numberformat
return r
ELSEIF sType="EXTENDED" then
extended itp = 0
copy @itp, h+Offse, sizeof(itp)
numberformat(6,1,0,1,0,1)
r = str(itp)
numberformat
return r
ELSE
return this.udtmember(h+Offse, Index, rs)
END IF
end if
end if
lBnd += 1
Offse += Lenth
Next l
end if
next i
return ""
end function
function getvalue(byval int m, byval string vn) as string
int i
string s = vn
string r = ""
if instr(s, ".") then
r = mid(s, instr(s, ".")+1)
s = mid(s, 1, instr(s, ".")-1)
end if
if s = "cgi" then
return cgi.getword(r)
else
do
for i = 1 to numtti
if hmod[i] = m then
if name[i] = s then
select case vtyp[i]
case -16 : return vstr[vidx[i]] ' string
case -19 : return vwst[vidx[i]] ' wstring
case -7 : return str(vdwd[vidx[i]]) ' dword
case -5 : return str(vlng[vidx[i]]) ' long
case -8 : return str(vwrd[vidx[i]]) ' word
case -6 : return str(vint[vidx[i]]) ' integer (short)
case -9 : return str(vbyt[vidx[i]]) ' byte
case -10 : return str(vqud[vidx[i]]) ' quad
case -11 : return str(vsng[vidx[i]]) ' single
case -12 : return str(vdbl[vidx[i]]) ' double
case -13 : return str(vext[vidx[i]]) ' extended
case -14 : return str(vcur[vidx[i]]) ' currency
case -15 : return str(vcux[vidx[i]]) ' currencyx
case -24 : return str(vgui[vidx[i]]) ' guid
case -29 : return str(vhdl[vidx[i]]) ' handle
case -30 : return str(vadr[vidx[i]]) ' address
case else : return this.udtmember(hadr[i], vtyp[i], r)
end select
end if
end if
next i
if m then
m = 0 ' no match in local variables. Let's try global.
else
return "" ' no match in global variables, exit with an empty string.
end if
loop
end if
end function
support_function str string
function strs(byval int n) as sys {return strptr(vstr[vidx[n]])}
support_function wst wstring
function wsts(byval int n) as sys {return strptr(vwst[vidx[n]])}
support_function int short
support_function wrd word
support_function dwd dword
support_function lng long
support_function qud quad
support_function byt byte
support_function sng single
support_function ext extended byref
support_function gui string
function wgui(byval int n) as sys {return strptr(vgui[vidx[n]])}
support_function cur double
support_function cux double
support_function hdl sys
support_function adr sys
end class
' END OF TOKEN.BIN
' STARTS STRINGN.BIN
//Assigns a truncated null terminated string.
MACRO ¤STRN_SET(v, c, l b)
string b = c
if len(b) > l then
b = left(b, l)
elseif len(b) < l then
b += space(l-len(b))
end if
v = b
END MACRO
' END OF STRINGN.BIN
' STARTS STR$.BIN
'int dp ' DECIMAL PLACES
'int trz ' STRIP TRAILING ZEROS
'int sn ' SCIENTIFIC NOTATION BY DEFAULT
'int sdp ' INHIBIT ZERO BEFORE DECIMAL POINT
'int sns ' LEADING SPACE FOR NON NEGATIVE NUMBERS
'int lps ' LEAD PADDING SPACES
'numberformat(8,0,0,0,1,0) 'default settings
'numberformat 'return to default
MACRO ¤STRCODE(dc)
numberformat(dc,1,0,1,0,0)
string ss = str(v)
numberformat
if v < 0 then
return ltrim(ss)
else
return " " + ltrim(ss)
end if
END MACRO
FUNCTION ¤STR(double v, byref long d) as string
long d2 = 6
if @d then d2 = d
¤STRCODE(d2)
END FUNCTION
FUNCTION ¤STR(single v, byref long d) as string
long d2 = 6
if @d then d2 = d
¤STRCODE(d2)
END FUNCTION
FUNCTION ¤STR(quad v, byref long d) as string
¤STRCODE(0)
END FUNCTION
FUNCTION ¤STR(quad v) as string
long d = 0
¤STRCODE(0)
END FUNCTION
' END OF STR$.BIN
' STARTS RESOURCE$.BIN
' Returns the contents of a resource
FUNCTION ¤RESOURCE(int rt, rn) AS WSTRING
WCHAR zText[10000]
int nc = ¤LoadStringW(GetModuleHandle(0), rn, zText, byval 10000)
if nc then
return rtrim(zText)
end if
return ""
END FUNCTION
' Returns the contents of a resource
FUNCTION ¤RESOURCE(string rt, rn) AS STRING
sys nc = 0
int i = 0
asciiz rnm[256] = rn + chr(0)
if rt = "data" then
nc = ¤FindResourceA(GetModuleHandle(0), rnm, byval 10)
else
for i = 1 to 30
if i <> 6 then
nc = ¤FindResourceA(GetModuleHandle(0), rnm, byval i)
if nc then
exit for
end if
end if
next i
end if
if nc then
int rSize = ¤SizeofResource(GetModuleHandle(0), nc)
sys hRes = ¤LoadResource(GetModuleHandle(0), nc)
sys hData = ¤LockResource(hRes)
string o = news(rSize)
copy(o, hData, rSize)
¤FreeResource(hRes)
return o
end if
END FUNCTION
' Returns the contents of a resource
FUNCTION ¤RESOURCE(string rt, int rn) AS STRING
sys nc = 0
int i = 0
if rt = "data" then
nc = ¤FindResourceA(GetModuleHandle(0), rn, byval 10)
else
for i = 1 to 30
if i <> 6 then
nc = ¤FindResourceA(GetModuleHandle(0), byval rn, byval i)
if nc then
exit for
end if
end if
next i
end if
if nc then
int rSize = ¤SizeofResource(GetModuleHandle(0), nc)
sys hRes = ¤LoadResource(GetModuleHandle(0), nc)
sys hData = ¤LockResource(hRes)
string o = news(rSize)
copy(o, hData, rSize)
¤FreeResource(hRes)
return o
end if
END FUNCTION
' END OF RESOURCE$.BIN
' STARTS PRINTR.BIN
SUB ¤INITCONSOLE()
STATIC Allc AS LONG
IF Allc=0 THEN
¤AllocConsole()
Allc = 1
END IF
END SUB
MACRO ¤STDOUT()
INT lWritten = 0
SYS hFile = 0
INT Btc = 0
hFile = ¤GetStdHandle(-11)
If cgi.headerssent()=0 Then
cgi.headerssent = -1
TTsnd = cgi.getheaders()
¤WriteConsole(hFile, ByVal StrPtr(TTsnd), byval Len(TTsnd), lWritten, ByVal 0)
End if
if cr=1 then s += chr(13, 10)
if cr=2 then s += ""
FOR Btc = 1 TO 50
IF ((Btc*32000)-31999) > len(s) THEN EXIT FOR
TTsnd = MID(s, ((Btc*32000)-31999), 32000)
¤WriteConsole(hFile, ByVal StrPtr(TTsnd), byval Len(TTsnd), lWritten, ByVal 0)
NEXT Btc
END MACRO
SUB ¤PRINTASZ(ASCIIZ c[0], byval int cr)
STRING TTsnd = ""
string s = c
¤STDOUT()
END SUB
SUB ¤PRINTSTR(STRING c, byval int cr)
STRING TTsnd = ""
STRING s = c
¤STDOUT()
END SUB
SUB ¤PRINTJSN(STRING c, byval int cr)
STRING TTsnd = ""
STRING s = c
¤STDOUT()
END SUB
SUB ¤PRINTSTZ(ZSTRING c[0], byval int cr)
STRING TTsnd = ""
STRING s = c
¤STDOUT()
END SUB
SUB ¤PRINTWST(WSTRING c, byval int cr)
STRING TTsnd = ""
STRING s = c
¤STDOUT()
END SUB
SUB ¤PRINTWSZ(WZSTRING c[0], byval int cr)
WSTRING TTsnd = ""
WSTRING s = c
¤STDOUT()
END SUB
' END OF PRINTR.BIN
' STARTS PLURIBASIC_INIT.BIN
' This code is executed before anything else, if you want to do something before nything else, see PLURIBASIC_PREPARE
' END OF PLURIBASIC_INIT.BIN
' STARTS GETFIELD.BIN
' Returns the value of a submitted URI field.
FUNCTION GETFIELD(string f, int n) AS STRING
return cgi.uri(f, n)
END FUNCTION
' END OF GETFIELD.BIN
' STARTS FORMOUT.BIN
' STARTS PROCSTR.BIN
'Returns a copy of the html code with embedded token variables.
FUNCTION PROCSTR(byval int hm, string html) AS STRING
string o = html
string v = ""
int i = 0
int p = 0
int k = 0
int r = 0
byte ptr b = strptr(o)
i = 0
do
i += 1
if i > len(o) then exit do
if b[i] = 91 then ' [
i += 1
if b[i] = 33 then ' !
p = (i+1)
k = 1
do
i += 1
if i > len(o) then
exit do
end if
if b[i] = 91 then ' [
k += 1
elseif b[i] = 93 then ' ]
k -= 1
if k = 0 then
v = ¤GetTokenContents(hm, mid(o, p, (i-p)))
o = mid(o, 1, p-3) + v + mid(o, i+1)
@b = strptr(o) ' String changed, refresh the PTR.
r += 1
i = p
if len(o) > 500000 then ' more than 500kb.
' probably an endless loop (self-expanding token)! abort!!
return o
end if
exit do
end if
end if
loop
end if
end if
loop
return o
END FUNCTION
' END OF PROCSTR.BIN
' CONTINUES (1) FORMOUT.BIN
' Outputs a form with embedded token variables.
FUNCTION FORMOUT(byval int hm, byval string f = "") AS LONG
if @f then
¤PRINTSTR(PROCSTR(hm, f), 0)
else
¤PRINTSTR(PROCSTR(hm, ""), 0)
end if
END FUNCTION
' END OF FORMOUT.BIN
' STARTS FORMFIELD.BIN
' Returns the contents of a submitted form's field.
FUNCTION FORMFIELD(string f, optional int nm) AS STRING
return cgi.formfield(f, nm)
END FUNCTION
' END OF FORMFIELD.BIN
' STARTS CALLBACKDATA.BIN
' END OF CALLBACKDATA.BIN
new ¤Tokens ¤tk(1, 1, 0)
function ¤GetTokenContents(int hm, string v) as string
return ¤tk.getvalue(hm, v)
end function
DECLARE FUNCTION PBMAIN() AS INT
¤tk.declare(1, 1, -16, 0, 0, "upload") : ¤tk.strw(1) = ¤RESOURCE("data", "upload")
' Initializes various things in the script.
FUNCTION PluriBASIC_Initialize() AS LONG
END FUNCTION
FUNCTION PBMAIN() AS INT
INT ¤RETVAL = 0
¤SYSERR Err
STRING ¤SCV14 = GETFIELD("action", byval 0)
IF ¤SCV14 = "upload" THEN
¤PRINTSTR("Temporary file is at:
", 1)
¤PRINTSTR(cgi.TempName("fileToUpload", byval 0) & "
", 1)
¤PRINTSTR("
", 1)
¤PRINTSTR("Remote Name:
", 1)
¤PRINTSTR(cgi.FileName("fileToUpload", byval 0) & "
", 1)
¤PRINTSTR("
", 1)
¤PRINTSTR("Extension:
", 1)
¤PRINTSTR(cgi.FileExt("fileToUpload", byval 0) & "
", 1)
¤PRINTSTR(¤STR(cgi.FileError("fileToUpload", byval 0), byval 0) & "
", 1)
¤PRINTSTR(FORMFIELD("fileToUpload", byval 0), 1)
¤PRINTSTR("uploaded", 1)
ELSE
FORMOUT(3002, ¤tk.strr(1))
END IF
RETURN ¤RETVAL
END FUNCTION
PBMAIN() ' invoke entry point