\ 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 ( -- )
."
" ." Thanks for the mail!" CR ."
" CR
;
: nack ( -- )
."
" CR ; : sig ."