Я их использовал при создании распределенных систем различных типов и довольно успешно.
Сейчас они уже лежат без дела. Возможно кому-то пригодятся.
CGI.tpl
Код: Выделить всё
#TEMPLATE(CGI, 'CGI Template'),FAMILY('ABC')
#INCLUDE('CGI.TPW')
Код: Выделить всё
#!-
#!- CGI TPW
#!-
#!- See CGI.TPL for details
#!-
#!-
#!-----------------------------------------------------------------------------------------
#EXTENSION(CGIGlobal, 'CGI Application'),APPLICATION
#DISPLAY
#DISPLAY('CGI Global Extension Settings')
#INSERT(%dbStuff)
#SHEET
#TAB('General')
#DISPLAY
#PROMPT('CGI Class Name:', @s255),%CGIClassName,REQ
#DISPLAY
#ENABLE(%FALSE)
#!- Right now, we are only dealing with IIS
#!PROMPT('Выбор типа WWW сервера',OPTION),%CGIWWWServer,DEFAULT('Microsoft IIS v5.0 (WinNT)')
#!PROMPT('Microsoft IIS v5.0 (WinNT)',RADIO)
#!PROMPT('Microsoft PWS (Win95)',RADIO)
#!PROMPT('O''Reilly WebSite v2.0',RADIO)
#ENDENABLE
#DISPLAY
#BOXED('WWW сервер - информация.')
#DISPLAY
#DISPLAY('Этот шаблон работает с любым ')
#DISPLAY('WEB сервером c поддержкой СGI.')
#DISPLAY
#ENDBOXED
#DISPLAY
#BOXED('Клиент - информация.')
#DISPLAY
#DISPLAY('Унифицированo для создания ')
#DISPLAY('клиентских приложений WEB сервера.')
#DISPLAY
#ENDBOXED
#DISPLAY
#INSERT(%cCGIMethodReference)
#DISPLAY
#ENDTAB
#ENDSHEET
#ATSTART
#IF (NOT %Target32)
#ERROR('CGI Applications must be compiled as 32 bit applications.')
#ENDIF
#FIX(%Procedure,%FirstProcedure)
#IF (%ProcedureTemplate = 'ToDo')
#ERROR('CGI Applications require that the application''s first procedure be defined, otherwise they will not run as expected.')
#ENDIF
#ENDAT
#AT(%GlobalData)
!- Generated by Global CGI template
INCLUDE('cCGI.inc') #<!- cCGI Base Class
%[20]CGIClassName CLASS(cCGI) #<!- User CGI Class
Init PROCEDURE, VIRTUAL #<!- Virtual Procedure
HeaderOut PROCEDURE, VIRTUAL #<!- Virtual Procedure
FooterOut PROCEDURE, VIRTUAL #<!- Virtual Procedure
END
#ENDAT
#AT (%ProgramProcedures)
%CGIClassName.Init PROCEDURE #<!- Declare Virtual CGI Initialization Procedure
#EMBED(%CGIInitMethodData,'cCGI.Init Method Data Section'),DATA
CODE
#EMBED(%CGIInitMethodStart,'cCGI.Init Method VIRTUAL Begin')
PARENT.Init #<!- We must call the PARENT to initialize cCGI properties
#EMBED(%CGIInitMethodEnd,'cCGI.Init Method VIRTUAL End')
%CGIClassName.HeaderOut PROCEDURE #<!- Declare Virtual Header Procedure
#EMBED(%CGIHeaderOutMethodData,'cCGI.HeaderOut Method Data Section'),DATA
CODE
!- Header Code
!---------------
#EMBED(%CGIHeaderOutMethodStart,'cCGI.HeaderOut Method VIRTUAL Start')
#IF (%HTMLGenerateAll)
PARENT.HeaderOut
!
! Я изменил эту строку для того чтобы обеспечить внешнюю настройку для BODY
! SELF.HTMLOut('<<TITLE>%HTMLTitle<</TITLE><</HEAD><<BODY %HTMLBody>')
!
#IF(%HTMLNscapeTables)
SELF._DefTableCenter = %HTMLCenterTables
SELF._DefTableBorder = %HTMLBorder
SELF._DefTableRowAlign = 0
SELF._DefTableWidth = %HTMLWidthPercentage
SELF.TableSet(SELF._DefTableCenter, SELF._DefTableBorder, SELF._DefTableRowAlign , SELF._DefTableWidth)
#ENDIF
#IF(%GetAllCGI)
SELF.GetAllCGI #<!- Get all CGI data
#ENDIF
#ENDIF
#EMBED(%CGIHeaderOutMethodEnd,'cCGI.HeaderOut Method VIRTUAL End')
%CGIClassName.FooterOut PROCEDURE #<!- Declare Virtual Footer Procedure
#EMBED(%CGIFooterOutMethodData,'cCGI.FooterOut Method Data Section'),DATA
CODE
!- Footer Code
!---------------
#EMBED(%CGIFooterOutMethodStart,'cCGI.FooterOut Method VIRTUAL Start')
#IF (%HTMLGenerateAll)
! Все следующие строки я закоментировал
! #IF (%HTMLMailto)
! SELF.HTMLOut('<<br><<br>') #<!- Output other HTML
! SELF.HTMLOut('<<A HREF="mailto:%HTMLMailToAddress">')
! SELF.HTMLOut('<<ADDRESS>< %HTMLMailto ><</ADDRESS><</A><<p>')
! #ENDIF
! #IF (%HTMLCopy)
! SELF.HTMLOut('© %HTMLCopy <<p>')
! #ENDIF
! #IF (%HTMLLastUpdated)
! SELF.HTMLOut('<<i>Last Updated %HTMLLastUpdated<</i><<p>')
! #ENDIF
PARENT.FooterOut
#ENDIF
#EMBED(%CGIFooterOutMethodEnd,'cCGI.FooterOut Method VIRTUAL End')
#ENDAT
#AT(%ProgramSetup)
#EMBED(%CGIHandCodeBeforeInit, 'cCGI Before Initialization')
%CGIClassName.Init #<!- Call object constructor to handle all initializing
#EMBED(%CGIHandCodeAfterInit, 'cCGI After Initialization')
#ENDAT
#AT(%ProgramEnd)
#EMBED(%CGIHandCodeBeforeKill, 'cCGI Before Kill')
%CGIClassName.Kill #<!- Call object destructor to clean up
#EMBED(%CGIHandCodeAfterKill, 'cCGI After Kill')
#ENDAT
#!-----------------------------------------------------------------------------------------
#PROCEDURE(CGISource,'CGI Source Procedure')
#PROMPT('Parameters',@s255),%Parameters #! Retrieve parameters used
#INSERT(%dbStuff)
#DISPLAY
#DISPLAY('Для включения класса ' & %CGIClassName)
#DISPLAY('в Ваш код, объявите ваше приложение как глобальное.')
#DISPLAY
#INSERT(%cCGIMethodReference)
#DISPLAY
#!PREPARE
#!SET(%ProcedureIsGlobal,%TRUE)
#!ENDPREPARE
#IF(%Parameters) #! IF Parameters used
%[20]Procedure %ProcedureType %Parameters #<! Declare Procedure
#ELSE #! ELSE (IF parameters not used)
%[20]Procedure %ProcedureType #<! Declare Procedure
#ENDIF #! END (IF parameters used)
#FOR(%LocalData)
%[20]LocalData %LocalDataStatement
#ENDFOR
#EMBED(%CGIDataSection,'CGI Data Section'),DATA #! Embedded Source Code
CODE
#EMBED(%CGIProcessedCode,'CGI Processed Code'),LABEL #! Embedded Source Code
#!
#GROUP(%cCGIMethodReference)
#ENABLE(CLIP(%CGIClassName)<>'')
#BUTTON('cCGI Object Method Reference'),AT(,,150,)
#SHEET
#TAB('Server')
#INSERT(%dbStuff)
#BOXED('General Methods')
#DISPLAY
#DISPLAY(%CGIClassName & '.GetAllCGI()')
#DISPLAY(' - Initializes all Values from current CGI session.')
#DISPLAY
#DISPLAY(%CGIClassName & '.GetValue(MyValue)')
#DISPLAY(' - Returns a Value from CGI session.')
#DISPLAY(' Use ' & %CGIClassName & '.GetAllCGI first.')
#DISPLAY
#DISPLAY(%CGIClassName & '.HTMLOut(MyOut)')
#DISPLAY(' - Prints out a single line of HTML')
#DISPLAY
#ENDBOXED
#ENDTAB
#TAB('Client HTTP')
#BOXED('HTTP Methods')
#DISPLAY
#DISPLAY
#DISPLAY(%CGIClassName & '.Postadata')
#DISPLAY('(string pstserv, string pstexe,')
#DISPLAY('*string pstarea, *string pTextBuf)')
#DISPLAY
#DISPLAY
#ENDBOXED
#ENDTAB
#TAB('Client FTP')
#BOXED('FTP Methods')
#DISPLAY
#DISPLAY(%CGIClassName & '.CreateDirFTP')
#DISPLAY('(string srvdir, string srvlogin,')
#DISPLAY('string srvpsw, string srvurl)')
#DISPLAY
#DISPLAY(%CGIClassName & '.GetAFileFTP')
#DISPLAY('(string srvfile,string locfile,')
#DISPLAY('string srvlogin, string srvpsw')
#DISPLAY('string srvurl)')
#DISPLAY
#DISPLAY(%CGIClassName & '.PutAFileFTP')
#DISPLAY('(string locfile,string srvfile,')
#DISPLAY('string srvlogin, string srvpsw,')
#DISPLAY('string srvurl)')
#DISPLAY
#DISPLAY(%CGIClassName & '.DeleteDirFTP')
#DISPLAY('(string srvdir, string srvlogin,')
#DISPLAY('string srvpsw, string srvurl)')
#DISPLAY
#DISPLAY(%CGIClassName & '.DeleteFileFTP')
#DISPLAY('(string srvfile, string srvlogin,')
#DISPLAY('string srvpsw, string srvurl)')
#DISPLAY
#DISPLAY(%CGIClassName & '.RenameFileFTP')
#DISPLAY('(string srvfile, string srvnewfile,')
#DISPLAY('string srvlogin, string srvpsw,')
#DISPLAY('string srvurl)')
#DISPLAY
#ENDBOXED
#ENDTAB
#TAB('Common')
#BOXED('Common Methods')
#DISPLAY
#DISPLAY(%CGIClassName & '.GetDskName(String)')
#DISPLAY(%CGIClassName & '.GetDskInfo(*String,*String,*String)')
#DISPLAY(%CGIClassName & '.GetDskFree')
#DISPLAY('(*string s1,*ulong SectPerClast,')
#DISPLAY('*ulong BytesPerSect,*ulong NumbFreeClust,')
#DISPLAY('*ulong AllNumbOfClust)')
#DISPLAY(%CGIClassName & '.GetPcName(String)')
#DISPLAY(%CGIClassName & '.GetUserName(String)')
#DISPLAY
#ENDBOXED
#ENDTAB
#ENDSHEET
#ENDBUTTON
#ENDENABLE
#GROUP(%dbStuff)
#DISPLAY
#DISPLAY('CGI Templates for Clarion')
#DISPLAY('extended by Andrew Art from ')
#DISPLAY('sourse Dave Berton CIS 102644,3557.')
#DISPLAY
#DISPLAY('This code is freeware. I take no responsibility')
#DISPLAY('if it happens to destroy everything.')
#DISPLAY
#DISPLAY('Send all suggestions to webprotech@mail.ru.')
#DISPLAY
Код: Выделить всё
!- CGI Class definition file
OMIT('_EndOfInclude_',_cCGIPresent_)
_cCGIPresent_ EQUATE(1)
TupleQType QUEUE,TYPE !- Used for Accept: and "extra" headers
Key STRING(255) !- and for holding POST form key=value pairs
Value CSTRING(2000) !- Change from 1000
offset LONG !- Byte offset into Content File of value [FORM HUGE]
length LONG !- Length of value, bytes [FORM HUGE]
!Type STRING(15) !- [ACCEPT], [EXTRA HEADERS], [FORM LITERAL] or [FORM HUGE]
END
WIN32_FIND_DATA_Def Group,type
dwFileAttributes Long
ftCreationTime:dwLowDateTime Long
ftCreationTime:dwHighDateTime Long
ftLastAccessTime:dwLowDateTime Long
ftLastAccessTime:dwHighDateTime Long
ftLastWriteTime:dwLowDateTime Long
ftLastWriteTime:dwHighDateTime Long
nFileSizeHigh Long
nFileSizeLow Long
dwReserved0 Long
dwReserved1 Long
cFileName CString(261)
cAlternate CString(15)
End
cCGI CLASS,TYPE,MODULE('cCgi.clw'),LINK('cCgi.clw')
hStdIn LONG !- Handle to read from the server
hStdOut LONG !- Handle of file to write HTML to
CGI_RequestMethod CSTRING(50) !- Contains 'POST' or 'GET'
CGI_QueryString CSTRING(1000) !- Query string sent to exe
CGI_ContentLength CSTRING(50) !- Length of POSTed data
CGI_RemoteAddr CSTRING(50) ! - Моя вставка
CGI_HTTPUserAgent CSTRING(50) ! - Моя вставка
CGI_ContentType CSTRING(50) ! - Моя вставка
CGI_Server CSTRING(50) ! - Моя вставка
CGI_PathT CSTRING(50) ! - Моя вставка
CGI_ServerN CSTRING(50) ! - Моя вставка
CGI_FormData CSTRING(128000) !- All POSTed data изменено с 64 000
CGI_TextArea CSTRING(128000) !**** Область для текста в TEXTAREA ( имя поля TXTAREA, имя рисунка ITXTAREA )
CGI_TextLength LONG !**** ее длина
TableCenter BYTE !- Current table setting
TableBorder BYTE !- Current table setting
TableRowAlign BYTE !- Current table setting
TableWidth BYTE !- Current table setting
_DefTableCenter BYTE !- Default table setting
_DefTableBorder BYTE !- Default table setting
_DefTableRowAlign BYTE !- Default table setting
_DefTableWidth BYTE !- Default table setting
TupleQ &TupleQType !- POSTed data
Init PROCEDURE,VIRTUAL !- Constructor
GetAllCGI PROCEDURE !- Deformats POSTed data
GetTextArea PROCEDURE !**** - Deformat TEXTAREA - special edition
GetValue FUNCTION(STRING MyValue),STRING !- Returns form data value
HTMLOut PROCEDURE(STRING) !- Outputs a line of HTML to the server
TableSet PROCEDURE(BYTE Center, BYTE Border, BYTE RowAlign, BYTE Width) !- Assign values to table attributes
TableHeader PROCEDURE(STRING MyHeader) !- Output a table header
TableItem PROCEDURE(STRING MyItems) !- Output a single table item
TableFooter PROCEDURE !- Output a table footer
ErrorOut PROCEDURE(<STRING MyError>),VIRTUAL !- Displays error message and halts app
HeaderOut PROCEDURE,VIRTUAL !- Output the HTML page header
FooterOut PROCEDURE,VIRTUAL !- Output the HTML page footer
Kill PROCEDURE !- Destructor
GetDskName FUNCTION(STRING z1),long !- Returns form data value
GetDskInfo PROCEDURE(*string s1,*string s2,*string s3)
GetDskFree PROCEDURE(*string s1,*ulong SectPerClast,*ulong BytesPerSect,*ulong NumbFreeClust,*ulong AllNumbOfClust)
GetPcName FUNCTION,string
GetUserName FUNCTION,string
CreateDirFTP PROCEDURE(string srvdir, string srvlogin, string srvpsw, string srvurl), long ! Ftp Create Directory
Postadata PROCEDURE(string pstserv, string pstexe, *string pstarea, *string pTextBuf), long ! URL POST Data Server Data
GetAFileFTP PROCEDURE(string srvfile,string locfile,string srvlogin, string srvpsw, string srvurl), long ! Ftp Get File
PutAFileFTP PROCEDURE(string locfile,string srvfile,string srvlogin, string srvpsw, string srvurl), long ! Ftp Put File
DeleteDirFTP PROCEDURE(string srvdir, string srvlogin, string srvpsw, string srvurl), long ! Ftp Remove Directory
DeleteFileFTP PROCEDURE(string srvfile, string srvlogin, string srvpsw, string srvurl), long ! Ftp Remove File
RenameFileFTP PROCEDURE(string srvfile, string srvnewfile, string srvlogin, string srvpsw, string srvurl), long ! Ftp Remove File
END
_EndOfInclude_
Код: Выделить всё
!- cCGI method definition file
MEMBER()
MAP
!- CGI API calls
MODULE('win32.lib')
GetStdhandle(ULONG),UNSIGNED,PASCAL,NAME('GetStdhandle')
ReadFile(UNSIGNED,*CSTRING,ULONG,*ULONG,<*OVERLAPPED>),BOOL,PASCAL,RAW,NAME('ReadFile')
WriteFile(UNSIGNED,*CSTRING,ULONG,*ULONG,<*OVERLAPPED>),BOOL,PASCAL,RAW,NAME('WriteFile')
GetEnvironmentVar(*CSTRING,*CSTRING,ULONG),ULONG,PASCAL,RAW,NAME('GetEnvironmentVariableA')
SetFilePointer(UNSIGNED,LONG,LONG,ULONG),ULONG,PASCAL,NAME('SetFilePointer')
SetEndOfFile(UNSIGNED),BOOL,PASCAL,NAME('SetEndOfFile')
Lwrite(UNSIGNED,*CSTRING,UNSIGNED)UNSIGNED,PASCAL,RAW,NAME('_lwrite')
Lread(UNSIGNED,*CSTRING,UNSIGNED)UNSIGNED,PASCAL,RAW,NAME('_lread')
end
MODULE('Windows.DLL')
GetVolumeInformationA(*CSTRING,*CSTRING,ULONG,*ULONG,*ULONG,*ULONG,*CSTRING,ULONG),BOOL,PASCAL,RAW
GetDiskFreeSpaceA(*CSTRING,*ULONG,*ULONG,*ULONG,*ULONG),BOOL,PASCAL,RAW
GetDriveType(*CSTRING),UNSIGNED,PASCAL,RAW,NAME('GetDriveTypeA')
GetComputerName(*CSTRING,*ULONG),BOOL,PASCAL,RAW,NAME('GetComputerNameA')
GetUserNameA(*CSTRING,*ULONG),BOOL,PASCAL,RAW
end
module('wininet.lib')
InternetOpen(*CSTRING,ulong,*CSTRING,ulong,ulong),unsigned,pascal,raw,NAME('InternetOpenA'),dll(1)
InternetOpenURL(unsigned,*CSTRING,ulong,ulong,ulong,ulong),unsigned,pascal,raw,name('InternetOpenURLA'),dll(1)
InternetReadFile(unsigned,*CSTRING,ulong,*ulong),unsigned,pascal,raw,name('InternetReadFile'),dll(1)
InternetCloseHandle(unsigned),pascal,raw,name('InternetCloseHandle'),dll(1)
! Далее мое творчество
InternetConnect(unsigned,*CSTRING,ulong,*CSTRING,*CSTRING,ulong,ulong,ulong),unsigned,pascal,raw,NAME('InternetConnectA'),dll(1)
HttpOpenRequest(unsigned,*CSTRING,*CSTRING,*CSTRING,*CSTRING,ulong,ulong,ulong),unsigned,pascal,raw,name('HttpOpenRequestA'),dll(1)
HttpSendRequest(unsigned,*CSTRING,ulong,*CSTRING,ulong),unsigned,pascal,raw,name('HttpSendRequestA'),dll(1)
! и еще
! HttpSendRequestEx(unsigned,*CSTRING,*CSTRING,ulong,ulong ),pascal,raw,NAME('HttpSendRequestExA'),dll(1)
! HttpEndRequest(unsigned,*CSTRING,ulong,ulong),pascal,raw,name('HttpEndRequest'),dll(1)
! и еще FTP
FtpGetCurrentDirectory(long,*cstring,*long),long,raw,pascal,name('FtpGetCurrentDirectoryA'),dll(1)
FtpSetCurrentDirectory(long,*cstring),long,raw,pascal,name('FtpSetCurrentDirectoryA'),dll(1)
FtpCreateDirectory(long,*cstring),long,raw,pascal,name('FtpCreateDirectoryA'),dll(1)
FtpRemoveDirectory(long,*cstring),long,raw,pascal,name('FtpRemoveDirectoryA'),dll(1)
FtpDeleteFile(long,*cstring),long,raw,pascal,name('FtpDeleteFileA'),dll(1)
FtpRenameFile(long,*cstring,*cstring),long,raw,pascal,name('FtpRenameFileA'),dll(1)
FtpGetFile(long,*cstring,*cstring,long,long,long,long),long,raw,pascal,name('FtpGetFileA'),dll(1)
FtpPutFile(long,*cstring,*cstring,long,long),long,raw,pascal,name('FtpPutFileA'),dll(1)
FtpFindFirstFile(long,*cstring,win32_find_data_def,long,long),long,raw,pascal,name('FtpFindFirstFileA'),dll(1)
FtpOpenFile(long,*cstring,long,long,long),long,raw,pascal,name('FtpOpenFileA'),dll(1)
FtpGetFileSize(long,long),long,raw,pascal,dll(1)
! FtpFindFirstFile(long,*cstring,win32_find_data_def,long,long),long,raw,pascal,name('FtpFindFirstFileA')
end
END
INCLUDE('cCGI.inc')
!- CGI Global Template Data
ITEMIZE(-1) !- Object Equates
_Default EQUATE
_Center EQUATE
_Left EQUATE
_Right EQUATE
END
!---------------------------
FILE_BEGIN ULONG(0)
STD_INPUT_unsigned EQUATE(-10)
STD_OUTPUT_unsigned EQUATE(-11)
!- For WriteFile() API
OVERLAPPED GROUP,TYPE
Internal ULONG
InternalHigh ULONG
Offset ULONG
OffsetHigh ULONG
hEvent UNSIGNED
END
!- WriteFile() vars
lBytesWritten ULONG
OVERLAPPED_ LIKE(OVERLAPPED)
ZeroPointer LONG(0)
ZERO_DIST_TO_MOVE LONG(0)
cCGI.Init PROCEDURE
EnvVarName CSTRING(20) !- Environment variable name
ContentLength ULONG !- Length of POSTed data
BytesRead ULONG !- Bytes of POSTed data read
multipart string(19) !**** Переменная для выявления UPLOAD файла
VarLen EQUATE(129)
BegTxtArea long
EndtxtArea long
OstStr string(250)
LenOst long
CODE
SELF.TupleQ &= NEW(TupleQType)
SELF.hStdIn = GetStdHandle(STD_INPUT_unsigned) !- I/O parms
SELF.hStdOut = GetStdHandle(STD_OUTPUT_unsigned) !- I/O parms
SELF.HTMLOut('Content-type: text/html<10>') !- Let the server know we are alive
EnvVarName = 'REQUEST_METHOD'
junk# = GetEnvironmentVar(EnvVarName,SELF.CGI_RequestMethod,VarLen)
! -------------------------------------------------------------------
EnvVarName = 'REMOTE_ADDR' ! Моя вставка
junk# = GetEnvironmentVar(EnvVarName,SELF.CGI_RemoteAddr,VarLen) !
EnvVarName = 'HTTP_USER_AGENT' ! Моя вставка
junk# = GetEnvironmentVar(EnvVarName,SELF.CGI_HTTPUserAgent,VarLen) !
EnvVarName = 'CONTENT_TYPE' ! Моя вставка
junk# = GetEnvironmentVar(EnvVarName,SELF.CGI_ContentType,VarLen) !
multipart = sub(SELF.CGI_ContentType,1,19) !
EnvVarName = 'SERVER_SOFTWARE' ! Моя вставка
junk# = GetEnvironmentVar(EnvVarName,SELF.CGI_Server,VarLen) !
EnvVarName = 'PATH_TRANSLATED' ! Моя вставка
junk# = GetEnvironmentVar(EnvVarName,SELF.CGI_PathT,VarLen) !
EnvVarName = 'SERVER_NAME' ! Моя вставка
junk# = GetEnvironmentVar(EnvVarName,SELF.CGI_ServerN,VarLen) !
! -------------------------------------------------------------------
EnvVarName = 'QUERY_STRING'
junk# = GetEnvironmentVar(EnvVarName,SELF.CGI_QueryString,VarLen)
CASE CLIP(SELF.CGI_RequestMethod)
OF 'POST'
!- Load all POSTed data
EnvVarName = 'CONTENT_LENGTH'
junk# = GetEnvironmentVar(EnvVarName,SELF.CGI_ContentLength,VarLen)
ContentLength = SELF.CGI_ContentLength !- Convert to number
if ContentLength > 64000 then ContentLength = 64000 .
IF ContentLength
!junk# = ReadFile(SELF.hStdIn,SELF.CGI_FormData,ContentLength,BytesRead,OVERLAPPED_)
junk# = Lread(SELF.hStdIn,SELF.CGI_FormData,ContentLength)
SELF.GetAllCGI ! то выделяю поля
END
END!CASE
!junk# = SetFilePointer(SELF.hStdOut,ZERO_DIST_TO_MOVE,ZeroPointer,FILE_BEGIN)
! SELF.HeaderOut !- Begin the page
cCGI.GetAllCGI PROCEDURE
LastAmpersand LONG,AUTO
LastEqual LONG,AUTO
StrPos LONG,AUTO
OutPos LONG,AUTO
ContentLength LONG,AUTO
CODE
ContentLength = SELF.CGI_ContentLength
LastAmpersand = 1
LastEqual = 0
!- Loads all POST data into Tuple Q
FREE(SELF.TupleQ)
LOOP
LastEqual = INSTRING('=',CLIP(SELF.CGI_FormData),1,LastAmpersand)
IF NOT LastEqual
BREAK
END
IF LastAmpersand = 1
LastAmpersand = 0
END
SELF.TupleQ.Key = SELF.CGI_FormData[(LastAmpersand+1):(LastEqual-1)]
LastAmpersand = INSTRING('&',CLIP(SELF.CGI_FormData),1,LastEqual)
IF NOT LastAmpersand
LastAmpersand=SELF.CGI_ContentLength + 1
END
StrPos=LastEqual+1
OutPos=1
Clear(SELF.TupleQ.Value)
LOOP
If StrPos>LastAmperSand-1
SELF.TupleQ.Value[OutPos]='<0>'
BREAK
END
CASE SELF.CGI_FormData[StrPos]
OF '+'
SELF.TupleQ.Value[OutPos] = ' '
StrPos+=1
OF '%'
SELF.TupleQ.Value[OutPos] = CHR( |
Instring(SELF.CGI_FormData[StrPos+1],'0123456789ABCDEF',1,1)*16 + |
Instring(SELF.CGI_FormData[StrPos+2],'0123456789ABCDEF',1,1) - 17 )
StrPos+=3
ELSE
SELF.TupleQ.Value[OutPos] = SELF.CGI_FormData[StrPos]
StrPos+=1
END
OutPos+=1
END
ADD(SELF.TupleQ)
IF LastAmpersand>LEN(CLIP(SELF.CGI_FormData)) THEN BREAK.
END!LOOP
cCGI.GetValue FUNCTION(STRING MyValue)
CODE
!- Find a value in the global queue and return it
SORT(SELF.TupleQ, +SELF.TupleQ.Key)
SELF.TupleQ.Key = CLIP(MyValue)
GET(SELF.TupleQ, SELF.TupleQ.Key)
IF ERRORCODE()
RETURN('')
ELSE
RETURN(SELF.TupleQ.Value)
END
cCGI.HTMLOut PROCEDURE(MyOut) !- Output a line to the HTML file
MyCString CSTRING(255),AUTO
FILE_END EQUATE(2)
CODE
MyCString = MyOut
MyCString = CLIP(MyCString) & '<10>'
!puts(MyCString)
!- PWS for Win95 code, does not work yet
!junk# = WriteFile(SELF.hStdOut,MyCString,LEN(MyCString),lBytesWritten)
!- Original WinNT code
!junk# = WriteFile(SELF.hStdOut,MyCString,LEN(MyCString),lBytesWritten,OVERLAPPED_)
junk# = Lwrite(SELF.hStdOut,MyCString,LEN(MyCString))
cCGI.ErrorOut PROCEDURE(<STRING MyError>) !- Abandon everything and report error
TheError STRING(255)
TheErrorCode LONG
StdOut LONG
CODE
!- Reset the WriteFile() pointer to start over and report the error
StdOut = SELF.hStdOut
!junk# = SetFilePointer(SELF.hStdOut,ZERO_DIST_TO_MOVE,ZeroPointer,FILE_BEGIN)
!junk# = SetFilePointer(StdOut,ZERO_DIST_TO_MOVE,ZeroPointer,FILE_BEGIN)
TheError = ERROR()
TheErrorCode = ERRORCODE()
!SELF.HTMLOut('Content-type: text/html')
!SELF.HTMLOut('')
!SELF.HTMLOut('<<HTML><<HEAD>')
!SELF.HTMLOut('<</HEAD><<BODY>')
SELF.HTMLOut('<<h1>Error - ' & SELF.GetValue('Executable Path') & '<</h1>')
SELF.HTMLOut('<<PRE>' & CLIP(TheErrorCode) & ' - ' & CLIP(TheError))
IF CLIP(MyError)
SELF.HTMLOut(CLIP(MyError))
END
SELF.HTMLOut('<</PRE>Date: ' & FORMAT(TODAY(), @d2) & ' Time: ' & FORMAT(CLOCK(),@t4))
!SELF.HTMLOut('<</BODY><</HTML>')
junk# = SetEndOfFile(SELF.HStdOut)
HALT !- Terminate the program
cCGI.TableHeader PROCEDURE(STRING MyHeader) !- Output HTML table header
HeaderQ QUEUE, PRE(HQ)
Head STRING(40)
END
CODE
FREE(HeaderQ)
!- Find header item
CurrentChar# = 0
LastChar# = 1
LOOP
Currentchar# += 1
IF CurrentChar# >= LEN(CLIP(MyHeader)) THEN BREAK.
IF SUB(CLIP(MyHeader), CurrentChar#, 1) = '|'
HQ:Head = MyHeader[LastChar#:(CurrentChar#-1)]
ADD(HeaderQ)
LastChar# = (CurrentChar#+1)
END
END!LOOP
HQ:Head = MyHeader[LastChar#:CurrentChar#] !- Last header...
ADD(HeaderQ)
!- Output HTML
!- Netscape Table Header
IF SELF.TableCenter
SELF.HTMLOut('<<i><<CENTER><<TABLE BORDER='&SELF.TableBorder& ' WIDTH=' &SELF.TableWidth& '%%><<tr>')
ELSE
SELF.HTMLOut('<<i><<TABLE BORDER=' &SELF.TableBorder& ' WIDTH=' &SELF.TableWidth&'%%><<tr>')
END
LOOP CurrentHeader# = 1 to RECORDS(HeaderQ)
GET(HeaderQ, CurrentHeader#)
SELF.HTMLOut('<<th>'&CLIP(HQ:Head)&'<</th>')
END!LOOP
SELF.HTMLOut('<</tr><</i>')
cCGI.TableItem PROCEDURE(STRING MyItems) !- Output table row
ItemQ QUEUE, PRE(IQ)
Item STRING(255)
END
CODE
FREE(ItemQ)
!- Find header item
CurrentChar# = 0
LastChar# = 1
LOOP
Currentchar# += 1
IF CurrentChar# >= LEN(CLIP(MyItems)) THEN BREAK.
IF SUB(CLIP(MyItems), CurrentChar#, 1) = '|'
IQ:Item = MyItems[LastChar#:(CurrentChar#-1)]
ADD(ItemQ)
LastChar# = (CurrentChar#+1)
END
END!LOOP
IQ:Item = MyItems[LastChar#:CurrentChar#] !- Last item...
ADD(ItemQ)
IF SELF.TableRowAlign = _Left
Align" = '<<p align=left>'
ELSIF SELF.TableRowAlign = _Right
Align" = '<<p align=right>'
ELSIF SELF.TableRowAlign = _Center
Align" = '<<p align=center>'
ELSE
Align" = ''
END
SELF.HTMLOut('<<tr BORDER=' &SELF.TableBorder& '>')
LOOP CurrentItem# = 1 TO RECORDS(ItemQ)
GET(ItemQ, CurrentItem#)
SELF.HTMLOut('<<td>'&Align"&CLIP(IQ:Item)&'<</td>')
END!LOOP
SELF.HTMLOut('<</tr>')
cCGI.TableFooter PROCEDURE !- Output table end
CODE
IF SELF.TableCenter
SELF.HTMLOut('<</TABLE><</CENTER><<p>')
ELSE
SELF.HTMLOut('<</TABLE><<p>')
END
cCGI.TableSet PROCEDURE(BYTE Center, BYTE Border, BYTE RowAlign, BYTE Width) !- Reset table settings
CODE
IF Center = _DEFAULT
SELF.TableCenter = SELF._DefTableCenter
ELSE
SELF.TableCenter = Center
END
IF Border = _DEFAULT
SELF.TableBorder = SELF._DefTableBorder
ELSE
SELF.TableBorder = Border
END
IF RowAlign = _DEFAULT
SELF.TableRowAlign = SELF._DefTableRowAlign
ELSE
SELF.TableRowAlign = RowAlign
END
IF Width = _DEFAULT
SELF.TableWidth = SELF._DefTableWidth
ELSE
SELF.TableWidth = Width
END
cCGI.GetTextArea PROCEDURE
CODE
cCGI.Kill PROCEDURE
CODE
SELF.FooterOut()
DISPOSE(SELF.TupleQ)
cCGI.HeaderOut PROCEDURE !- Virtual procedure
CODE
!
! Я удалил это предложения - попытка работать с Фреймами
!
! SELF.HTMLOut('<<HTML><<HEAD>') !- Generate Default HTML
cCGI.FooterOut PROCEDURE !- Virtual procedure
CODE
!
! Я удалил это предложения - попытка работать с Фреймами
!
! SELF.HTMLOut('<</BODY><</HTML>')
!--------------------------------------------------------------------------------------------------
cCGI.GetDskInfo PROCEDURE(*string s1,*string s2,*string s3)
s01 cstring(64)
s02 cstring(64)
s03 cstring(64)
n01 ulong
n02 ulong
n03 ulong
n04 ulong
n05 ulong
Code
s01 = s1
s01 = clip(s01) & '<0>'
s02 = ''
s03 = ''
n01 = 255
n02 = 0
n03 = 0
n04 = 0
n05 = 255
n# = GetVolumeInformationA(S01,S02,N01,N02,N03,N04,S03,N05)
s2 = s02
s3 = s03
!--------------------------------------------------------------------------------------------------
cCGI.GetDskFree PROCEDURE(*string s1,*ulong SectPerClast,*ulong BytesPerSect,*ulong NumbFreeClust,*ulong AllNumbOfClust)
s01 cstring(64)
n01 ulong
n02 ulong
n03 ulong
n04 ulong
Code
s01 = s1
n01 = SectPerClast
n02 = BytesPerSect
n03 = NumbFreeClust
n04 = AllNumbOfClust
s01 = clip(s01) & '<0>'
junk# = GetDiskFreeSpaceA(s01,n01,n02,n03,n04)
SectPerClast = n01
BytesPerSect = n02
NumbFreeClust = n03
AllNumbOfClust = n04
!--------------------------------------------------------------------------------------------------
cCGI.GetDskName FUNCTION(STRING z1) !- Returns form data value
s11 cstring(6)
n1 byte
Code
s11 = z1
s11 = clip(s11) & '<0>'
n1 = GetDriveType(s11)
return(n1)
!--------------------------------------------------------------------------------------------------
cCGI.GetPcName Function
pcname cstring(64),AUTO
pcn ulong
code
junk# = GetComputerName(pcname,pcn)
return(pcname)
!----------------------------------------------------------------------------------------------------
cCGI.GetUserName Function
usname cstring(64),AUTO
usn ulong
code
junk# = GetUserNameA(usname,usn)
Return(Usname)
!--------------------------------------------------------------------------------------------------
!----------------------------------------------------------------------------------------
cCGI.PostaData Procedure(string pstserv, string pstexe, *string pstarea, *string pTextBuf)
!----------------------------------------------------------------------------------------
! InternetOpen Сессия
! InternetConnect Коннект
! HttpOpenRequest Запрос
! HttpSendRequest Послать
! InternetReadFile Получить
! InternetCloseunsigned Закрыть запрос
! InternetCloseunsigned Закрыть коннект
! InternetCloseunsigned Закрыть сессию
!----------------------------------------------------------------------------------------
UserAgent cstring('Mozilla/4.0 (compatible; MSIE 6.0b; Windows NT 5.0; .NET CLR 1.0.2914)')
ProxyName CSTRING(1000)
OpenType ulong
bufferlen equate(528001)
HTTPbuffer cstring(bufferlen)
Headerlen ulong
Headerbuf cstring(250),AUTO ! Content-Type: application/x-www-form-urlencoded
Postlen ulong
postbuf cstring(64000),AUTO ! name=John+Doe&userid=hithere&other=P%26Q
bytesread ulong
! Open Flags
INTERNET_OPEN_TYPE_PRECONFIG EQUATE(0) !- use registry configuration
INTERNET_OPEN_TYPE_DIRECT EQUATE(1) !- direct to net
INTERNET_OPEN_TYPE_PROXY EQUATE(3) !- via named proxy
!OpenURL dwFlags
INTERNET_FLAG_NO_CACHE_WRITE EQUATE(04000000H) ! Does not add the returned entity to the cache.
INTERNET_FLAG_RELOAD equate(80000000H) ! Forces a download of the requested file, object,
! or directory listing from the origin server, not from the cache.
INTERNET_FLAG_PRAGMA_NOCACHE equate(00000100H) ! Forces the request to be resolved by the origin server,
! even if a cached copy exists on the proxy.
NoCaching equate(84000100H) ! all of the above
INTERNET_DEFAULT_HTTP_PORT equate(00000050H) ! Номер TCP/IP порта к которому мы собираемся подсоединиться
INTERNET_SERVICE_HTTP equate(00000003H) ! Тип сервиса - FTP, HTTP или Gopher
ZERO ulong
hsession unsigned
hconnect unsigned
hrequest unsigned
hReadFile unsigned
hsend unsigned
dwFlags ulong
dwContext ulong
postserv cstring(250),AUTO
postexe cstring(250),AUTO
pTextBufLen long
Pageptr long
ReturnCode long
usid cstring(20)
psw cstring(20)
postv cstring(20)
acc ulong
version cstring(20)
reff cstring(20)
s0 long
code
postv = 'POST'
Headerbuf = 'Content-Type: application/x-www-form-urlencoded' & '<0>'
headerlen = len(Headerbuf)
postserv = clip(pstserv) & '<0>'
postexe = clip(pstexe) & '<0>'
! loop s0 = 1 to 8000
! if pstarea[s0] = ' ' then break .
! postbuf[s0] = pstarea[s0]
! end
! postbuf[s0] = '<0>'
postbuf = CLIP(PSTAREA) & '<0>'
postlen = len(postbuf)
pTextBufLen = len(pTextBuf)
OpenType = INTERNET_OPEN_TYPE_PRECONFIG
ReturnCode = 0
version = 'HTTP/1.1<0>'
reff = 'http://s775/rocom.exe<0>'
usid = 'anonymous<0>'
psw = '<0>'
hsession = InternetOpen(UserAgent,OpenType,ProxyName,zero,zero)
if hsession = 0 then
ReturnCode = 1 !* Error * Internet Open error
else
dwFlags = NoCaching
hconnect = InternetConnect(hsession,postserv,INTERNET_DEFAULT_HTTP_PORT, usid, psw, INTERNET_SERVICE_HTTP, dwFlags, dwContext)
if hconnect = 0 then
ReturnCode = 2 !* Error * Internet Connect error
else
hrequest = HttpOpenRequest(hConnect, postv, postexe, version, reff, 0, dwFlags, dwContext);
if hrequest = 0 then
ReturnCode = 3 !* Error * Internet Request error
else
hsend = HttpSendRequest(hRequest, headerbuf, headerlen, postbuf, postlen)
if hsend = false then
ReturnCode = 4 !* Error * Internet send error
else
Pageptr = 1
loop
hReadFile = InternetReadFile(hRequest,HTTPbuffer,bufferlen-1,bytesread)
if hReadFile = true and bytesread = 0 then break.
if bytesread > 0 then
if Pageptr + bytesread > pTextBuflen then
Returncode = 5 ! * Error * Buffer size exceeded
break
end
pTextBuf = pTextBuf[1:Pageptr] & HTTPbuffer[1:bytesread] ! + first byte always _
Pageptr += bytesread
end
end
end
end
end
end
internetclosehandle(hrequest)
internetclosehandle(hconnect)
internetclosehandle(hsession)
return(ReturnCode)
!----------------------------------------------------------------------------------------
cCGI.GetAFileFTP Procedure(string srvfile, string locfile, string srvlogin, string srvpsw, string srvurl) ! Ftp Get File
!----------------------------------------------------------------------------------------
! InternetOpen Сессия
! InternetConnect Коннект
! FTPGetFile Получить файл
! InternetCloseHandle Закрыть коннект
! InternetCloseHandle Закрыть сессию
!----------------------------------------------------------------------------------------
UserAgent cstring('Windiws 7 FTP agent')
ProxyName CSTRING(1000)
OpenType ulong
! Open Flags
INTERNET_OPEN_TYPE_PRECONFIG EQUATE(0) !- use registry configuration
INTERNET_OPEN_TYPE_DIRECT EQUATE(1) !- direct to net
INTERNET_OPEN_TYPE_PROXY EQUATE(3) !- via named proxy
!OpenURL dwFlags
INTERNET_FLAG_NO_CACHE_WRITE EQUATE(04000000H) ! Does not add the returned entity to the cache.
INTERNET_FLAG_RELOAD equate(80000000H) ! Forces a download of the requested file, object,
! or directory listing from the origin server, not from the cache.
INTERNET_FLAG_PRAGMA_NOCACHE equate(00000100H) ! Forces the request to be resolved by the origin server,
! even if a cached copy exists on the proxy.
NoCaching equate(84000100H) ! all of the above
INTERNET_DEFAULT_FTP_PORT equate(00000015H) ! Номер TCP/IP порта к которому мы собираемся подсоединиться
INTERNET_SERVICE_FTP equate(00000001H) ! Тип сервиса - FTP, HTTP или Gopher
INTERNET_FLAG_PASSIVE EQUATE(08000000h) ! Тип соединения - пассивный 0 - активный
ZERO ulong
hsession unsigned
hconnect unsigned
hrequest unsigned
dwFlags ulong
dwContext ulong
ftp_serv cstring(250),AUTO
file_srv cstring(250),AUTO
file_loc cstring(250),AUTO
pTextBufLen long
Pageptr long
ReturnCode long
usid cstring(32)
psw cstring(32)
postv cstring(32)
acc ulong
version cstring(32)
reff cstring(32)
code
ftp_serv = clip(srvurl) & '<0>'
file_srv = clip(srvfile) & '<0>'
file_loc = clip(locfile) & '<0>'
OpenType = INTERNET_OPEN_TYPE_PRECONFIG
ReturnCode = 0
version = 'HTTP/1.1<0>'
reff = 'http://s775/rocom.exe<0>'
usid = clip(srvlogin) & '<0>'
psw = clip(srvpsw) & '<0>'
hsession = InternetOpen(UserAgent,OpenType,ProxyName,zero,zero)
if hsession = 0 then
ReturnCode = 1 !* Error * Internet Open error
else
dwFlags = INTERNET_FLAG_PASSIVE
hconnect = InternetConnect(hsession,ftp_serv,INTERNET_DEFAULT_FTP_PORT, usid, psw, INTERNET_SERVICE_FTP, dwFlags, dwContext)
if hconnect = 0 then
ReturnCode = 2 !* Error * Internet Connect error
else
hrequest = FtpGetFile( hconnect, file_srv, file_loc, False, 0, 2, 0)
if hrequest = false then
ReturnCode = 3 !* Error * Internet Request error
end
end
end
internetclosehandle(hconnect)
internetclosehandle(hsession)
return(ReturnCode)
!----------------------------------------------------------------------------------------
cCGI.PutAFileFTP Procedure(string locfile, string srvfile, string srvlogin, string srvpsw, string srvurl) ! Ftp Put File
!----------------------------------------------------------------------------------------
! InternetOpen Сессия
! InternetConnect Коннект
! FTPGetFile Получить файл
! InternetCloseHandle Закрыть коннект
! InternetCloseHandle Закрыть сессию
!----------------------------------------------------------------------------------------
UserAgent cstring('Expi FTP agent')
ProxyName CSTRING(1000)
OpenType ulong
! Open Flags
INTERNET_OPEN_TYPE_PRECONFIG EQUATE(0) !- use registry configuration
INTERNET_OPEN_TYPE_DIRECT EQUATE(1) !- direct to net
INTERNET_OPEN_TYPE_PROXY EQUATE(3) !- via named proxy
!OpenURL dwFlags
INTERNET_FLAG_NO_CACHE_WRITE EQUATE(04000000H) ! Does not add the returned entity to the cache.
INTERNET_FLAG_RELOAD equate(80000000H) ! Forces a download of the requested file, object,
! or directory listing from the origin server, not from the cache.
INTERNET_FLAG_PRAGMA_NOCACHE equate(00000100H) ! Forces the request to be resolved by the origin server,
! even if a cached copy exists on the proxy.
NoCaching equate(84000100H) ! all of the above
INTERNET_DEFAULT_FTP_PORT equate(00000015H) ! Номер TCP/IP порта к которому мы собираемся подсоединиться
INTERNET_SERVICE_FTP equate(00000001H) ! Тип сервиса - FTP, HTTP или Gopher
INTERNET_FLAG_PASSIVE EQUATE(08000000h) ! Тип соединения - пассивный 0 - активный
ZERO ulong
hsession unsigned
hconnect unsigned
hrequest unsigned
dwFlags ulong
dwContext ulong
ftp_serv cstring(250),AUTO
file_srv cstring(250),AUTO
file_loc cstring(250),AUTO
pTextBufLen long
Pageptr long
ReturnCode long
usid cstring(32)
psw cstring(32)
postv cstring(32)
acc ulong
version cstring(32)
reff cstring(32)
code
ftp_serv = clip(srvurl) & '<0>'
file_srv = clip(srvfile) & '<0>'
file_loc = clip(locfile) & '<0>'
OpenType = INTERNET_OPEN_TYPE_PRECONFIG
ReturnCode = 0
version = 'HTTP/1.1<0>'
usid = clip(srvlogin) & '<0>'
psw = clip(srvpsw) & '<0>'
hsession = InternetOpen(UserAgent,OpenType,ProxyName,zero,zero)
if hsession = 0 then
ReturnCode = 1 !* Error * Internet Open error
else
dwFlags = INTERNET_FLAG_PASSIVE
hconnect = InternetConnect(hsession,ftp_serv,INTERNET_DEFAULT_FTP_PORT, usid, psw, INTERNET_SERVICE_FTP, dwFlags, dwContext)
if hconnect = 0 then
ReturnCode = 2 !* Error * Internet Connect error
else
hrequest = FtpPutFile( hconnect, file_loc, file_srv, 2, 0)
if hrequest = false then
ReturnCode = 3 !* Error * Internet Request error
end
end
end
internetclosehandle(hconnect)
internetclosehandle(hsession)
return(ReturnCode)
!----------------------------------------------------------------------------------------
cCGI.CreateDirFTP Procedure(string srvdir, string srvlogin, string srvpsw, string srvurl) ! Create FTP derectory
!----------------------------------------------------------------------------------------
! InternetOpen Сессия
! InternetConnect Коннект
! FTPGetFile Получить файл
! InternetCloseHandle Закрыть коннект
! InternetCloseHandle Закрыть сессию
!----------------------------------------------------------------------------------------
UserAgent cstring('Windiws 7 FTP agent')
ProxyName CSTRING(1000)
OpenType ulong
! Open Flags
INTERNET_OPEN_TYPE_PRECONFIG EQUATE(0) !- use registry configuration
INTERNET_OPEN_TYPE_DIRECT EQUATE(1) !- direct to net
INTERNET_OPEN_TYPE_PROXY EQUATE(3) !- via named proxy
!OpenURL dwFlags
INTERNET_FLAG_NO_CACHE_WRITE EQUATE(04000000H) ! Does not add the returned entity to the cache.
INTERNET_FLAG_RELOAD equate(80000000H) ! Forces a download of the requested file, object,
! or directory listing from the origin server, not from the cache.
INTERNET_FLAG_PRAGMA_NOCACHE equate(00000100H) ! Forces the request to be resolved by the origin server,
! even if a cached copy exists on the proxy.
NoCaching equate(84000100H) ! all of the above
INTERNET_DEFAULT_FTP_PORT equate(00000015H) ! Номер TCP/IP порта к которому мы собираемся подсоединиться
INTERNET_SERVICE_FTP equate(00000001H) ! Тип сервиса - FTP, HTTP или Gopher
INTERNET_FLAG_PASSIVE EQUATE(08000000H) ! Тип соединения - пассивный 0 - активный
ZERO ulong
hsession unsigned
hconnect unsigned
hrequest unsigned
dwFlags ulong
dwContext ulong
ftp_serv cstring(250),AUTO
Ftp_dir cstring(250),AUTO
pTextBufLen long
Pageptr long
ReturnCode long
usid cstring(32)
psw cstring(32)
postv cstring(32)
acc ulong
version cstring(32)
reff cstring(32)
code
ftp_serv = clip(srvurl) & '<0>'
FTP_dir = clip(srvdir) & '<0>'
OpenType = INTERNET_OPEN_TYPE_PRECONFIG
ReturnCode = 0
version = 'HTTP/1.1<0>'
usid = clip(srvlogin) & '<0>'
psw = clip(srvpsw) & '<0>'
hsession = InternetOpen(UserAgent,OpenType,ProxyName,zero,zero)
if hsession = 0 then
ReturnCode = 1 !* Error * Internet Open error
else
dwFlags = 0
hconnect = InternetConnect(hsession,ftp_serv,INTERNET_DEFAULT_FTP_PORT, usid, psw, INTERNET_SERVICE_FTP, dwFlags, dwContext)
if hconnect = 0 then
ReturnCode = 2 !* Error * Internet Connect error
else
hrequest = FtpCreateDirectory(hconnect,FTP_dir)
if hrequest = false then
ReturnCode = 3 !* Error * Internet Request error
end
end
end
internetclosehandle(hconnect)
internetclosehandle(hsession)
return(ReturnCode)
!----------------------------------------------------------------------------------------
cCGI.DeleteDirFTP Procedure(string srvdir, string srvlogin, string srvpsw, string srvurl) ! Delete FTP derectory
!----------------------------------------------------------------------------------------
! InternetOpen Сессия
! InternetConnect Коннект
! FTPGetFile Получить файл
! InternetCloseHandle Закрыть коннект
! InternetCloseHandle Закрыть сессию
!----------------------------------------------------------------------------------------
UserAgent cstring('Windiws 7 FTP agent')
ProxyName CSTRING(1000)
OpenType ulong
! Open Flags
INTERNET_OPEN_TYPE_PRECONFIG EQUATE(0) !- use registry configuration
INTERNET_OPEN_TYPE_DIRECT EQUATE(1) !- direct to net
INTERNET_OPEN_TYPE_PROXY EQUATE(3) !- via named proxy
!OpenURL dwFlags
INTERNET_FLAG_NO_CACHE_WRITE EQUATE(04000000H) ! Does not add the returned entity to the cache.
INTERNET_FLAG_RELOAD equate(80000000H) ! Forces a download of the requested file, object,
! or directory listing from the origin server, not from the cache.
INTERNET_FLAG_PRAGMA_NOCACHE equate(00000100H) ! Forces the request to be resolved by the origin server,
! even if a cached copy exists on the proxy.
NoCaching equate(84000100H) ! all of the above
INTERNET_DEFAULT_FTP_PORT equate(00000015H) ! Номер TCP/IP порта к которому мы собираемся подсоединиться
INTERNET_SERVICE_FTP equate(00000001H) ! Тип сервиса - FTP, HTTP или Gopher
INTERNET_FLAG_PASSIVE EQUATE(08000000H) ! Тип соединения - пассивный 0 - активный
ZERO ulong
hsession unsigned
hconnect unsigned
hrequest unsigned
dwFlags ulong
dwContext ulong
ftp_serv cstring(250),AUTO
Ftp_dir cstring(250),AUTO
pTextBufLen long
Pageptr long
ReturnCode long
usid cstring(32)
psw cstring(32)
postv cstring(32)
acc ulong
version cstring(32)
reff cstring(32)
code
ftp_serv = clip(srvurl) & '<0>'
FTP_dir = clip(srvdir) & '<0>'
OpenType = INTERNET_OPEN_TYPE_PRECONFIG
ReturnCode = 0
version = 'HTTP/1.1<0>'
usid = clip(srvlogin) & '<0>'
psw = clip(srvpsw) & '<0>'
hsession = InternetOpen(UserAgent,OpenType,ProxyName,zero,zero)
if hsession = 0 then
ReturnCode = 1 !* Error * Internet Open error
else
dwFlags = 0
hconnect = InternetConnect(hsession,ftp_serv,INTERNET_DEFAULT_FTP_PORT, usid, psw, INTERNET_SERVICE_FTP, dwFlags, dwContext)
if hconnect = 0 then
ReturnCode = 2 !* Error * Internet Connect error
else
hrequest = FtpRemoveDirectory(hconnect,FTP_dir)
if hrequest = false then
ReturnCode = 3 !* Error * Internet Request error
end
end
end
internetclosehandle(hconnect)
internetclosehandle(hsession)
return(ReturnCode)
!----------------------------------------------------------------------------------------
cCGI.DeleteFileFTP Procedure(string srvfile, string srvlogin, string srvpsw, string srvurl) ! Delete Srv file
!----------------------------------------------------------------------------------------
! InternetOpen Сессия
! InternetConnect Коннект
! FTPGetFile Получить файл
! InternetCloseHandle Закрыть коннект
! InternetCloseHandle Закрыть сессию
!----------------------------------------------------------------------------------------
UserAgent cstring('Windiws 7 FTP agent')
ProxyName CSTRING(1000)
OpenType ulong
! Open Flags
INTERNET_OPEN_TYPE_PRECONFIG EQUATE(0) !- use registry configuration
INTERNET_OPEN_TYPE_DIRECT EQUATE(1) !- direct to net
INTERNET_OPEN_TYPE_PROXY EQUATE(3) !- via named proxy
!OpenURL dwFlags
INTERNET_FLAG_NO_CACHE_WRITE EQUATE(04000000H) ! Does not add the returned entity to the cache.
INTERNET_FLAG_RELOAD equate(80000000H) ! Forces a download of the requested file, object,
! or directory listing from the origin server, not from the cache.
INTERNET_FLAG_PRAGMA_NOCACHE equate(00000100H) ! Forces the request to be resolved by the origin server,
! even if a cached copy exists on the proxy.
NoCaching equate(84000100H) ! all of the above
INTERNET_DEFAULT_FTP_PORT equate(00000015H) ! Номер TCP/IP порта к которому мы собираемся подсоединиться
INTERNET_SERVICE_FTP equate(00000001H) ! Тип сервиса - FTP, HTTP или Gopher
INTERNET_FLAG_PASSIVE EQUATE(08000000H) ! Тип соединения - пассивный 0 - активный
ZERO ulong
hsession unsigned
hconnect unsigned
hrequest unsigned
dwFlags ulong
dwContext ulong
ftp_serv cstring(250),AUTO
Ftp_file cstring(250),AUTO
pTextBufLen long
Pageptr long
ReturnCode long
usid cstring(32)
psw cstring(32)
postv cstring(32)
acc ulong
version cstring(32)
reff cstring(32)
code
ftp_serv = clip(srvurl) & '<0>'
FTP_file = clip(srvfile) & '<0>'
OpenType = INTERNET_OPEN_TYPE_PRECONFIG
ReturnCode = 0
version = 'HTTP/1.1<0>'
usid = clip(srvlogin) & '<0>'
psw = clip(srvpsw) & '<0>'
hsession = InternetOpen(UserAgent,OpenType,ProxyName,zero,zero)
if hsession = 0 then
ReturnCode = 1 !* Error * Internet Open error
else
dwFlags = 0
hconnect = InternetConnect(hsession,ftp_serv,INTERNET_DEFAULT_FTP_PORT, usid, psw, INTERNET_SERVICE_FTP, dwFlags, dwContext)
if hconnect = 0 then
ReturnCode = 2 !* Error * Internet Connect error
else
hrequest = FtpDeleteFile(hconnect,FTP_file)
if hrequest = false then
ReturnCode = 3 !* Error * Internet Request error
end
end
end
internetclosehandle(hconnect)
internetclosehandle(hsession)
return(ReturnCode)
!----------------------------------------------------------------------------------------
cCGI.RenameFileFTP Procedure(string srvfile, string srvnewfile, string srvlogin, string srvpsw, string srvurl) ! Rename Srv file
!----------------------------------------------------------------------------------------
! InternetOpen Сессия
! InternetConnect Коннект
! FTPGetFile Получить файл
! InternetCloseHandle Закрыть коннект
! InternetCloseHandle Закрыть сессию
!----------------------------------------------------------------------------------------
UserAgent cstring('Windiws 7 FTP agent')
ProxyName CSTRING(1000)
OpenType ulong
! Open Flags
INTERNET_OPEN_TYPE_PRECONFIG EQUATE(0) !- use registry configuration
INTERNET_OPEN_TYPE_DIRECT EQUATE(1) !- direct to net
INTERNET_OPEN_TYPE_PROXY EQUATE(3) !- via named proxy
!OpenURL dwFlags
INTERNET_FLAG_NO_CACHE_WRITE EQUATE(04000000H) ! Does not add the returned entity to the cache.
INTERNET_FLAG_RELOAD equate(80000000H) ! Forces a download of the requested file, object,
! or directory listing from the origin server, not from the cache.
INTERNET_FLAG_PRAGMA_NOCACHE equate(00000100H) ! Forces the request to be resolved by the origin server,
! even if a cached copy exists on the proxy.
NoCaching equate(84000100H) ! all of the above
INTERNET_DEFAULT_FTP_PORT equate(00000015H) ! Номер TCP/IP порта к которому мы собираемся подсоединиться
INTERNET_SERVICE_FTP equate(00000001H) ! Тип сервиса - FTP, HTTP или Gopher
INTERNET_FLAG_PASSIVE EQUATE(08000000H) ! Тип соединения - пассивный 0 - активный
ZERO ulong
hsession unsigned
hconnect unsigned
hrequest unsigned
dwFlags ulong
dwContext ulong
ftp_serv cstring(250),AUTO
Ftp_file cstring(250),AUTO
Ftp_newfile cstring(250),AUTO
pTextBufLen long
Pageptr long
ReturnCode long
usid cstring(32)
psw cstring(32)
postv cstring(32)
acc ulong
version cstring(32)
reff cstring(32)
code
ftp_serv = clip(srvurl) & '<0>'
FTP_file = clip(srvfile) & '<0>'
FTP_newfile = clip(srvnewfile) & '<0>'
OpenType = INTERNET_OPEN_TYPE_PRECONFIG
ReturnCode = 0
version = 'HTTP/1.1<0>'
usid = clip(srvlogin) & '<0>'
psw = clip(srvpsw) & '<0>'
hsession = InternetOpen(UserAgent,OpenType,ProxyName,zero,zero)
if hsession = 0 then
ReturnCode = 1 !* Error * Internet Open error
else
dwFlags = 0
hconnect = InternetConnect(hsession,ftp_serv,INTERNET_DEFAULT_FTP_PORT, usid, psw, INTERNET_SERVICE_FTP, dwFlags, dwContext)
if hconnect = 0 then
ReturnCode = 2 !* Error * Internet Connect error
else
hrequest = FtpRenameFile(hconnect,FTP_file,Ftp_newfile)
if hrequest = false then
ReturnCode = 3 !* Error * Internet Request error
end
end
end
internetclosehandle(hconnect)
internetclosehandle(hsession)
return(ReturnCode)