649 lines
14 KiB
Forth
Executable File
649 lines
14 KiB
Forth
Executable File
\ #! /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 johnhall@aol.com skip@taygeta.com "
|
|
S" /usr/ucb/Mail -s %22FIG Membership%22 skip@taygeta.com "
|
|
['] 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" johnhall@aol.com " ['] 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. -- 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 ( -- 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]
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|