-
-
Notifications
You must be signed in to change notification settings - Fork 24
/
Copy pathUNDIGESTIFY
318 lines (268 loc) · 16.7 KB
/
UNDIGESTIFY
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 3-Jun-2024 23:02:57" {WMEDLEY}<lispusers>UNDIGESTIFY.;5 16776
:EDIT-BY rmk
:CHANGES-TO (VARS UNDIGESTIFYCOMS)
:PREVIOUS-DATE " 3-Jun-2024 23:01:00" {WMEDLEY}<lispusers>UNDIGESTIFY.;4)
(PRETTYCOMPRINT UNDIGESTIFYCOMS)
(RPAQQ UNDIGESTIFYCOMS
((INITVARS *DELETE-DIGEST-FLAG* *MOVE-TO-FIRST-DIGEST-MESSAGE-FLAG* *DONT-UPDATE-HEADERS-FLAG*
SEPARATOR1 SEPARATOR2)
(FNS INSTALL-UNDIGESTIFY LAFITE-DISPLAY LAFITE-TRUNCATE-FILE LAFITE-UNDIGESTIFY MOVE-TO-EOL
OPEN-SPACE-IN-FILE PARSE-AND-MAYBE-MERGE-HEADER SKIP-EOLS BACKUP-PTR
TEDIT.FIND.NOT.CASELESS)
(DECLARE%: EVAL@COMPILE DONTCOPY (FILES LAFITE-DECLS))
(P (INSTALL-UNDIGESTIFY))))
(RPAQ? *DELETE-DIGEST-FLAG* NIL)
(RPAQ? *MOVE-TO-FIRST-DIGEST-MESSAGE-FLAG* NIL)
(RPAQ? *DONT-UPDATE-HEADERS-FLAG* NIL)
(RPAQ? SEPARATOR1 NIL)
(RPAQ? SEPARATOR2 NIL)
(DEFINEQ
(INSTALL-UNDIGESTIFY
[LAMBDA NIL (* ; "Edited 29-Jul-87 08:44 by Rao")
(* ;
"Put 'Undigest' on the browser menu after Display, if it isn't already there.")
(if (NOT (SASSOC "Undigest" LAFITEBROWSERMENUITEMS))
then (* ;
"Copy the list because the menus will share its structure.")
(SETQ LAFITEBROWSERMENUITEMS (COPY LAFITEBROWSERMENUITEMS))
(for ITEMS on LAFITEBROWSERMENUITEMS when (EQUAL "Forward" (CAAR ITEMS))
do (RPLACD ITEMS (CONS '("Undigest" 'LAFITE-UNDIGESTIFY
"Unpacks network digest into separate messages.")
(CDR ITEMS)))
(RETURN T)))
(* ;; "Update the width of the browser. Use the larger of the previous width and the minimum possible width, it case they like wide browsers.")
[AND (REGIONP LAFITEBROWSERREGION)
(replace (REGION WIDTH) of LAFITEBROWSERREGION
with (IMAX (fetch (REGION WIDTH) of LAFITEBROWSERREGION)
(fetch (REGION WIDTH)
of (WINDOWPROP (MENUWINDOW (create MENU
ITEMS _ LAFITEBROWSERMENUITEMS
CENTERFLG _ T
MENUFONT _ LAFITEMENUFONT))
'REGION]
(SETQ *DELETE-DIGEST-FLAG* T)
(SETQ *MOVE-TO-FIRST-DIGEST-MESSAGE-FLAG* NIL)
(SETQ *DONT-UPDATE-HEADERS-FLAG* NIL)
(SETQ SEPARATOR1 '"-----------------------------------------------------------------")
(SETQ SEPARATOR2 '"--------"])
(LAFITE-DISPLAY
[LAMBDA (WINDOW MAILFOLDER ITEM MENU KEY) (* SCB%: "26-Mar-86 10:44")
(COND
((EQ KEY 'LEFT)
(\LAFITE.DISPLAY WINDOW MAILFOLDER ITEM MENU KEY))
((EQ KEY 'MIDDLE)
(LAFITE-UNDIGESTIFY WINDOW MAILFOLDER ITEM MENU KEY])
(LAFITE-TRUNCATE-FILE
[LAMBDA (FILE LENGTH) (* SCB%: "30-Apr-86 14:24")
(* Truncate the folder. FILE is the filename, not a stream.
Returns T if we did the truncation.)
(CLOSEF? FILE)
(if (NEQ (GETFILEINFO FILE 'LENGTH)
LENGTH)
then (SETFILEINFO FILE 'LENGTH LENGTH)
T])
(LAFITE-UNDIGESTIFY
[LAMBDA (WINDOW MAILFOLDER ITEM MENU KEY) (* SCB%: "30-Apr-86 14:51")
(RESETLST
(LA.RESETSHADE ITEM MENU)
(PROG (REPORTWINDOW MSG1 MSGN MESSAGES DIGEST-MSG-DESC MESSAGE-STREAM MESSAGE-POSITIONS
DIGEST-HEADER-PARSE DIGEST-TO)
(SETQ REPORTWINDOW (fetch (MAILFOLDER BROWSERPROMPTWINDOW) of MAILFOLDER))
(SETQ MSG1 (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE) of MAILFOLDER))
(SETQ MSGN (fetch (MAILFOLDER LASTSELECTEDMESSAGE) of MAILFOLDER))
(CLEARW REPORTWINDOW)
(if (NOT (AND (NUMBERP MSG1)
(NUMBERP MSGN)
(IEQP MSG1 MSGN)))
then (PRINTOUT REPORTWINDOW "Must select a single message.")
else
(PRINTOUT REPORTWINDOW "Parsing digest... ")
(WITH.MONITOR
(fetch FOLDERLOCK of MAILFOLDER)
(SETQ DIGEST-MSG-DESC (NTHMESSAGE (SETQ MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS)
of MAILFOLDER))
MSG1))
(LA.COPY.MESSAGE.TEXT MAILFOLDER (SETQ MESSAGE-STREAM (OPENTEXTSTREAM))
DIGEST-MSG-DESC)
(SETQ DIGEST-HEADER-PARSE (LAFITE.PARSE.HEADER MESSAGE-STREAM \LAPARSE.FULL 0 -1 NIL T)
)
(SETQ DIGEST-TO (CADR (ASSOC 'To DIGEST-HEADER-PARSE)))
(* Parse the digest, looking for the separators between each submessage.)
(PROG (TEXTOBJ MSGS L1 L2 P1 P2 P3)
(SETQ TEXTOBJ (TEXTOBJ MESSAGE-STREAM))
(SETQ MSGS NIL)
(SETQ L1 (NCHARS SEPARATOR1))
(SETQ L2 (NCHARS SEPARATOR2))
(SETQ P1 (TEDIT.FIND.NOT.CASELESS TEXTOBJ SEPARATOR1 1))
(if (NULL P1)
then (PRINTOUT REPORTWINDOW "Can't find first separator.")
(GO ERROR))
[SETQ P1 (SKIP-EOLS MESSAGE-STREAM (MOVE-TO-EOL MESSAGE-STREAM (IPLUS P1 L1]
(if (EQ 'ERROR (PARSE-AND-MAYBE-MERGE-HEADER MESSAGE-STREAM P1 (IPLUS P1 1000)
DIGEST-TO))
then (PRINTOUT REPORTWINDOW "Can't parse header of digest message #1")
(GO ERROR))
(SETQ P2 P1)
(* P1 points to the beginning of the message.
P2 points to the separator that might end the message.
P3 points to the beginning of the next message's header.)
(until (NULL (SETQ P2 (TEDIT.FIND.NOT.CASELESS TEXTOBJ SEPARATOR2 P2)))
do [SETQ P3 (SKIP-EOLS MESSAGE-STREAM (MOVE-TO-EOL MESSAGE-STREAM
(IPLUS P2 L2]
(if (EQ 'ERROR (PARSE-AND-MAYBE-MERGE-HEADER MESSAGE-STREAM P3
(IPLUS P3 1000)
DIGEST-TO))
then (SETQ P2 P3) (* Keep looking for end of message.)
else
(* Message ends at char just before P2 because of TEDIT.FIND.NOT.CASELESS)
(push MSGS (LIST P1 (SUB1 P2)))
(SETQ P1 P3)
(SETQ P2 P3)))
(* We're allowed to throw away up to 50 characters at the end of the message.)
[if (IGEQ (IDIFFERENCE (GETEOFPTR MESSAGE-STREAM)
P1)
50)
then (push MSGS (LIST P1 (GETEOFPTR MESSAGE-STREAM]
(SETQ MESSAGE-POSITIONS (DREVERSE MSGS))
(RETURN)
ERROR
(SETQ MESSAGE-POSITIONS 'ERROR)
(RETURN))
(if (EQ 'ERROR MESSAGE-POSITIONS)
then (PRINTOUT REPORTWINDOW " Aborted.")
else (PROG (OUTSTREAM BEGIN MSG-DESC MSG-START MSG-END NEW-MESSAGE-DESCRIPTORS)
(SETQ OUTSTREAM (\LAFITE.OPEN.FOLDER MAILFOLDER 'OUTPUT))
(* Protect against the user typing an interrupt char while we're writing to the
mailfolder.)
[RESETSAVE NIL `(AND RESETSTATE (LAFITE-TRUNCATE-FILE
',(fetch (MAILFOLDER
VERSIONLESSFOLDERNAME)
of MAILFOLDER)
',(fetch (MAILFOLDER FOLDEREOFPTR)
of MAILFOLDER]
(SETFILEPTR OUTSTREAM -1)
[COND
((NOT (IEQP (SETQ BEGIN (GETFILEPTR OUTSTREAM))
(fetch FOLDEREOFPTR of MAILFOLDER)))
(RETURN (HELP "Folder inconsistent with browser"]
(SETQ NEW-MESSAGE-DESCRIPTORS NIL)
(for MSG-POS in MESSAGE-POSITIONS
do (SETQ MSG-START (CAR MSG-POS))
(SETQ MSG-END (CADR MSG-POS))
[SETQ MSG-DESC
(create LAFITEMSG
BEGIN _ BEGIN
SEEN? _ NIL
MARKCHAR _ UNSEENMARK
STAMPLENGTH _ LAFITESTAMPLENGTH
MESSAGELENGTH _ (SETQ LEN (IPLUS LAFITESTAMPLENGTH
(IDIFFERENCE MSG-END
MSG-START]
(push NEW-MESSAGE-DESCRIPTORS MSG-DESC)
(SETQ BEGIN (IPLUS BEGIN LEN))
(LA.PRINTSTAMP OUTSTREAM)
(LA.PRINTCOUNT LEN OUTSTREAM)
(LA.PRINTCOUNT LAFITESTAMPLENGTH OUTSTREAM)
(BOUT OUTSTREAM UNDELETEDFLAG)
(BOUT OUTSTREAM SEENFLAG)
(BOUT OUTSTREAM SEENMARK)
(BOUT OUTSTREAM (CHARCODE CR))
(COPYBYTES MESSAGE-STREAM OUTSTREAM MSG-START MSG-END))
(LAB.APPENDMESSAGES MAILFOLDER (SETQ NEW-MESSAGE-DESCRIPTORS (DREVERSE
NEW-MESSAGE-DESCRIPTORS
)))
(SEENMESSAGE DIGEST-MSG-DESC MAILFOLDER)
(if *DELETE-DIGEST-FLAG*
then (DELETEMESSAGE DIGEST-MSG-DESC MAILFOLDER))
[if *MOVE-TO-FIRST-DIGEST-MESSAGE-FLAG*
then (UNSELECTALLMESSAGES MAILFOLDER)
(SELECTMESSAGE (CAR NEW-MESSAGE-DESCRIPTORS)
MAILFOLDER)
(LAB.EXPOSEMESSAGE MAILFOLDER (CAR NEW-MESSAGE-DESCRIPTORS))
else
(* Treat digest message as if it had been displayed, and move to next undeleted
message.)
(for N from (ADD1 MSG1) to (fetch (MAILFOLDER %#OFMESSAGES)
of MAILFOLDER)
do (if [NOT (fetch (LAFITEMSG DELETED?)
of (SETQ MSG-DESC (NTHMESSAGE MESSAGES N]
then (LA.SHOW.SELECTION MAILFOLDER DIGEST-MSG-DESC
'ERASE)
(LA.SHOW.SELECTION MAILFOLDER MSG-DESC 'REPLACE)
(replace (LAFITEMSG SELECTED?) of DIGEST-MSG-DESC
with NIL)
(replace (LAFITEMSG SELECTED?) of MSG-DESC
with T)
(replace FIRSTSELECTEDMESSAGE of MAILFOLDER
with N)
(replace LASTSELECTEDMESSAGE of MAILFOLDER
with N)
(RETURN]
(PRINTOUT REPORTWINDOW " done. "])
(MOVE-TO-EOL
[LAMBDA (TEXTSTREAM POSITION) (* SCB%: "27-Mar-86 10:34")
(* POSITION points into a line. Return the position immediately following the
CR at the end of this line, i.e., the first char on the next line.)
(AND POSITION (SETFILEPTR TEXTSTREAM POSITION))
(until (IEQP (CHARCODE CR)
(\BIN TEXTSTREAM)) do)
(GETFILEPTR TEXTSTREAM])
(OPEN-SPACE-IN-FILE
[LAMBDA (FILE POSITION NCHARS) (* ; "Edited 24-Sep-2023 14:25 by rmk")
(* SCB%: "25-Mar-86 12:52")
(* ;;
"Open a space in file starting at POSITION for length NCHARS by sliding the rest of the file down.")
(* Open a space in file starting at POSITION for length NCHARS by sliding the
rest of the file down.)
(LET [(TEMP (OPENSTREAM '{NODIRCORE} 'BOTH]
(COPYBYTES FILE TEMP POSITION (GETEOFPTR FILE))
(SETFILEPTR FILE (IPLUS POSITION NCHARS))
(SETFILEPTR TEMP 0)
(COPYBYTES TEMP FILE)
(CLOSEF? TEMP])
(PARSE-AND-MAYBE-MERGE-HEADER
[LAMBDA (MESSAGE-STREAM P1 P2 DIGEST-TO) (* SCB%: "14-Apr-86 12:31")
(PROG (MSG-HEADER-PARSE END-OF-HEADER STRING CR)
(SETQ MSG-HEADER-PARSE (LAFITE.PARSE.HEADER MESSAGE-STREAM \LAPARSE.FULL P1 P2 NIL T))
(if (NULL (CDR MSG-HEADER-PARSE))
then (* Nothing in the header, probably not
a legal message.)
(RETURN 'ERROR))
(if *DONT-UPDATE-HEADERS-FLAG*
then (RETURN P2))
(SETQ END-OF-HEADER (CADR (ASSOC 'EOF MSG-HEADER-PARSE)))
(if (NULL (ASSOC 'To MSG-HEADER-PARSE))
then (TEDIT.INSERT MESSAGE-STREAM (SETQ STRING (CONCAT (SETQ CR (CHARACTER (CHARCODE
CR)))
"To: " DIGEST-TO CR))
END-OF-HEADER)
(add END-OF-HEADER (NCHARS STRING))
(add P2 (NCHARS STRING)))
(RETURN P2])
(SKIP-EOLS
[LAMBDA (TEXTSTREAM POSITION) (* SCB%: "27-Mar-86 10:35")
(AND POSITION (SETFILEPTR TEXTSTREAM POSITION))
(until (NOT (IEQP (CHARCODE CR)
(\BIN TEXTSTREAM))) do)
(SETFILEPTR TEXTSTREAM (SUB1 (GETFILEPTR TEXTSTREAM])
(BACKUP-PTR
[LAMBDA (STREAM) (* SCB%: "27-Mar-86 10:20")
(SETFILEPTR STREAM (SUB1 (GETFILEPTR STREAM])
(TEDIT.FIND.NOT.CASELESS
[LAMBDA (TEXTOBJ TARGETSTRING START# END# WILDCARDS?) (* SCB%: " 9-Apr-86 13:53")
(* This function exists because you might be using Shrager's caseless search in
TEdit.)
(LET ((TEDIT%:*CASE-FOLD-SEARCH-P* NIL))
(TEDIT.FIND TEXTOBJ TARGETSTRING START# END# WILDCARDS?])
)
(DECLARE%: EVAL@COMPILE DONTCOPY
(FILESLOAD LAFITE-DECLS)
)
(INSTALL-UNDIGESTIFY)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1016 16664 (INSTALL-UNDIGESTIFY 1026 . 3039) (LAFITE-DISPLAY 3041 . 3340) (
LAFITE-TRUNCATE-FILE 3342 . 3753) (LAFITE-UNDIGESTIFY 3755 . 13411) (MOVE-TO-EOL 13413 . 13873) (
OPEN-SPACE-IN-FILE 13875 . 14595) (PARSE-AND-MAYBE-MERGE-HEADER 14597 . 15817) (SKIP-EOLS 15819 .
16130) (BACKUP-PTR 16132 . 16294) (TEDIT.FIND.NOT.CASELESS 16296 . 16662)))))
STOP