650 lines
14 KiB
Forth
Executable File
650 lines
14 KiB
Forth
Executable File
\ 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 ( -- )
|
|
|
|
|
|
." <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. -- 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-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]
|
|
|
|
|
|
|
|
|
|
|
|
|