\ MAILFIG       program to handle forms for comments to FIG

\ This is an ANS Forth program requiring:
\      1. The File Access word set.
\      2. The words CMOVE and COMPARE 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).


\  (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: @(#)mailfig.fth        1.5 10:15:52 11/6/95   EFC


FALSE  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
FALSE VALUE cc-req
FALSE VALUE unesc-req
FALSE VALUE strip-plus-req

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: name
string: comments
string: e-mail
string: subject
string: request

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

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


: init-strings

     S" /usr/skip/forth/FIG/figmail.seq"  ['] SEQFILE  $copy

     S" /usr/skip/forth/FIG/figmail.log"  ['] LOGFILE  $copy

     S" mailfig.fth V1.5"                         ['] PROGRAM  $copy

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


\ 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 Comments%22 [email protected] [email protected] " ['] MAILER $copy


\     S"  [email protected] [email protected] " ['] DESTINATION $copy

\     S"  [email protected] " ['] DESTINATION $copy
\     DESTINATION   S"  [email protected] "  $cat ['] DESTINATION $!

\      S"  [email protected] " ['] DESTINATION $copy

;


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

: acknowledge ( -- )


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

       ." Everything received <B>OK</B><P> "
       ." Thanks for the mail!" 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> Mail to Forth Interest Group NOT OK  "
       ." </TITLE></HEADER> " CR

       ." Sorry, There seems to be a problem with the form as you filled it out "
       CR CR
       ." Is perhaps your name/e-mail missing ?" CR

       ." <P><hr> " CR
       ." <A HREF=http://www.taygeta.com/fig/figmail.html> "
       ." <IMG SRC=" [CHAR] " EMIT
       ." http://www.taygeta.com/icons/back.xbm" [CHAR] " EMIT
       ."  ALT = " [CHAR] " EMIT ." <--" [CHAR] " EMIT ." >  "
       ."   Back to FIG Mailer 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-in ( -- 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-in DUP 0 > IF ['] subject    $! THEN
     scan-in DUP 0 > IF ['] comments   $! THEN

     scan-in DUP 0 > IF ['] name       $! THEN
     scan-in DUP 0 > IF ['] e-mail     $! THEN

     \ get cc request
     scan-in DUP 0 > IF ['] request    $! THEN
     request 3 MIN S" Yes" compare 0= TO cc-req

     \ get strip_plus request
     scan-in DUP 0 > IF ['] request    $! THEN
     request 3 MIN S" Yes" compare 0= TO strip-plus-req

     \ get unescape request
     scan-in DUP 0 > IF ['] request    $! THEN
     request 3 MIN S" Yes" compare 0= TO unesc-req


     name plus->space

     strip-plus-req IF
                      subject  plus->space
                      comments plus->space
                    THEN

     name unescape-url   name DROP SWAP ['] name $!

     unesc-req IF
                 subject unescape-url    subject  DROP SWAP ['] subject $!
                 comments unescape-url   comments DROP SWAP ['] comments $!
               THEN


     \ need a name or e-mail
     name $len 0= e-mail $len 0= AND       TO bad-status



;

: report-field ( addr count handle -- )

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

      WRITE-FILE DROP
;

: report ( handle -- )

      S" Subject: " 2 PICK WRITE-FILE DROP
      subject 2 PICK report-field
      DUP newline DROP

      S" Comments: " 2 PICK WRITE-FILE DROP
      DUP newline DROP
      comments 2 PICK report-field

      DUP newline DROP
      DUP newline DROP

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

      DUP newline DROP

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

      newline DROP
;


: sendmail ( handle -- handle )


     DUP report

     S" Sequence 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




;

: mail_fig ( -- )

       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




       ?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
                       \ open the mail pipe
                        cc-req IF
                                 MAILER e-mail $cat ['] MAILER $!
                        THEN

                        ?DEBUG IF
                                 S" Mailer: " log-file WRITE-FILE DROP
                                 MAILER log-file WRITE-FILE DROP
                                 log-file newline DROP
                               THEN

                       \ ." Mailer command <" MAILER TYPE ." >" CR

                       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   mail_fig   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.