@prog mail.muf 1 9999 d 1 i ( To read mail, just "mail". To send mail, "mail user [user [user...]]". A user name of the form "rl/string" treats the part after the slash as an RL mail address, with the note that backslashes are treated as escape characters, and processed according to the character following the backslash: \_ becomes a space \b becomes a backslash This is necessary because spaces cannot appear in a destination name. Access to RL email may be restricted. Control functions take the form of "mail %cmd", where %cmd can be: %alias [alias[=[name1 [name2 ...]]]] Establishes "alias" as an alias; if you mail to "alias" your mail will go to the listed names. If the = is given but no names are given, removes the alias. If the = is omitted as well as all the names, shows what the alias expands to; if everything is omitted, shows all your aliases. While an alias is being expanded, that alias is disabled, to prevent looping and to allow aliasing like "%alias foo=foo bar". %global [alias[=[name1 [name2 ...]]]] Like %alias except the alias is global to the entire mail system. Only a wizard may use this command. Note that personal aliases override global aliases. %fwd [user][=[name1 [name2 ...]]] Controls mail forwarding for the specified user. Only wizards may specify a name before the =; without this, the command works on your own forwarding. Mail sent to you will be forwarded to the specified list, rather as if a global alias had been set for you, except that it does not conflict with any actual such global alias. Skipping the names clears forwarding; skipping the = as well shows what it's set to. %check Reports one of "You have mail.", "You have new mail.", or "You have no mail.", as appropriate. ["new" mail is defined as mail that has never been read.] %qcheck Like %check except that if you have no mail, nothing is printed. %help Prints out a help page of short descriptions. %prompt {on|off} Turns prompts-without-newlines on or off for you. %cansend player={on|off} Lets a wizard restrict who can send mail. With on, lets the player send mail without restriction; with off, prevents the player from sending any mail at all. All other functions of the mail program work fine for disabled players. %rl Enters RL-interface mode. Access to this command is very restricted; see below for a description of the interface. Global aliases are kept in properties on the mail program itself; all other information is stored in properties on players. All such properties are prefixed with the following string: ) : mail-pfx ".mail/" ; ( All properties with this prefix should be considered as reserved to the mailer; any meddling with them is liable to break things. Some of them have documented uses; others are used internally. The following properties on a player are used to store mail received but not yet deleted [all are prefixed with mail-pfx]: nm Number of messages stored. m--nh Number of header lines for message number . m--nt Number of text lines for message number . m--s Status of the message: "new", "read", or "deleted". Note that "deleted" messages are normally discarded upon exiting mail. m--h- Header line for message . m--t- Text line for message . Mail pending delivery to RL is stored on the mail program itself, formatted as described above, except that the m--s property is not used, and there are two additional properties: m--from The envelope-from. m--to The envelope-to. Aliases are stored on the player, in the following properties: na Number of aliases. a--a Alias name for alias number . a--e Alias expansion for alias number . a-x- Alias number for the alias whose name is . Global aliases are stored on the program in the same format. Forwarding lists set with %fwd are stored on the player, in a fwd property. The muck's name, for Received: headers, is stored on the program in a muckname property. The %rl command is allowed only to a players for whom ) : mailer-daemon? "@mailer-daemon" prop-exists? ; ( returns true. When it is given, RL-interface mode is entered. In this mode, the mail program then awaits commands, which can be: E Echo the rest of the input line unchanged. This is used for handshaking. S Send one of the letters awaiting RL delivery. The envelope-from is sent with an F prefix, the envelope-to addresses, each on its own line with a T prefix, the header, each line with an H prefix, and the body, with each line prefixed with a B. After the last line of the letter a single line with just a . is produced. The letter is automatically deleted from the list of letters awaiting RL delivery. If there are no such letters waiting, a single line containing just an X is produced. R Receive a letter from RL. A letter is accepted in the format described under the S command. After all processing for the letter is complete, a line with just a . on it is emitted. P Check for player existence. Following lines are taken as player names, with a line with just a . terminating the list; for each name, one line of output is produced, of the form P name x where name is the name given and x is Y if such a player exists or N if not. The terminating . draws no response. Q Exit mail. Note that envelope-from and envelope-to addresses in this protocol may contain spaces and backslashes; the escaping mentioned earlier is dealt with by the muck mailer. RL addresses do have their rl/ prefix present. Players who cannot send mail have a ) : disable-prop "@mail/nosend" ; ( property on them; when the property is absent, the player is permitted to send. ) : say dup not if pop " " then me @ swap notify ; : mpset (obj prop val -- ) swap mail-pfx swap strcat swap addprop ; : mpget (obj prop -- val) mail-pfx swap strcat getpropstr ; : mpchk (obj prop -- i) mail-pfx swap strcat prop-exists? ; : mpdel (obj prop -- ) mail-pfx swap strcat remove_prop ; : mpsetif (obj prop val -- v) swap mail-pfx swap strcat swap addprop-if ; : mpdelif (obj prop val -- i) swap mail-pfx swap strcat swap remprop-if ; : isspace (c -- i) " " strcmp not ; : splitat (s c -- s1 s2) over swap instr dup if 1 - strcut 1 strcut swap pop else pop "" then ; : pmatch-int dup "#" 1 strncmp if "*" swap strcat match else 1 strcut swap pop atoi dbref dup player? not if pop #-1 then then ; : pmatch pmatch-int dup not if "Not a valid player." say then ; : sstrip begin dup not if exit then 1 strcut over isspace while swap pop loop strcat begin -1 strcut dup isspace while pop loop strcat ; ( note that this locking scheme assumes that any dump/restart takes long enough that systime will change. ) : mail-lock (obj -- ) dup "lock" mpget dup if dup atoi dbref dup daemon? if dup "for" mpget 3 pick strcmp else 1 then swap pop if over swap "lock" swap mpdelif then pop else pop then fork dup not if begin 3600 sleep loop then intostr " " strcat systime intostr strcat dup atoi dbref "for" 3 pick mpset 1 1 25 1 for pop 3 pick 3 pick "lock" swap mpsetif not if pop 0 break then yield loop if pop "Lock on " swap me @ unparse_object " stuck busy!" strcat strcat say 0 sleep daemon kill then pop pop ; : mail-unlock (obj -- ) dup "lock" mpget swap "lock" mpdel atoi dbref kill ; : check-for-mail- me @ "nm" mpget atoi dup 1 < if pop 0 exit then 1 swap 1 for me @ swap intostr "m-" swap "-s" strcat strcat mpget "new" strcmp not if 2 exit then loop 1 ; : check-for-mail me @ mail-lock check-for-mail- me @ mail-unlock ; : do-qcheck check-for-mail 0 over 1 = if pop "You have mail." then over 2 = if pop "You have new mail." then dup if say else pop then pop ; : do-check check-for-mail "You have no mail." over 1 = if pop "You have mail." then over 2 = if pop "You have new mail." then say pop ; : clear-mail-temps (tag -- ) me @ over "-#" strcat mpget atoi dup 0 > if 1 -1 for intostr me @ 3 pick "-" strcat rot strcat mpdel loop else pop then me @ over "-#" strcat mpdel pop ; : clear-all-mail-temps "th" clear-mail-temps "tb" clear-mail-temps "tet" clear-mail-temps ; : add-temp-line (line tag -- ) me @ over "-#" strcat over over mpget atoi 1 + intostr dup 4 1 roll mpset "-" swap strcat strcat me @ swap rot mpset ; : prepend-temp-line (line tag -- ) me @ over "-#" strcat over over mpget atoi 1 + dup 4 1 roll intostr mpset swap "-" strcat swap begin dup 1 > while over over 1 - intostr strcat me @ swap mpget 3 pick 3 pick intostr strcat me @ swap rot mpset 1 - loop intostr strcat me @ swap rot mpset ; : get-temp-count (tag -- n) me @ swap "-#" strcat mpget atoi ; : get-temp-line (n tag -- text) me @ swap "-" strcat rot intostr strcat mpget ; : set-temp-line (text n tag -- ) me @ swap "-" strcat rot intostr strcat rot mpset ; : alias-define (obj alias value -- ) 3 pick mail-lock 3 pick "a-x-" 4 pick strcat mpget atoi dup if intostr else pop 3 pick "na" mpget atoi 1 + intostr 4 pick "na" 3 pick mpset then 4 pick "a-" 3 pick "-a" strcat strcat 5 pick mpset 4 pick "a-" 3 pick "-e" strcat strcat 4 pick mpset 4 pick "a-x-" 5 pick strcat 3 pick mpset pop " -> " swap strcat strcat "Defined: " swap strcat say mail-unlock ; : alias-undefine (obj alias -- ) over mail-lock "a-x-" swap strcat over swap mpget atoi dup not if pop "No such alias defined." say exit then over "na" mpget atoi over intostr over intostr 4 2 roll < if 3 pick "a-" 4 pick "-a" strcat strcat mpget "a-x-" swap strcat 4 pick swap mpdel 3 pick "a-" 4 pick "-a" strcat strcat over "a-" 5 pick "-a" strcat strcat mpget mpset 3 pick "a-" 4 pick "-e" strcat strcat over "a-" 5 pick "-e" strcat strcat mpget mpset 3 pick "a-" 4 pick "-a" strcat strcat mpget "a-x-" swap strcat 4 pick swap 4 pick mpset 3 pick "a-" 3 pick "-a" strcat strcat mpdel 3 pick "a-" 3 pick "-e" strcat strcat mpdel else 3 pick "a-" 4 pick "-a" strcat strcat mpget "a-x-" swap strcat 4 pick swap mpdel 3 pick "a-" 3 pick "-a" strcat strcat mpdel 3 pick "a-" 3 pick "-e" strcat strcat mpdel then swap pop atoi 1 - dup if over swap "na" swap intostr mpset else pop dup "na" mpdel then mail-unlock "Removed." say ; : alias-show-1-internal (obj alias -- ) "a-x-" swap strcat over swap mpget atoi dup if intostr over over "a-" swap "-a" strcat strcat mpget " -> " strcat 3 pick rot "a-" swap "-e" strcat strcat mpget strcat say else pop "No such alias defined." say then pop ; : alias-show-1 (obj alias -- ) over swap over mail-lock alias-show-1-internal mail-unlock ; : alias-show-all (obj -- ) dup mail-lock dup "na" mpget atoi dup 1 < if pop "None defined." say mail-unlock exit then 1 swap 1 for intostr "a-" swap "-a" strcat strcat over dup rot mpget alias-show-1-internal loop mail-unlock ; : alias-internal (obj ckpriv cmd -- ) sstrip dup "=" instr dup if 1 - strcut 1 strcut swap pop rot exec if pop pop pop "Permission denied." say exit then sstrip dup if alias-define else pop alias-undefine then else pop swap pop dup if alias-show-1 else pop alias-show-all then then ; : ckpriv-nopriv 0 ; : ckpriv-wizard me @ wizard? not ; : do-alias me @ swap ' ckpriv-nopriv swap alias-internal ; : do-global prog swap ' ckpriv-wizard swap alias-internal ; : do-clear clear-all-mail-temps ; : do-fwd sstrip dup "=" instr dup if 1 - strcut 1 strcut swap pop swap sstrip dup if me @ wizard? not if pop pop "Permission denied." say exit then pmatch dup not if pop pop exit then else pop me @ then swap sstrip dup if "fwd" swap mpset "Forwarding set." else pop "fwd" mpdel "Forwarding removed." then say else pop dup if me @ wizard? not if pop "Permission denied." say exit then pmatch dup not if pop exit then else pop me @ then dup "fwd" mpget dup if "Forward to: " swap strcat else pop "No forwarding in effect." then say then ; : do-cansend me @ wizard? not if pop "Permission denied." say exit then sstrip dup "=" instr dup if 1 - strcut 1 strcut swap pop swap pmatch dup player? not if pop pop "That's not a player." say exit then swap dup "on" strcmp not if pop 1 else dup "off" strcmp not eif pop 0 else pop pop "Usage: %cansend player={on|off}" say exit then disable-prop swap if remove_prop else "" addprop then "Set." say else pop pmatch dup player? not if pop "That's not a player." say exit then dup disable-prop prop-exists? if "is not allowed" else "is allowed" then swap name " " strcat swap strcat " to send mail." strcat say then ; : copy-for-delivery (obj msgnumstr temptag delivertag -- obj msgnumstr) over get-temp-count 5 pick "m-" 6 pick "-n" 6 pick strcat strcat strcat 3 pick intostr mpset 1 -1 for dup 4 pick get-temp-line 6 pick "m-" 7 pick "-" 7 pick "-" 8 rotate intostr strcat strcat strcat strcat strcat rot mpset loop pop pop ; : deliver-local (addr -- ) dup pmatch-int dup not if pop "No local user called " swap strcat "!" strcat say exit then swap pop dup mail-lock dup "nm" mpget atoi 1 + intostr over over "nm" swap mpset over "m-" 3 pick "-s" strcat strcat "new" mpset "th" "h" copy-for-delivery "tb" "t" copy-for-delivery pop dup "You have new mail." notify mail-unlock ; : deliver-rl (addr -- ) prog mail-lock prog "nm" mpget atoi 1 + intostr prog over "nm" swap mpset prog swap "th" "h" copy-for-delivery "tb" "t" copy-for-delivery swap pop prog "m-" 3 pick "-from" strcat strcat me @ "ef" mpget mpset prog "m-" 3 pick "-to" strcat strcat 4 pick mpset pop prog mail-unlock ; : addr-is-rl? (addr -- bool) "rl/" 3 strncmp not ; : deliver-message me @ disable-prop prop-exists? if prog owner "MAIL: Delivering message for disabled user " me @ prog owner unparse_object strcat notify exit then 1 "tet" get-temp-count 1 for "tet" get-temp-line dup addr-is-rl? if deliver-rl else deliver-local then loop ; : zap-lines (obj n type -- obj n) 3 pick "m-" 4 pick "-n" 5 pick strcat strcat strcat swap over mpget atoi 1 -1 for 5 pick "m-" 6 pick "-" 7 pick "-" 7 rotate intostr strcat strcat strcat strcat strcat mpdel loop 4 pick swap mpdel pop ; : zap-msg (obj n -- ) "h" zap-lines "t" zap-lines over "m-" 3 pick "-s" strcat strcat mpdel over "m-" 3 pick "-from" strcat strcat mpdel over "m-" 3 pick "-to" strcat strcat mpdel pop pop ; : add-Received:-line "Received: " swap strcat "by " strcat prog "muckname" mpget strcat " " strcat systime ctime strcat "th" prepend-temp-line ; : break-name-list (list source -- addr1 addr2 ... addrN N) swap " " explode dup 2 + rotate 0 swap rot 1 -1 for 3 pick 2 + + rotate dup not if pop continue then rot 1 + rot loop pop ; : undisable-alias (obj num -- ) "a-" swap "-d" strcat strcat mpdel ; : expand-one-alias (name obj -- x1 x2 clrfn 2 eN ... e1 N obj 1 / name 0) dup "a-x-" 4 pick strcat mpget atoi dup not if pop pop 0 exit then intostr over over "a-" swap "-d" strcat strcat mpchk if pop pop 0 exit then over over "a-" swap "-d" strcat strcat "" mpset rot pop ' undisable-alias 2 4 pick 4 pick "a-" swap "-e" strcat strcat mpget 5 pick break-name-list dup 5 + pick 1 ; : undisable-fwd (obj -- ) "fwd.d" mpdel ; : expand-forward (name -- x clrfn 1 eN ... e1 N player 1 / name 0) dup pmatch-int dup if dup "fwd.d" mpchk not if ( name player ) dup "fwd" mpget sstrip dup if ( name player fwd-to ) rot pop over "fwd.d" "" mpset ' undisable-fwd 1 rot 4 pick break-name-list dup 4 + pick 1 exit else pop then then then pop 0 ; : expand-alias-relative (alias who -- aN ... a1 N) expand-one-alias not if prog expand-one-alias not if expand-forward not if 1 exit then then then ( fixM ... fix1 fixfn M eN ... e1 N relative-to ) over if over 1 -1 for ( <> eN ... ei+1 ei ei-1 ... e1 N rel i ) dup 3 + rotate 3 pick ( <> eN ... ei+1 ei-1 ... e1 N rel i ei rel ) expand-alias-relative ( <> eN ... ei+1 ei-1 ... e1 N rel i xM ... x1 M ) dup 4 + rotate over + 1 - over 4 + -1 * rotate ( <> eN ... ei+1 ei-1 ... e1 N+M-1 rel i xM ... x1 M ) dup 2 + rotate over + 1 + swap ( <> eN ... ei+1 ei-1 ... e1 N+M-1 rel xM ... x1 i+M+1 M ) roll ( <> eN ... ei+1 xM ... x1 ei-1 ... e1 N+M-1 rel ) loop then ( fixM ... fix1 fixfn M eN ... e1 N rel ) pop dup 2 + pick over + 3 + over 1 + ( fixM ... fix1 fixfn M eN ... e1 N M+N+3 N+1 ) roll ( eN ... e1 N fixM ... fix1 fixfn M ) pop exec ( eN ... e1 N ) ; : chase-aliases-in-list (aN ... a1 N -- aM ... a1 M) dup if dup 1 -1 for dup 2 + rotate me @ expand-alias-relative ( aN ... ai+1 ai-1 ... a1 N i xM ... x1 M ) dup 3 + rotate over + 1 - over 3 + -1 * rotate ( aN ... ai+1 ai-1 ... a1 N+M-1 i xM ... x1 M ) dup 2 + rotate over + swap ( aN ... ai+1 ai-1 ... a1 N+M-1 xM ... x1 i+M M ) roll ( aN ... ai+1 xM ... x1 ai-1 ... a1 N+M-1 ) loop then ; : expand-rl-to prog expand-alias-relative ; : map-backslash-to-rl " " "\\_" subst "\\" "\\b" subst ; : map-backslash-from-rl "\\b" "\\" subst "\\_" " " subst ; : rl-S-lines (n type linetag -- n) prog "m-" 5 pick "-n" 6 pick strcat strcat strcat mpget atoi dup 1 < if pop pop pop exit then 1 swap 1 for intostr prog "m-" 6 pick "-" 7 pick "-" 7 rotate strcat strcat strcat strcat strcat mpget over swap strcat say loop pop pop ; : rl-S prog mail-lock prog "nm" mpget atoi dup if dup 1 - prog "nm" rot intostr mpset intostr prog "m-" 3 pick "-from" strcat strcat mpget map-backslash-to-rl "F" swap strcat say prog "m-" 3 pick "-to" strcat strcat mpget map-backslash-to-rl "T" swap strcat say "h" "H" rl-S-lines "t" "B" rl-S-lines "." say prog swap zap-msg else "X" say then prog mail-unlock ; : rl-R clear-all-mail-temps begin read 1 strcut swap dup "F" strcmp not if pop map-backslash-from-rl me @ "ef" rot mpset else dup "T" strcmp not eif pop map-backslash-from-rl expand-rl-to 1 -1 for pop "tet" add-temp-line loop else dup "H" strcmp not eif pop dup 5 strcut pop "From:" stringcmp not if 5 strcut sstrip map-backslash-from-rl " " swap strcat strcat then "th" add-temp-line else dup "B" strcmp not eif pop "tb" add-temp-line else dup "." strcmp not eif pop pop break else pop pop then loop "from " connections "" swap 1 -1 for pop over condbref me @ dbcmp if pop conhost else swap pop then loop dup not if pop "(unknown)" then strcat " " strcat add-Received:-line deliver-message me @ "ef" mpdel clear-all-mail-temps "." say ; : rl-P begin read dup "." strcmp while "*" over strcat match if "Y" else "N" then swap "P" 3 " " implode say loop ; : do-rl me @ mailer-daemon? not if "Permission denied." say exit then begin read 1 strcut swap dup "Q" strcmp not if pop pop break else dup "E" strcmp not eif pop say else dup "S" strcmp not eif pop pop rl-S else dup "R" strcmp not eif pop pop rl-R else dup "P" strcmp not eif pop pop rl-P else pop pop then loop ; : prompt-for-input (s -- s) 1 swap me @ "noprompt" mpchk if say read else prompt then dup string? if swap pop else (this shouldn't be possible, but there's a bug in the muck's handling of do_disconnect that makes it happen when someone disconnects while in mail....) 0 sleep daemon kill then ; : do-prompt sstrip dup "on" strcmp not if pop me @ "noprompt" mpdel else dup "off" strcmp not eif pop me @ "noprompt" "" mpset else pop "Argument should be `on' or `off'." say then ; : do-help "mail reads mail" say "mail user... sends mail" say "mail %alias [alias[=[name1 [name2 ...]]]]" say " Sets up `alias' to expand to the names given. No names means" say " delete the alias; if = is omitted, shows the alias; if all args" say " omitted, shows all aliases." say "mail %global [alias[=[name1 [name2 ...]]]]" say " Like %alias except aliases are valid for everyone. Wiz-only." say "mail %fwd [user][=[name1 [name2 ...]]]]" say " Sets forwarding. Only wiz may specify user name. = and parts" say " after it are as for %alias (show, remove, set)." say "mail %check Check to see if you have mail." say "mail %qcheck Like %check but no output if no mail." say "mail %help Show this text." say "mail %prompt on" say "mail %prompt off" say " Turns on or off use of prompt-without-newline prompting, since" say " some clients get upset by it." say "mail %cansend player={on|off}" say " Allow/disallow player to sending mail. Wiz-only." say "Addresses of the form rl/rl-email-address send mail to RL." say ; : do-chase me @ wizard? not if pop "Permission denied." say exit then sstrip dup "@" instr dup if 1 - strcut 1 strcut swap pop atoi dbref 2 "Before" pstack expand-alias-relative dup 1 + "After" pstack else pop me @ break-name-list dup 1 + "Before" pstack chase-aliases-in-list dup 1 + "After" pstack then ; : mail-cmd dup "%qcheck" strcmp not if pop do-qcheck exit then dup "%check" strcmp not if pop do-check exit then dup "%rl" strcmp not if pop do-rl exit then dup "%clear" strcmp not if pop do-clear exit then dup "%help" strcmp not if pop do-help exit then dup "%prompt" 7 strncmp not if 7 strcut swap pop do-prompt exit then dup "%fwd" 4 strncmp not if 4 strcut swap pop do-fwd exit then dup "%alias" 6 strncmp not if 6 strcut swap pop do-alias exit then dup "%global" 7 strncmp not if 7 strcut swap pop do-global exit then dup "%cansend" 8 strncmp not if 8 strcut swap pop do-cansend exit then dup "%chase" 6 strncmp not if 6 strcut swap pop do-chase exit then "Unknown mail command: " swap strcat say ; : msg-is-deleted? (n -- i) me @ "m-" rot intostr "-s" strcat strcat mpget "deleted" strcmp not ; : msg-is-inrange? (n -- i) dup 0 <= if pop 0 exit then dup me @ "nm" mpget atoi > if pop 0 exit then pop 1 ; : msg-is-ok? (n -- i) dup msg-is-inrange? not if pop 0 exit then msg-is-deleted? not ; : msg-is-new? (n -- i) me @ "m-" rot intostr "-s" strcat strcat mpget "new" strcmp not ; : get-hdr-of-msg (n hdr -- text) "m-" rot intostr "-" strcat strcat me @ over "nh" strcat mpget atoi 1 -1 for me @ 3 pick "h-" strcat rot intostr strcat mpget dup 4 pick dup strlen strncmp if pop else swap pop swap pop exit then loop pop pop "" ; : get-hdrtext-of-msg (n hdr -- text) dup strlen rot rot get-hdr-of-msg swap strcut swap pop sstrip ; : get-status-of-msg (msgnum -- status) me @ "m-" rot intostr "-s" strcat strcat mpget ; : get-linecount-of-msg (msgnum -- linecount) me @ "m-" rot intostr "-nt" strcat strcat mpget atoi ; : show-hdrline-of-msg (n -- ) dup intostr " " swap strcat -3 strcut swap pop over get-status-of-msg "new" strcmp if " " else "N" then swap strcat over me @ "cm" mpget atoi = if ">" else " " then swap strcat ": " strcat over "From:" get-hdrtext-of-msg strcat " / " strcat over "Date:" get-hdrtext-of-msg strcat " / " strcat over "Subject:" get-hdr-of-msg dup if 8 strcut swap pop sstrip 40 strcut pop "\"" swap over strcat strcat strcat else pop "(no subject)" strcat then " / [" strcat over get-linecount-of-msg intostr strcat "]" strcat say pop ; : show-hdrs-from (n -- ) me @ "nm" mpget atoi swap 0 swap begin over 10 < while dup 4 pick <= while dup msg-is-deleted? not if dup show-hdrline-of-msg swap 1 + swap then 1 + loop pop pop pop ; : show-hdrs me @ "cm" mpget atoi dup not if pop "No messages." say exit then show-hdrs-from ; : print-curmsg me @ "cm" mpget atoi intostr me @ "m-" 3 pick "-nh" strcat strcat mpget atoi 1 swap 1 for me @ "m-" 4 pick "-h-" 5 rotate intostr strcat strcat strcat mpget say loop " " say me @ "m-" 3 pick "-nt" strcat strcat mpget atoi 1 swap 1 for me @ "m-" 4 pick "-t-" 5 rotate intostr strcat strcat strcat mpget say loop me @ "m-" 3 pick "-s" strcat strcat "read" mpset pop ; : delete-curmsg me @ "cm" mpget atoi me @ "m-" 3 pick intostr "-s" strcat strcat "deleted" mpset me @ "nm" mpget atoi swap begin 1 + over over >= while dup msg-is-deleted? while loop over over >= if swap pop me @ "cm" rot intostr mpset exit then pop pop me @ "cm" mpget atoi begin 1 - dup 0 > while dup msg-is-deleted? while loop me @ "cm" rot intostr mpset ; : advance-curmsg ( -- i) me @ "nm" mpget atoi me @ "cm" mpget atoi begin 1 + over over < if pop pop 1 exit then dup msg-is-deleted? not if me @ "cm" rot intostr mpset pop 0 exit then loop ; : no-msgs? me @ "cm" mpget atoi not ; : arg-default-cm 1 strcut swap pop sstrip dup not if pop me @ "cm" mpget then atoi ; : copy-msg-prop (from to suffix -- from to) me @ "m-" 5 pick 4 pick strcat strcat mpget me @ "m-" 5 pick 5 pick strcat strcat rot mpset pop ; : copy-lines (from to type -- from to) rot rot "-n" 4 pick strcat copy-msg-prop me @ "m-" 3 pick "-n" 7 pick strcat strcat strcat mpget atoi 1 -1 for "-" 5 pick "-" 4 rotate intostr strcat strcat strcat copy-msg-prop loop rot pop ; : copy-msg (from to -- ) over over = if pop pop exit then intostr swap intostr swap me @ over zap-msg "h" copy-lines "t" copy-lines "-s" copy-msg-prop pop pop ; : flush-deleted me @ "nm" mpget atoi 1 1 3 pick 1 for dup msg-is-deleted? not if over copy-msg 1 + else pop then loop 1 - swap over 1 + begin over over >= while me @ over intostr zap-msg 1 + loop pop pop dup if me @ "nm" rot intostr mpset else pop me @ "nm" mpdel then ; : local-check (addr -- ) dup addr-is-rl? if pop exit then dup pmatch-int if pop exit then "Warning: there currently is no local user called " swap "!" strcat strcat say ; : hdrto-to-envto me @ break-name-list chase-aliases-in-list begin dup 0 > while 1 - swap dup local-check "tet" add-temp-line loop pop ; : start-header (to-list -- ) "To: " over strcat "th" add-temp-line hdrto-to-envto "From: " me @ name strcat "th" add-temp-line "Date: " systime ctime strcat "th" add-temp-line "" add-Received:-line ; : add-to-hdr (str hdrname sep -- ) 1 "th" get-temp-count 1 for dup "th" get-temp-line dup 5 pick dup strlen strncmp if pop pop else rot strcat 4 rotate strcat swap "th" set-temp-line pop exit then loop pop " " strcat swap strcat "th" add-temp-line ; : show-letter "th" get-temp-count 1 swap 1 for "th" get-temp-line say loop " " say "tb" get-temp-count dup if 1 swap 1 for "tb" get-temp-line say loop else pop then "(continue)" say ; : accumulate-message ( -- i) "Enter message text (. to end, %? for help)" say begin read dup "." strcmp while dup "%" 1 strncmp not if dup "%\"" 2 strncmp not if 2 strcut swap pop else dup "%%" 2 strncmp not eif 1 strcut swap pop else dup "%!" strcmp not eif 2 strcut swap pop me @ swap force else dup "%?" strcmp not eif pop "%\"text - enter message line `text'" say "%%text - enter message line `%text'" say "%? - print this help" say "%t user - add user to to-list" say "%c user - send a cc to user" say "%p - show letter so far" say "%q - quit mail, discarding unsent letter" say "%e - enter message editor" say "%!command - execute muck command" say ". - end letter and send it" say continue else dup "%q" strcmp not eif pop 1 exit else dup "%p" strcmp not eif pop show-letter continue else dup "%e" strcmp not eif pop "Not yet implemented" say continue else dup "%c" 2 strncmp not eif 2 strcut swap pop sstrip dup "Cc:" " " add-to-hdr hdrto-to-envto continue else dup "%t" 2 strncmp not eif 2 strcut swap pop sstrip dup "To:" " " add-to-hdr hdrto-to-envto continue else "Unknown % escape " swap strcat say continue then then "tb" add-temp-line loop pop 0 ; : do-&-? "? print this help info" say "!cmd execute a muck command" say "q flush deleted messages and exit" say "x same as q" say " print message #" say "d delete current message" say "d delete message #" say "u undelete deleted message #" say "t print current message" say "t print message #" say "h show headers, starting at current message" say "h show headers, starting at message #" say " (just RETURN) print current message if new, else next message" say ; : do-&-return me @ "cm" mpget atoi dup msg-is-new? not if advance-curmsg if "At EOF" say exit then then print-curmsg ; : do-&-h no-msgs? if pop "No messages." say exit then arg-default-cm dup msg-is-inrange? not if pop "Invalid message number." say exit then show-hdrs-from ; : do-&-d no-msgs? if pop "No messages." say exit then arg-default-cm dup msg-is-ok? not if pop "Invalid message number." say exit then me @ "cm" rot intostr mpset delete-curmsg ; : do-&-t no-msgs? if pop "No messages." say exit then arg-default-cm dup msg-is-ok? not if pop "Invalid message number." say exit then me @ "cm" rot intostr mpset print-curmsg ; : do-&-u arg-default-cm dup msg-is-inrange? not if pop "Invalid message number." say exit then dup msg-is-deleted? not if pop "Message is not deleted." say exit then intostr me @ "m-" 3 pick "-s" strcat strcat "read" mpset me @ "cm" rot mpset ; : nosend "You are not allowed to send mail." say ; : do-&-r me @ disable-prop prop-exists? if pop nosend exit then clear-all-mail-temps arg-default-cm dup msg-is-ok? not if pop "Invalid message number." say exit then dup "From:" get-hdrtext-of-msg start-header dup "Subject:" get-hdr-of-msg dup if 8 strcut swap pop sstrip dup "Re:" 3 strncmp if "Re: " swap strcat then "Subject: " swap strcat "th" add-temp-line else pop then me @ mail-unlock accumulate-message if me @ mail-lock exit then me @ "ef" me @ name mpset deliver-message me @ "ef" mpdel me @ mail-lock clear-all-mail-temps ; : do-&-! 1 strcut swap pop me @ swap me @ mail-unlock force me @ mail-lock ; : do-&-command me @ mail-unlock "& " prompt-for-input me @ mail-lock dup "?" strcmp not if pop do-&-? else dup "help" stringcmp not eif pop do-&-? else dup "X" strcmp not eif pop 1 exit else dup "x" strcmp not eif pop flush-deleted 1 exit else dup "q" strcmp not eif pop flush-deleted 1 exit else dup "" strcmp not eif pop do-&-return else dup "h" 1 strncmp not eif do-&-h else dup "d" 1 strncmp not eif do-&-d else dup "t" 1 strncmp not eif do-&-t else dup "u" 1 strncmp not eif do-&-u else dup "r" 1 strncmp not eif do-&-r else dup "!" 1 strncmp not eif do-&-! else dup atoi dup if swap pop dup msg-is-ok? not if pop "Invalid message number" say else me @ "cm" rot intostr mpset print-curmsg then else pop "Unknown mail command: " swap strcat say then then 0 ; : read-mail- me @ mail-lock me @ "nm" mpget atoi dup 1 < if pop "No mail for " me @ name "." strcat strcat say me @ mail-unlock exit then 1 1 rot 1 for dup intostr "m-" swap "-s" strcat strcat me @ swap mpget "new" strcmp not if swap pop break then pop loop intostr me @ "cm" rot mpset show-hdrs begin do-&-command until me @ mail-unlock "Mail done." say ; : read-mail read-mail- me @ "cm" mpdel ; : enter-subject ( -- i) "Subject (return for none, . to abort): " prompt-for-input dup "." strcmp not if "Send aborted." say 1 exit then dup if "Subject: " swap strcat "th" add-temp-line else pop then 0 ; : send-mail- start-header enter-subject if exit then accumulate-message if "Aborted." say exit then me @ "ef" me @ name mpset deliver-message me @ "ef" mpdel "Sent." say ; : send-mail me @ disable-prop prop-exists? if pop nosend exit then clear-all-mail-temps send-mail- clear-all-mail-temps ; : main " " " " subst sstrip dup not if pop read-mail exit then dup "%" 1 strncmp not if mail-cmd exit then send-mail ; . c q