\ #! /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 [email protected] [email protected] "
S" /usr/ucb/Mail -s %22FIG Membership%22 [email protected] "
                                      ['] 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" [email protected] " ['] 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. -- [email protected]" 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]

You are viewing proxied material from sdf.org. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.