(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "27-Feb-2024 09:28:24" {WMEDLEY}lafite>LAFITE-TIMEDDELETE.;3 10989 :EDIT-BY rmk :CHANGES-TO (VARS LAFITE-TIMEDDELETECOMS) :PREVIOUS-DATE "23-Feb-2024 23:23:25" {WMEDLEY}lafite>LAFITE-TIMEDDELETE.;2) (PRETTYCOMPRINT LAFITE-TIMEDDELETECOMS) (RPAQQ LAFITE-TIMEDDELETECOMS ((DECLARE%: DONTCOPY EVAL@COMPILE (FILES LAFITE-DECLS)) (FILES LAFITE-FIND) (FNS \LAFITE.TIMEDDELETE \LAFITE.SETEXPIRATIONS \LAFITE.DELETEEXPIRED) (FNS LTD.INIT MESSAGEAGE) (INITVARS EXPIRATIONMENU) (VARS EXPIRATIONMENUITEMS MARKDURATIONS) (GLOBALVARS EXPIRATIONMENU EXPIRATIONMENUITEMS MARKDURATIONS) (P (LTD.INIT)))) (DECLARE%: DONTCOPY EVAL@COMPILE (FILESLOAD LAFITE-DECLS) ) (FILESLOAD LAFITE-FIND) (DEFINEQ (\LAFITE.TIMEDDELETE [LAMBDA (WINDOW MAILFOLDER ITEM MENU KEY) (* jtm%: "30-Sep-87 14:25") (COND ((EQ KEY 'MIDDLE) (\LAFITE.SETEXPIRATIONS WINDOW MAILFOLDER ITEM MENU)) (T (\LAFITE.DELETE WINDOW MAILFOLDER ITEM MENU]) (\LAFITE.SETEXPIRATIONS [LAMBDA (WINDOW MAILFOLDER ITEM MENU) (* ; "Edited 21-Sep-88 16:36 by jtm:") (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) [LET (EXPIRATION DURATION MSGDURATION MSGEXPIRATION TODAY YEAR ONEDAY MESSAGEAGE (N 0) (NODATE 0)) (\LAFITE.MAYBE.CLEAR.PROMPT MAILFOLDER) (COND [[SETQ EXPIRATION (MENU (OR EXPIRATIONMENU (SETQ EXPIRATIONMENU (create MENU MENUFONT _ LAFITEMENUFONT TITLE _ "Expiration date" CENTERFLG _ T ITEMS _ EXPIRATIONMENUITEMS] (SETQ DURATION (CADR (FASSOC EXPIRATION MARKDURATIONS))) [AND DURATION (add DURATION (IMINUS (IQUOTIENT DURATION 10] (* this is so yesterday's messages won't be marked as 4 months when you ask for  2.0) [COND ((NOT (LAB.ASSURE.SELECTIONS MAILFOLDER)) (SETQ ONEDAY (IDIFFERENCE (IDATE "2-Jan-80 12:00") (IDATE "1-Jan-80 12:00"))) (SETQ TODAY (IPLUS (IDATE (DATE)) (IQUOTIENT ONEDAY 2))) (* treat "now" as being after noon  for the purposes of counting days.) (SETQ YEAR (SUBSTRING (DATE) 8 9)) (for MSG selectedin MAILFOLDER when (OR (EQ EXPIRATION 0) (NOT (fetch (LAFITEMSG DELETED?) of MSG))) do (COND ((EQ EXPIRATION T) (DELETEMESSAGE MSG MAILFOLDER)) ((EQ EXPIRATION 0) (* equivalent to undelete.) (UNDELETEMESSAGE MSG MAILFOLDER) (MARKMESSAGE MSG MAILFOLDER 32)) ((SETQ MESSAGEAGE (MESSAGEAGE MSG TODAY YEAR ONEDAY)) (SETQ MSGDURATION (IPLUS DURATION MESSAGEAGE)) (SETQ MSGEXPIRATION (OR [CAR (for ITEM in MARKDURATIONS thereis (ILEQ MSGDURATION (CADR ITEM] 9)) (MARKMESSAGE MSG MAILFOLDER (IPLUS 48 MSGEXPIRATION))) (T (* the message didn't have a date.  Flag the message with a ?) (add NODATE 1) (MARKMESSAGE MSG MAILFOLDER 63))) (add N 1] (COND ((EQ NODATE 0) (LAB.PROMPTPRINT MAILFOLDER T "Marked " N " " (COND ((EQ N 1) "message") (T "messages")) " to expire after " [CAR (for I in EXPIRATIONMENUITEMS thereis (EQ EXPIRATION (CADR I] ".")) (T (LAB.PROMPTPRINT MAILFOLDER T "Error: " NODATE " " (COND ((EQ NODATE 1) "message") (T "messages")) " had a bad date."] (T (LAB.PROMPTPRINT MAILFOLDER T "No expiration date selected."])]) (\LAFITE.DELETEEXPIRED [LAMBDA (MAILFOLDER) (* ; "Edited 22-Jun-89 09:39 by jtm:") (* ; "Edited 22-Jun-89 09:39 by jtm:") (* ; "Edited 22-Jun-89 09:37 by jtm:") (* ; "Edited 22-Jun-89 09:36 by jtm:") (* ; "Edited 22-Jun-89 09:22 by jtm:") (* ; "Edited 21-Sep-88 16:39 by jtm:") (LET (MESSAGES LASTMSG# YEAR TODAY ONEDAY MISSING (N 0)) (SETQ MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER)) (SETQ LASTMSG# (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER)) (SETQ TODAY (IDATE (DATE))) (SETQ YEAR (SUBSTRING (DATE) 8 9)) (SETQ ONEDAY (IDIFFERENCE (IDATE "2-Jan-80 12:00") (IDATE "1-Jan-80 12:00"))) [for I MSG MARK MSGAGE DURATION from 1 to LASTMSG# do (SETQ MSG (NTHMESSAGE MESSAGES I)) (SETQ MARK (fetch (LAFITEMSG MARKCHAR) of MSG)) (COND ((AND (IGREATERP MARK 48) (ILESSP MARK 58) (NOT (fetch (LAFITEMSG DELETED?) of MSG))) (SETQ MSGAGE (MESSAGEAGE MSG TODAY YEAR ONEDAY)) (SETQ DURATION (CADR (FASSOC (IDIFFERENCE MARK 48) MARKDURATIONS))) (COND ((NULL MSGAGE) (push MISSING I)) ((AND DURATION (IGEQ MSGAGE DURATION)) (DELETEMESSAGE MSG MAILFOLDER) (add N 1] (COND (MISSING (SETQ MISSING (DREVERSE MISSING)) (LAB.PROMPTPRINT MAILFOLDER T "The dates for " MISSING " cannot be parsed.")) (T (LAB.PROMPTPRINT MAILFOLDER T N " expired " (COND ((EQ N 1) "message") (T "messages")) " deleted."]) ) (DEFINEQ (LTD.INIT [LAMBDA NIL (* jtm%: "30-Sep-87 16:44") (LET (DELETEMENUITEM) (COND ((SETQ DELETEMENUITEM (SASSOC "Delete" LAFITEBROWSERMENUITEMS)) (RPLACA (CDR DELETEMENUITEM) ''\LAFITE.TIMEDDELETE) (COND ((NOT (SASSOC "Delete Expired Msgs" LAFITEEXTRAMENUITEMS)) (push LAFITEEXTRAMENUITEMS '("Delete Expired Msgs" (FUNCTION \LAFITE.DELETEEXPIRED) "Mark as deleted all of the messages that have passed their expiration dates." )) (SETQ LAFITEEXTRAMENU NIL) (SETQ LAFITEEXTRAMENUFLG T]) (MESSAGEAGE [LAMBDA (MSG TODAY YEAR ONEDAY) (* ; "Edited 22-Jun-89 11:46 by jtm:") (* ; "Edited 21-Sep-88 16:25 by jtm:") (LET (MSGDATE MSGTIME) [COND ((AND (fetch (LAFITEMSG DATEKNOWN?) of MSG) (SETQ MSGTIME (fetch (LAFITEMSG IDATE) of MSG))) (* ;; "new format: date already parsed.") NIL) ((SETQ MSGDATE (fetch (LAFITEMSG DATE) of MSG)) [OR TODAY (SETQ TODAY (IDATE (DATE] (OR YEAR (SETQ YEAR (SUBSTRING (DATE) 8 9))) [OR ONEDAY (SETQ ONEDAY (IDIFFERENCE (IDATE "2-Jan-80 12:00") (IDATE "1-Jan-80 12:00"] (SETQ MSGTIME (IDATE (CONCAT MSGDATE " " YEAR " 12:00"))) (COND ((AND MSGTIME (IGREATERP (IDIFFERENCE MSGTIME TODAY) ONEDAY)) (* a message from last year.) (SETQ MSGTIME (IDATE (CONCAT MSGDATE " " (SUB1 (MKATOM YEAR)) " 12:00"] (AND MSGTIME (QUOTIENT (IDIFFERENCE TODAY MSGTIME) ONEDAY]) ) (RPAQ? EXPIRATIONMENU NIL) (RPAQQ EXPIRATIONMENUITEMS (("now" T) ("one day" 1) ("two days" 2) ("four days" 3) ("one week" 4) ("two weeks" 5) ("one month" 6) ("two months" 7) ("four months" 8) ("eight months" 9) ("forever" 0))) (RPAQQ MARKDURATIONS ((1 1) (2 2) (3 4) (4 7) (5 14) (6 30) (7 61) (8 122) (9 244))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS EXPIRATIONMENU EXPIRATIONMENUITEMS MARKDURATIONS) ) (LTD.INIT) (DECLARE%: DONTCOPY (FILEMAP (NIL (878 8028 (\LAFITE.TIMEDDELETE 888 . 1162) (\LAFITE.SETEXPIRATIONS 1164 . 5544) ( \LAFITE.DELETEEXPIRED 5546 . 8026)) (8029 10260 (LTD.INIT 8039 . 8928) (MESSAGEAGE 8930 . 10258))))) STOP