\ Forth Internet Scripter

' ANSI>OEM TO ANSI><OEM
S" INCLUDE\FACIL.F"  INCLUDED
S" EXT\FM.F"         INCLUDED
S" EXT\MUTEX.F"      INCLUDED
S" SAMPLES\DATE.TXT" INCLUDED
S" SAMPLES\SOCKETS.TXT" INCLUDED

: \S SOURCE-ID FILE-SIZE THROW SOURCE-ID REPOSITION-FILE THROW ;
\ ----------------------------------------------------
WINAPI: GetEnvironmentVariableA KERNEL32.DLL
( LPCTSTR  lpName,  // address of environment variable name 
  LPTSTR  lpBuffer, // address of buffer for variable value 
  DWORD  nSize 	    // size of buffer, in characters 
)
: .'
  ?COMP
  ['] _CLITERAL-CODE COMPILE,
  [CHAR] ' PARSE DUP C,
  HERE SWAP DUP ALLOT MOVE 0 C,
  ['] (.") COMPILE,
; IMMEDIATE
VARIABLE Build
VARIABLE BuildN

: HTML
  ." Content-Type: text/html; charset=windows-1251" 10 EMIT CR
  .' <!doctype html public "-//IETF//DTD HTML//EN">' CR
  ." <html>" CR
  .' <META HTTP-EQUIV="Pragma" CONTENT="no-cache">' CR
;
: HTML
  ." <p><font SIZE=-2><a href=" [CHAR] " EMIT
  ." mailto:andrey@cherezov.koenig.su" [CHAR] " EMIT
  ." > Forth Internet Scripter + DW v1.2 ("
  Build @ . ."  - " BuildN @ U. ." )</a></font></p>" CR
  ." </html>" CR
;
: 
  ." <p>"
;
: 
  ." <b>"
;
: /
  ." </b>"
;
: Br
  ." <br>"
;
: 
   ." : "
  ." fis.exe?script='__'&[_=_&] "
  ."        'action='  'form'  HTML: "
  ."          fis.exe"
  ."    . Fis.exe    "
  ."     ,     "
  ." -   ,     . "
  ." -         . "
;
:  ( c-addr1 u1 c-addr2 u2 -- )
    2SWAP TYPE / Br TYPE
;
\ ----------------------------------------------------
: 
  1000 HERE S" QUERY_STRING" DROP GetEnvironmentVariableA
  ?DUP IF
         DUP #TIB ! ALLOCATE THROW TO TIB >IN 0!
         HERE TIB #TIB @ MOVE TRUE
       ELSE GetCommandLineA ASCIIZ> NIP 5 >  THEN
;
: S, ( addr u -- )
  HERE SWAP DUP ALLOT MOVE
;
: +>BL ( addr u -- )
  0 ?DO DUP C@ [CHAR] + = IF BL OVER C! THEN 1+ LOOP DROP
;
: % ( addr u -- addr2 u2 )
  HEX
  HERE >R >R
  BEGIN
    R@ 0 >
  WHILE
    DUP C@ [CHAR] % =
    IF R> 3 - >R
       3 + DUP 2 - 2 0 0 2SWAP >NUMBER 2DROP D>S C,
    ELSE R> 1- >R
       DUP C@ C, 1+
    THEN
  REPEAT DROP R> DROP

  R> HERE OVER - OVER DP !
  DECIMAL 2DUP +>BL
  DUP >R
  DUP ALLOCATE THROW DUP >R SWAP MOVE
  R> R>
;
: ~>=
\  WebSite    IIS  "="  "~"
  #TIB @ 0 ?DO TIB I + C@ [CHAR] ~ =
               IF [CHAR] = TIB I + C! THEN
           LOOP
;
0 VALUE ListP
: ListP+ ( addr u -- )
  OVER C@ [CHAR] ^ <>
  IF S"  "  FALSE R> DROP EXIT THEN
  1- SWAP 1+ SWAP 0 0 2SWAP >NUMBER 2DROP D>S
  HERE SWAP ListP , , TO ListP
  [CHAR] & PARSE
;
: TmpListDo ( xt -- )
  ListP
  BEGIN
    ?DUP
  WHILE
    ( xt addr )
    OVER OVER CELL+ @ SWAP EXECUTE
    @
  REPEAT DROP
;
: InTmpList? ( node-oid -- flag)
  >R
  ListP
  BEGIN
    ?DUP
  WHILE
    ( flag addr )
    DUP CELL+ @ R@ = IF DROP R> DROP TRUE EXIT THEN
    @
  REPEAT R> DROP FALSE
;
: INCLUDED/CREATE ( c-addr u -- )
  2DUP R/O OPEN-FILE
  IF DROP R/W CREATE-FILE THROW CLOSE-FILE THROW
  ELSE >R 2DROP R> INCLUDE-FILE THEN
;
: OPEN/CREATE-FILE ( c-addr u fam -- fileid ior )
  >R 2DUP R@ OPEN-FILE
  IF DROP R> CREATE-FILE
  ELSE R> DROP >R 2DROP R> 0 THEN
;
VECT vIPaccessCheck
' TYPE TO vIPaccessCheck

: Log ( addr u -- )
  H-STDOUT >R
  S" dw.log" R/W OPEN/CREATE-FILE THROW TO H-STDOUT
  H-STDOUT FILE-SIZE THROW H-STDOUT REPOSITION-FILE THROW
  . SPACE . SPACE
  1000 PAD S" REMOTE_ADDR" DROP GetEnvironmentVariableA PAD SWAP 2DUP TYPE
  2DUP vIPaccessCheck ."  (" Get.Host.Name IF ." ?" 2DROP ELSE TYPE THEN ." ) "
  TYPE CR H-STDOUT CLOSE-FILE THROW
  R> TO H-STDOUT
;
: LogRequestBegin
  SOURCE Log
;
: LogRequestEnd
  S" RETURN: OK" Log
;

:  ( -- flag )
  LogRequestBegin
  ~>=
\ flag=true,     
  0 TO ListP
  BEGIN
    [CHAR] ? SKIP
    [CHAR] = PARSE ?DUP
  WHILE
    %
    2DUP FORTH-WORDLIST SEARCH-WORDLIST
    IF NIP NIP [CHAR] & PARSE % ROT EXECUTE
    ELSE ListP+ THEN
  REPEAT
;
: 
  C" ScriptMain" FIND
  IF EXECUTE 
  ELSE COUNT S" "  THEN
  LogRequestEnd
;
\ -----------------------------------------------------
0 VALUE DW-MUTEX
: Mutex
  S" DW-MUTEX" FALSE CREATE-MUTEX THROW TO DW-MUTEX
;
: Mutex
  -1 DW-MUTEX WAIT THROW DROP
;
: Mutex
  DW-MUTEX RELEASE-MUTEX THROW
;
: Mutex
  DW-MUTEX CLOSE-FILE THROW
;
\ ----------------------------------------------------
VECT ScriptMain
S" samples\.txt" INCLUDED
\ ' DataDump TO ScriptMain
' NOOP TO ScriptMain

0 VALUE MAP-OBJID
0 VALUE MAP-FILEID
: 
  1000000 S" BASE.DW" MAP-FILE THROW
  TO MAP-BASE TO MAP-OBJID TO MAP-FILEID
;
: 
  MAP-FILEID MAP-OBJID MAP-BASE UNMAP-FILE THROW
  0 TO MAP-BASE  0 TO MAP-OBJID  0 TO MAP-FILEID
;
\ ----------------------------------------------------
: 1
  ['] NOOP TO <PRE>
  SocketsStartup THROW
  
  Mutex
  HTML

  
  IF  IF  THEN
  ELSE  THEN

  HTML
  Mutex
  
  SocketsCleanup THROW
  BYE
;
: 
  ['] 1 CATCH ?DUP
  IF ." : " . ." <BR>" CR SOURCE TYPE THEN
  BYE
;
\ ----------------------------------------------------
: script
  2DUP + 0!
  2DUP R/O OPEN-FILE
  IF DROP TYPE S"   " 
  ELSE NIP NIP INCLUDE-FILE THEN
;
: NoEqualsInBrainDeadDOS (   WebSite under Win95)
  ." =NoEqualsInBrainDeadDOS"
;
\ FALSE TO ?CONSOLE
 Build !
TIME&DATE 2DROP DROP 60 * + 100 * + BuildN !

' NOOP TO ANSI><OEM
512 TO C/L '  TO <MAIN> S" dw.exe" SAVE BYE