\ 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 johnhall@aol.com skip@taygeta.com " ['] MAILER $copy
\ S" johnhall@aol.com skip@taygeta.com " ['] DESTINATION $copy
\ S" johnhall@aol.com " ['] DESTINATION $copy
\ DESTINATION S" skip@taygeta.com " $cat ['] DESTINATION $!
\ S" skip@taygeta.com " ['] DESTINATION $copy
;
\ =========================================================================
: acknowledge ( -- )
." Mail to Forth Interest Group OK "
." " CR
." Everything received OK "
." Thanks for the mail!" CR
."
" CR
." "
." ![[CHAR]]( [CHAR] )
"
." Back to FIG Home page. " CR
." " CR
;
: nack ( -- )
." Mail to Forth Interest Group NOT OK "
." " 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
."
" CR
." "
." ![[CHAR]]( [CHAR] )
"
." Back to FIG Mailer Form page. " CR
." " CR
;
: sig
."
" CR
." Everett F. Carter Jr. -- skip@taygeta.com" CR
." " 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]