(FILECREATED "20-Jun-88 10:24:35" {QV}<MAXWELL>LISP>LAFITETIMEDDELETE.;2 7004
changes to: (VARS LAFITETIMEDDELETECOMS)
previous date: "15-Oct-87 09:27:55" {QV}<MAXWELL>LISP>LAFITETIMEDDELETE.;1)
(* Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT LAFITETIMEDDELETECOMS)
(RPAQQ LAFITETIMEDDELETECOMS ((FILES LAFITEFIND)
(FNS \LAFITE.TIMEDDELETE \LAFITE.SETEXPIRATIONS \LAFITE.DELETEEXPIRED)
(FNS LTD.INIT MESSAGEAGE)
(INITVARS EXPIRATIONMENU)
(VARS EXPIRATIONMENUITEMS MARKDURATIONS)
(P (LTD.INIT))))
(FILESLOAD LAFITEFIND)
(DEFINEQ
(\LAFITE.TIMEDDELETE
[LAMBDA (WINDOW MAILFOLDER ITEM MENU KEY) (* jtm: "30-Sep-87 14:25")
(COND
((EQ KEY (QUOTE MIDDLE))
(\LAFITE.SETEXPIRATIONS WINDOW MAILFOLDER ITEM MENU))
(T (\LAFITE.DELETE WINDOW MAILFOLDER ITEM MENU])
(\LAFITE.SETEXPIRATIONS
[LAMBDA (WINDOW MAILFOLDER ITEM MENU) (* jtm: "15-Oct-87 09:27")
(WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER)
(LET (EXPIRATION DURATION MSGDURATION MSGEXPIRATION TODAY YEAR ONEDAY (N 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))
(T (SETQ MSGDURATION (IPLUS DURATION
(MESSAGEAGE MSG TODAY YEAR
ONEDAY)))
(SETQ MSGEXPIRATION
(OR [CAR (for ITEM in MARKDURATIONS
thereis (ILEQ MSGDURATION
(CADR ITEM]
9))
(MARKMESSAGE MSG MAILFOLDER (IPLUS 48 MSGEXPIRATION]
(add N 1]
(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 "No expiration date selected."])
(\LAFITE.DELETEEXPIRED
[LAMBDA (MAILFOLDER) (* jtm: "30-Sep-87 16:41")
(LET (MESSAGES LASTMSG# YEAR TODAY ONEDAY (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
((AND DURATION (IGEQ MSGAGE DURATION))
(DELETEMESSAGE MSG MAILFOLDER)
(add N 1]
(LAB.PROMPTPRINT MAILFOLDER T (CONCAT N " expired messages deleted."])
)
(DEFINEQ
(LTD.INIT
[LAMBDA NIL (* jtm: "30-Sep-87 16:44")
(LET (DELETEMENUITEM)
(COND
((SETQ DELETEMENUITEM (SASSOC "Delete" LAFITEBROWSERMENUITEMS))
(RPLACA (CDR DELETEMENUITEM)
(QUOTE (QUOTE \LAFITE.TIMEDDELETE)))
(COND
((NOT (SASSOC "Delete Expired Msgs" LAFITEEXTRAMENUITEMS))
(push LAFITEEXTRAMENUITEMS (QUOTE ("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) (* jtm: "15-Oct-87 09:25")
(LET (MSGDATE MSGTIME)
(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
((IGREATERP (IDIFFERENCE MSGTIME TODAY)
ONEDAY) (* a message from last year.)
(SETQ MSGTIME (IDATE (CONCAT MSGDATE " " (SUB1 (MKATOM YEAR))
" 12:00"]
(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)))
(LTD.INIT)
(PUTPROPS LAFITETIMEDDELETE COPYRIGHT ("Xerox Corporation" 1987 1988))
(DECLARE: DONTCOPY
(FILEMAP (NIL (611 4869 (\LAFITE.TIMEDDELETE 621 . 908) (\LAFITE.SETEXPIRATIONS 910 . 3583) (
\LAFITE.DELETEEXPIRED 3585 . 4867)) (4870 6459 (LTD.INIT 4880 . 5586) (MESSAGEAGE 5588 . 6457)))))
STOP