-
-
Notifications
You must be signed in to change notification settings - Fork 24
/
Copy pathDATESORT
196 lines (173 loc) · 9.38 KB
/
DATESORT
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
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "25-Feb-88 18:29:26" |{NEWTON:EUROPARC:RX}<MACLEAN>LISP>DATESORT.;2| 9298
previous date%: "11-Jun-87 10:15:34" |{NEWTON:EUROPARC:RX}<MACLEAN>LISP>DATESORT.;1|)
(* "
Copyright (c) 1986, 1987, 1988 by XEROX Corporation. All rights reserved.
")
(PRETTYCOMPRINT DATESORTCOMS)
(RPAQQ DATESORTCOMS ((UGLYVARS RQIREADTABLE)
(FNS DATESORTER COMPAREDATE COMPAREDATE2 FIXNAME GETRF GETFTS DATESORT GETDATE
GETINFORMATION CORRECTDATE MAKEFINALFILE)
(ADDVARS (BackgroundMenuCommands ("Date Sorter" '(DATESORTER)
"Sort a Mail file by date")))
(VARS (BackgroundMenu)
(DEFAULTDATESORT NIL))))
(READVAR-FROM-STRING 'RQIREADTABLE "{D(9 10 11 25 31 32 39 44 63 96 124)OTHER OTHER SEPRCHAR (MACRO FIRST (LAMBDA (FILE RDTBL) (EVAL
(READ FILE RDTBL)))) OTHER OTHER (MACRO FIRST READ') (MACRO FIRST READBQUOTECOMMA) (INFIX FIRST
NOESCQUOTE DO?) (MACRO FIRST READBQUOTE) (INFIX ALWAYS READVBAR) }
")
(DEFINEQ
(DATESORTER
[LAMBDA NIL (* edited%: "28-Jan-86 11:24")
(ADD.PROCESS '(DATESORT) 'NAME 'DATESORTER 'INFOHOOK '(PROMPTPRINT
"This is the Mail Date Sorter process"
"Killing this process may leave open files, so make sure to close them"
" and erase the files in {CORE}"])
(COMPAREDATE
[LAMBDA (A B) (* edited%: "21-Jan-86 15:57")
(PROG NIL
(RETURN (OR (NOT (IDATE (CAR B)))
(AND (IDATE (CAR A))
(ILESSP (IDATE (CAR A))
(IDATE (CAR B])
(COMPAREDATE2
[LAMBDA (A B) (* edited%: "23-Jan-86 17:45")
(PROG NIL
(RETURN (OR (NOT (IDATE (CAR A)))
(AND (IDATE (CAR B))
(ILESSP (IDATE (CAR A))
(IDATE (CAR B])
(FIXNAME
[LAMBDA (NAMETOFIX RVFLG) (* edited%: "23-Jan-86 14:43")
(PROG NIL
(RETURN (PACKFILENAME (if (MEMB 'EXTENSION (UNPACKFILENAME NAMETOFIX))
then [if RVFLG
then (UNPACKFILENAME NAMETOFIX)
else (for X in (UNPACKFILENAME NAMETOFIX) collect X
until (EQUAL X 'VERSION]
else (if RVFLG
then (APPEND (UNPACKFILENAME NAMETOFIX)
'(EXTENSION MAIL))
else (for X in (APPEND (UNPACKFILENAME NAMETOFIX)
'(EXTENSION MAIL)) collect X
until (EQUAL X 'VERSION])
(GETRF
[LAMBDA (RF FTS) (* edited%: "23-Jan-86 15:04")
(PROG NIL
(SETQ FTS (FULLNAME (FIXNAME FTS)
'NEW))
(if (NOT RF)
then (SETQ RF (MKATOM (PROMPTFORWORD "Enter name of resulting file: " FTS)))
(TERPRI T))
(if [AND RF (SETQ RF (FULLNAME (FIXNAME RF)
'NEW]
then (RETURN RF)
else (RETURN])
(GETFTS
[LAMBDA (FTS) (* edited%: "23-Jan-86 15:05")
(PROG NIL
(if (NOT FTS)
then (SETQ FTS (MKATOM (PROMPTFORWORD "Enter name of file to be sorted: ")))
(TERPRI T))
(if [AND FTS (SETQ FTS (FULLNAME (FIXNAME FTS T]
then (RETURN FTS)
else (RETURN])
(DATESORT
[LAMBDA (FILETOSORT SORTEDFILE) (* edited%: "23-Jan-86 17:48")
(PROG (COREFILE FILEINFO RESULTS)
(CLRPROMPT) (* Code to check the filenames and
error if problems!!)
(if (SETQ FILETOSORT (GETFTS FILETOSORT))
then (if (NOT (SETQ SORTEDFILE (GETRF SORTEDFILE FILETOSORT)))
then (PRINTOUT PROMPTWINDOW "Error, no file to sort to ...aborted!" T)
(FLASHWINDOW)
(RETURN (CLOSEW T)))
else (PRINTOUT PROMPTWINDOW "Error, no file to sort or file not found " FILETOSORT
" ...aborted!" T)
(FLASHWINDOW)
(RETURN (CLOSEW T))) (* Error on file being open -
FATAL)
(if (OPENP FILETOSORT)
then (PRINTOUT PROMPTWINDOW "File to be sorted is already open ...aborted" T)
(FLASHWINDOW)
(RETURN (CLOSEW T)))
(PRINTOUT T "Working ..." T)
(SETQ COREFILE (COPYFILE FILETOSORT '{CORE}DATESORT.SCRATCH))
(SETQ COREFILE (OPENSTREAM COREFILE 'INPUT 'OLD))
(SETQ FILEINFO (GETINFORMATION COREFILE))
(CLOSEF COREFILE)
(DELFILE COREFILE)
(if DEFAULTDATESORT
then (SORT FILEINFO 'COMPAREDATE)
else (SORT FILEINFO 'COMPAREDATE2))
(BLOCK)
(SETQ RESULTS (MAKEFINALFILE FILETOSORT SORTEDFILE FILEINFO))
(if RESULTS
then (PRINTOUT PROMPTWINDOW " Messages sorted" T)
(FLASHWINDOW PROMPTWINDOW)
(CLOSEW T)
(RETURN SORTEDFILE)
else (PRINTOUT PROMPTWINDOW "Errors...")
(FLASHWINDOW)
(CLOSEW T)
(RETURN "Errors..."])
(GETDATE
[LAMBDA (GDFIL GDBEG GDNEXT) (* edited%: "22-Jan-86 10:25")
(PROG NIL
(SETFILEPTR GDFIL (FFILEPOS "DATE: " GDFIL GDBEG GDNEXT NIL NIL UPPERCASEARRAY))
(RSTRING GDFIL)
(RETURN (RSTRING GDFIL RQIREADTABLE])
(GETINFORMATION
[LAMBDA (SFIL) (* edited%: "23-Jan-86 17:20")
(* Will return a list consisting of the Message number and the information
about it.)
(PROG ((CURRENTSTART (FFILEPOS "*start*" SFIL 0))
(NEXTSTART 0)
(MSGCOUNT 0)
INFO)
(repeatwhile (SETQ CURRENTSTART NEXTSTART)
do (SETQ NEXTSTART (FFILEPOS "*start*" SFIL (ADD1 CURRENTSTART)))
[SETQ INFO (APPEND INFO (LIST (LIST (GETDATE SFIL CURRENTSTART NEXTSTART)
CURRENTSTART NEXTSTART]
(BLOCK))
[SETQ INFO (for X in INFO collect (APPEND (LIST (CORRECTDATE (CAR X)))
(CDR X]
(* fixes bug when a date is of the form Wed 16 Dec...)
(RETURN INFO])
(CORRECTDATE
[LAMBDA (DATETOFIX) (* edited%: "22-Jan-86 09:52")
(PROG (TEMP)
(if (IDATE DATETOFIX)
then (RETURN DATETOFIX)
else (SETQ TEMP (GNC DATETOFIX))
(until (NUMBERP TEMP) do (SETQ TEMP (GNC DATETOFIX)))
(RETURN (CONCAT TEMP DATETOFIX])
(MAKEFINALFILE
[LAMBDA (FROMFILE TOFILE DATESLIST) (* edited%: "23-Jan-86 17:27")
(PROG (ENDOFMSG)
(if (OR (OPENP FROMFILE)
(OPENP TOFILE))
then (PRINTOUT PROMPTWINDOW "File open in conflicting way ... aborted" T)
(FLASHWINDOW)
(RETURN))
(SETQ FROMFILE (OPENSTREAM FROMFILE 'INPUT 'OLD))
(SETQ TOFILE (OPENSTREAM TOFILE 'OUTPUT 'NEW))
(for X in DATESLIST do (if (SETQ ENDOFMSG (CADDR X))
then (COPYBYTES FROMFILE TOFILE (CADR X)
ENDOFMSG)
else (COPYBYTES FROMFILE TOFILE (CADR X)
(GETEOFPTR FROMFILE)))
(BLOCK))
(CLOSEF TOFILE)
(CLOSEF FROMFILE)
(RETURN TOFILE])
)
(ADDTOVAR BackgroundMenuCommands ("Date Sorter" '(DATESORTER) "Sort a Mail file by date"))
(RPAQQ BackgroundMenu NIL)
(RPAQQ DEFAULTDATESORT NIL)
(PUTPROPS DATESORT COPYRIGHT ("XEROX Corporation" 1986 1987 1988))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1178 9047 (DATESORTER 1188 . 1685) (COMPAREDATE 1687 . 2005) (COMPAREDATE2 2007 . 2326)
(FIXNAME 2328 . 3366) (GETRF 3368 . 3899) (GETFTS 3901 . 4314) (DATESORT 4316 . 6418) (GETDATE 6420
. 6711) (GETINFORMATION 6713 . 7676) (CORRECTDATE 7678 . 8067) (MAKEFINALFILE 8069 . 9045)))))
STOP