\ #! /usr/local/bin/pfe -q
\ FIG_reg       program to handle forms requests for joining FIG

\ This is an ANS Forth program requiring:
\      1. The File Access word set.
\      2. The word CMOVE from the String word set.
\      3. A system dependent word GETENV to get the specified
\         environment string,
\         GETENV ( str count -- str' count' )
\      4. The word STDIN to get the file ID of standard input.
\      5. The words OPEN-PIPE and CLOSE-PIPE to open and close pipes to
\         processes. (These are communicated with via the normal File access
\         words).
\      6. READ to write to Unix file descriptors (because of a problem with
\         ThisForth 94-09-12).
\      7. The word  : #!   \ ; IMMEDIATE

\  (c) Copyright 1994 Everett F. Carter.  Permission is granted by the
\  author to use this software for any application provided this
\  copyright notice is preserved.


\ rcsid: %W% %U% %G%   EFC


TRUE    CONSTANT ?DEBUG
TRUE   CONSTANT ThisForth
FALSE    CONSTANT PFE

ThisForth [IF]

\ =================== ANS File words for ThisForth =========================

\ file open modes
: R/W  S" r+" ;
: R/O  S" r"  ;
: W/O  S" w"  ;

: APPEND  S" a" ;                  \ NOT ANS, but necessary


: OPEN-FILE   fopen DUP 0= ;

