Расширенные темплейты CGI

Программы на Clarion, шаблоны, библиотеки и пр.
Правила форума
При написании вопроса или обсуждении проблемы, не забывайте указывать версию Clarion который Вы используете.
А так же пользуйтесь спец. тегами при вставке исходников!!!
Ответить
Art
Прохожий
Сообщения: 4
Зарегистрирован: 03 Июль 2015, 4:13

Расширенные темплейты CGI

Сообщение Art » 04 Март 2016, 5:46

В продолжение темы "Как работать с Firebird' публикую темплейты для создания WEB серверных и клиентских приложений.
Я их использовал при создании распределенных систем различных типов и довольно успешно.
Сейчас они уже лежат без дела. Возможно кому-то пригодятся.

CGI.tpl

Код: Выделить всё

#TEMPLATE(CGI, 'CGI Template'),FAMILY('ABC')
#INCLUDE('CGI.TPW')
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('&copy %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

ccgi.inc

Код: Выделить всё


    !- 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.clw

Код: Выделить всё

    !- 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)

Успехов и с приветом из 4 мартв 2016. Andrew Art.

Yufil
Ветеран движения
Сообщения: 1090
Зарегистрирован: 16 Май 2006, 13:34
Контактная информация:

Расширенные темплейты CGI

Сообщение Yufil » 04 Март 2016, 12:49

Давно это было... молодость вспомнил :)

Кстати, там несколько проблем было:
- ограниченный размер буфера
- кириллица не переводилась в urlencode
- модули winapi не открывали системные файлы в некоторых случаях

Всё решено?

У меня много CGI-приложений, сейчас перевожу в разные другие...

gopstop2007
Ветеран
Сообщения: 1201
Зарегистрирован: 25 Март 2009, 21:55

Расширенные темплейты CGI

Сообщение gopstop2007 » 04 Март 2016, 14:11

Yufil писал(а):У меня много CGI-приложений, сейчас перевожу в разные другие...
В какие, если не секрет ? :)
“Есть всего 2 типа языков: те, на которые все жалуются и те, которыми никто не пользуется.” — Бьерн Страуструп

Yufil
Ветеран движения
Сообщения: 1090
Зарегистрирован: 16 Май 2006, 13:34
Контактная информация:

Расширенные темплейты CGI

Сообщение Yufil » 04 Март 2016, 15:08

Я бросил писать коммерческие приложения, у меня своя специфика (http://www.tacis-dipol.ru/index.php).
Часть старых Кларион-приложений преобразована в html/javascript, часть интегрированы в SCORM LMS (это оболочки обучающих приложений)
некоторые (системы тестирования) в python/django (пока нет спроса, поэтому приостановлено),
ещё есть гибридные flash-unity3d-приложения, там обёртка моя, а внутренности пишут дизайнеры-аниматоры.

Ответить