: READ-LINE ( addr u fileid -- u' flag ior )
             STREAM 
             0 SWAP
             0 DO
                  next-char EOL = IF LEAVE THEN
                  next-char EOF = IF LEAVE THEN
                  get-char
                  2 PICK I + C!
                  1+
             LOOP

             UNSTREAM

             SWAP DROP TRUE 0
;

: READ-FILE ( addr u fileid -- u' flag )     \ a hack
             STREAM 
             0 SWAP
             0 DO
                  next-char EOF = IF LEAVE THEN
                  get-char
                  2 PICK I + C!
                  1+
             LOOP

             UNSTREAM

             SWAP DROP FALSE
;


: REPOSITION-FILE ( d fid -- flag )
        ROT ROT DROP 0
        fseek
;

: WRITE-FILE   ( c-addr u fileid -- ior )
	DISPLAY TYPE
        0 DISPLAY
        TRUE
;


: WRITE-LINE   ( c-addr u fileid -- ior )
	DISPLAY TYPE CR
        0 DISPLAY
        TRUE
;

: CLOSE-FILE   fclose ;

[THEN]

\ =========================================================================

ThisForth [IF]           \ ThisForth version
: OPEN-APPEND
             APPEND OPEN-FILE
;

[ELSE]
\ ANS Brute force OPEN-APPEND, depending upon what is under the hood, there may
\ be more efficient definitions
: OPEN-APPEND    R/W OPEN-FILE
                 DUP 0= IF OVER FILE-SIZE
                           0= IF 3 PICK REPOSITION-FILE DROP THEN
                        THEN
;
[THEN]


FALSE VALUE bad-status
0     VALUE seq-file
0     VALUE log-file
0     VALUE seq-no

CREATE NEW-LINE-CHARS   2 ALLOT
10 NEW-LINE-CHARS C!
\ 13 NEW-LINE-CHARS 1+ C!


0 VALUE buf-len
0 VALUE input-buffer
VARIABLE scan-ptr

ALIGN
CREATE out-buf   32 ALLOT

\ ============= A String pointer data structure =============================

: string:                   \ build a counted string
     CREATE
     0 ,                    \ POINTER to the data
     0 ,                    \ the count
     DOES>
       DUP @ SWAP CELL+ @
;


: $!  ( addr count 'str -- )           \ store a string
             >BODY
              SWAP OVER CELL+ !
              !
;

: $len ( addr count -- count )
       SWAP DROP
;

: $copy ( addr count 'str -- )

       HERE 2 PICK ROT $!         \ store string pointer to HERE
       HERE SWAP   DUP ALLOT
       CMOVE
;

: $cat ( addr1 count1 addr2 count2 -- addr count )
       2 PICK OVER + DUP >R
       HERE >R
       ALLOT
       2SWAP
       R@ SWAP DUP >R CMOVE   \ move first string

       R> R@ +
       SWAP CMOVE            \ move the second string

       R> R>
;

\ the data fields
string: first-name
string: last-name
string: street
string: city
string: state/prov
string: country
string: postal-code
string: phone
string: e-mail
string: www-page

\ ======================= LOCAL FILE NAMES ================================

string: SEQFILE
string: LOGFILE
string: PROGRAM
string: MAILER
string: HOSTNAME
string: DESTINATION

: init-strings


\ This is the name of the mail program, we are using URL escape codes
\ for quotes which will be converted to actual quotes later

\ S" /usr/ucb/Mail -s %22FIG Membership%22 johnhall@aol.com skip@taygeta.com "
 S" /usr/ucb/Mail -s %22FIG Membership%22 skip@taygeta.com "
                                       ['] MAILER $copy

     S" /usr/local/logs/figreg.seq"      ['] SEQFILE  $copy

     S" /usr/local/logs/figreg.log"      ['] LOGFILE  $copy

     S" %M% V%I%"                         ['] PROGRAM  $copy

     S" taygeta.com"          ['] HOSTNAME $copy


     S" johnhall@aol.com " ['] DESTINATION $copy

;

\ =========================================================================

: acknowledge ( -- )

	." <HEADER><TITLE> Forth Interest Group Membership OK  "
	." </TITLE></HEADER> " CR

	." Everything received <B>OK</B><P> " CR
	." You will be contacted soon about billing information<P> "
	." Your first issue of <I>Forth Dimensions</I> will arrive "
	."  in four to six weeks. " CR
	." Subsequent issues will be mailed to you every other month  "
	." as they are published -- six issues in all. " CR
	." <P><hr> " CR
	." Note, dues are not deductible as a charitable contribution for "
	." U.S. federal income tax purposes," CR ." but may be deductible as "
	." a business expense. " CR
	." <P><hr> " CR
	." <A HREF=http://www.taygeta.com/fig.html> "
	." <IMG SRC="  [CHAR] " EMIT
        ." http://www.taygeta.com/icons/back.xbm" [CHAR] " EMIT
	."  ALT = " [CHAR] " EMIT ." <--" [CHAR] " EMIT ." >  "
	."   Back to FIG Home page</A>. " CR
	." <P> " CR

;

: nack ( -- )

	." <HEADER><TITLE> Forth Interest Group Membership NOT OK  "
	." </TITLE></HEADER> " CR

	." Sorry, There seems to be a problem with the form as you filled it out "

	." <P><hr> " CR
	." <A HREF=http://www.taygeta.com/fig/fig_member.html> "
	." <IMG SRC=" [CHAR] " EMIT
	." http://www.taygeta.com/icons/back.xbm" [CHAR] " EMIT
	."  ALT = " [CHAR] " EMIT ." <--" [CHAR] " EMIT ." >  "
	."   Back to FIG Membership Form page</A>. " CR
	." <P> " CR

;

: sig
        ." <P><HR><ADDRESS><CENTER> " CR
        ." Everett F. Carter Jr. -- skip@taygeta.com" CR
        ." </CENTER></ADDRESS> " CR

;

: atol ( addr count -- d )
     >R
     0. ROT
     R>
     
     >NUMBER
     2DROP
;

: atoi ( addr count -- n )

    atol DROP
;

: move-chars ( dest src count -- dest count )
    >R OVER R@ CMOVE R>
;

: itoa ( n -- addr count )       \ (signed) int to counted string
   out-buf aligned SWAP
   DUP >R ABS S>D
   <# #S R> SIGN #>
   move-chars
;

: newline ( fileid -- flag )

        NEW-LINE-CHARS 1 ROT WRITE-FILE
;

: update_sequence_number ( -- old_no )

	SEQFILE R/W OPEN-FILE  ABORT" Unable to open sequence file "

        TO seq-file

        \ get the current sequence number
        PAD 16 seq-file READ-LINE ABORT" file read error "
        DROP

	PAD SWAP atoi


        \ increment the number and store it away
        DUP 1+

        0. seq-file REPOSITION-FILE DROP

        itoa seq-file WRITE-LINE DROP

        seq-file CLOSE-FILE DROP

;


: write-env ( -- len )

        S" SERVER_PROTOCOL" getenv
        DUP 0= IF 2DROP S" HTTP/1.0" THEN TYPE

        ."  200 OK" CR
        ." MIME-Version: 1.0" CR

        S" SERVER_SOFTWARE" getenv
        DUP 0 > IF TYPE CR ELSE 2DROP THEN

        ." Content-Type: text/html" CR
        \ ." Content-Encoding: HTML" CR
        \ ." Content-Transfer-Encoding: HTML" CR
        CR

        S" CONTENT_LENGTH"  getenv
	DUP IF atoi ELSE 2DROP 0 THEN
;



: plus->space ( addr count -- )         \ convert pluses to spaces

       0 ?DO I OVER + C@ [CHAR] + = IF I OVER + BL SWAP C! THEN LOOP 
       DROP
;

: x2c ( addr count -- n )

      HEX

      >R 0. ROT R>
      >NUMBER
      2DROP DROP

      DECIMAL
;

: unescape-url ( addr count -- count' )

     -1 SWAP
     0 ?DO
           1+

           OVER OVER +             \ get &url[x]
           2 PICK  I + C@          \ get url[y]
           DUP ROT C!              \ url[x] = url[y]


           [CHAR] % = IF         \ convert it if it is a % char
                          OVER I + 1+ 2 x2c  \ convert url[y+1]
                          2 PICK 2 PICK + C! \ and store it at url[x]
                          3
                      ELSE
                          1
                      THEN
                       
        +LOOP

     1+     \ adjust count
     SWAP DROP
;

: skip-past-equals ( -- )

       scan-ptr @ DUP buf-len SWAP ?DO
                                       1+
                                       input-buffer I + C@
                                       [CHAR] = = IF LEAVE THEN
                                    LOOP       
       scan-ptr !
;

: length-to-ampersand ( -- n )

      0
      buf-len scan-ptr @ ?DO
                             input-buffer I + C@
                             [CHAR] & = IF LEAVE THEN
                             1+
                          LOOP

;

: scan ( -- addr count | 0 )


       skip-past-equals

       length-to-ampersand

       DUP 0 > IF
                   input-buffer scan-ptr @ +       \ addr of first char
                   SWAP                            \ put count on top
                   DUP scan-ptr +!
               THEN        
;

\ get data from input stream (stdin)
\ set BAD-STATUS if it failed
: get-input-data ( addr len -- )
 

       \ STDIN READ-FILE

       \ The above SHOULD work, but with ThisForth 94-09-12
       \ it doesn't when this is run with no tty attached (as it will be
       \ when HTTP invokes it), so instead we are using:

       0 READ


       DUP 0 <
       TO bad-status
       TO buf-len
;


: scan-input-data ( -- )

      0 scan-ptr !

      scan DUP 0 > IF ['] first-name  $! THEN
      scan DUP 0 > IF ['] last-name   $! THEN

      scan DUP 0 > IF ['] street      $! THEN
      scan DUP 0 > IF ['] city        $! THEN
      scan DUP 0 > IF ['] state/prov  $! THEN
      scan DUP 0 > IF ['] postal-code $! THEN
      scan DUP 0 > IF ['] country     $! THEN

      scan DUP 0 > IF ['] phone       $! THEN
      scan DUP 0 > IF ['] e-mail      $! THEN
      scan DUP 0 > IF ['] www-page    $! THEN

      \ need a full name
      first-name $len 0= last-name $len 0= OR       TO bad-status

      \ if there is no phone number of e-mail, then there MUST be an
      \ address
      phone $len 0= e-mail $len 0= AND
      IF
             street $len 0=  city $len 0= OR state/prov $len 0= OR
             TO bad-status
      THEN

;

: report-field ( addr count handle -- )

       OVER 0= IF SWAP DROP  SWAP DROP S" (None) " ROT THEN

       WRITE-FILE DROP
;

: report ( handle -- )

       S" First name: " 2 PICK WRITE-FILE DROP
       first-name 2 PICK report-field

       S"    Last name: " 2 PICK WRITE-FILE DROP
       last-name 2 PICK report-field

       DUP newline DROP

       S" Street : " 2 PICK WRITE-FILE DROP
       street 2 PICK report-field

       DUP newline DROP

       S" City : " 2 PICK WRITE-FILE DROP
       city 2 PICK report-field

       S"   State: " 2 PICK WRITE-FILE DROP
       state/prov 2 PICK report-field

       DUP newline DROP

       S" Country: " 2 PICK WRITE-FILE DROP
       country 2 PICK report-field


       S"   postal-code: " 2 PICK WRITE-FILE DROP
       postal-code 2 PICK report-field

       DUP newline DROP

       S" phone: " 2 PICK WRITE-FILE DROP
       phone 2 PICK report-field

       DUP newline DROP

       S" e-mail: " 2 PICK WRITE-FILE DROP
       e-mail 2 PICK report-field

       DUP newline DROP

       S" WWW page: " 2 PICK WRITE-FILE DROP
       www-page 2 PICK report-field

       newline DROP
;


: sendmail ( handle -- handle )

      S" Here is a new FIG Membership request     number: " 2 PICK WRITE-FILE DROP
      seq-no itoa 2 PICK WRITE-LINE DROP

      S" Received at " 2 PICK WRITE-FILE DROP

      PAD 24 timestamp 2 PICK WRITE-FILE DROP
      S"  from the WWW page on: " 2 PICK WRITE-FILE DROP
      HOSTNAME 2 PICK WRITE-LINE DROP

      S" Program: " 2 PICK WRITE-FILE DROP
      PROGRAM 2 PICK WRITE-LINE DROP

      DUP newline DROP

      DUP report


;

: fig_reg ( -- )

	init-strings

        \ fix the mailer string
        MAILER unescape-url    MAILER DROP SWAP ['] MAILER $!

        MAILER DESTINATION $cat ['] MAILER $!

	LOGFILE OPEN-APPEND   ABORT" Unable to open log file "
        TO log-file

	update_sequence_number   DUP TO seq-no


        PAD 24 timestamp log-file WRITE-FILE DROP

        S"     Sequence number is: " log-file WRITE-FILE DROP
        itoa log-file WRITE-FILE DROP

        log-file newline DROP
        
        write-env

        ?DEBUG IF
        	 S" CONTENT LENGTH = "  log-file WRITE-FILE DROP
                 DUP itoa               log-file WRITE-FILE DROP
        THEN


        \ allocate space for the buffer
        HERE TO input-buffer
        DUP 2 + DUP TO buf-len ALLOT

        \ now read characters from the input stream
        input-buffer SWAP get-input-data
 

        ?DEBUG IF
                 S"  BUF-LEN = "  log-file WRITE-FILE DROP
                 buf-len itoa    log-file WRITE-FILE DROP
                 S"  status = "   log-file WRITE-FILE DROP
                 bad-status itoa log-file WRITE-FILE DROP
                 log-file newline DROP
        THEN


        input-buffer buf-len plus->space

	input-buffer buf-len unescape-url   TO buf-len


        ?DEBUG IF
                 input-buffer buf-len log-file WRITE-FILE DROP
                 log-file newline DROP
        THEN

	scan-input-data


        log-file report

        bad-status IF   nack
                   ELSE
			." Mailer command <" MAILER TYPE ." >" CR

                        \ open the mail pipe
                        MAILER W/O OPEN-PIPE
			ABORT" Unable to open pipe to mailer "

                        sendmail
                        CLOSE-PIPE DROP
                        acknowledge
                   THEN

        sig

        log-file newline DROP
        log-file CLOSE-FILE DROP

;

\ auto-startup word

: startup   fig_reg   bye ;


PFE [IF]
  startup
[THEN]