-
-
Notifications
You must be signed in to change notification settings - Fork 25
/
Copy pathCOMPAREDIRECTORIES
2274 lines (1910 loc) · 132 KB
/
COMPAREDIRECTORIES
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
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "26-Mar-2025 09:41:31" {WMEDLEY}<lispusers>COMPAREDIRECTORIES.;267 133447
:EDIT-BY rmk
:CHANGES-TO (VARS COMPAREDIRECTORIESCOMS)
(FNS CD-MENUFN)
:PREVIOUS-DATE "18-Feb-2025 23:37:14" {WMEDLEY}<lispusers>COMPAREDIRECTORIES.;264)
(PRETTYCOMPRINT COMPAREDIRECTORIESCOMS)
(RPAQQ COMPAREDIRECTORIESCOMS
[
(* ;; "Compare the contents of two directories.")
(FILES (SYSLOAD)
PDFSTREAM)
(FNS COMPAREDIRECTORIES COMPAREDIRECTORIES.INFOS COMPAREDIRECTORIES.CANDIDATES
CDENTRIES.SELECT COMPAREDIRECTORIES.INFOS.TYPE MATCHNAME CD.INSURECDVALUE
CD.UPDATEWIDTHS)
(FNS CDFILES CDFILES.MATCH CDFILES.PATS)
(FNS CDPRINT CDPRINT.HEADER CDPRINT.LINE CDPRINT.MAXWIDTHS CDPRINT.COLHEADERS CDPRINT.COLUMNS
CDTEDIT)
(FNS CDMAP CDENTRY CDSUBSET CDMERGE CDMERGE.COMMON CD.SORT)
(FNS BINCOMP EOLTYPE EOLTYPE.SHOW)
(RECORDS CDMAXNCHARS CDVALUE CDENTRY CDINFO)
(* ;; "look for compiled files older than the sources")
(FNS FIND-UNCOMPILED-FILES FIND-UNSOURCED-FILES FIND-SOURCE-FILES FIND-COMPILED-FILES
FIND-UNLOADED-FILES FIND-LOADED-FILES FIND-MULTICOMPILED-FILES)
(FNS CREATED-AS SOURCE-FOR-COMPILED-P COMPILE-SOURCE-DATE-DIFF)
(FNS FIX-DIRECTORY-DATES FIX-EQUIV-DATES COPY-COMPARED-FILES COPY-MISSING-FILES
COMPILED-ON-SAME-SOURCE)
[VARS (ONESECOND (IDIFFERENCE (IDATE "1-Jan-2020 12:00:01")
(IDATE "1-Jan-2020 12:00:00"]
(INITVARS (LASTCDVALUE NIL))
(* ;; "Compare-directories browser")
(COMS (FNS CDBROWSER CDBROWSER.STRINGS)
(* ;; "TABLEBROWSER browser")
(FILES (SYSLOAD)
TABLEBROWSER)
(DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
TABLEBROWSER))
(FNS CD.TABLEITEM CD.TABLEITEM.PRINTFN CD.TABLEITEM.COPYFN
CDTABLEBROWSER.HEADING.REPAINTFN)
(FNS CDTABLEBROWSER.WHENSELECTEDFN CD.COMMANDSELECTEDFN CD-MENUFN CD-COMPARE-FILES
CDBROWSER-COPY CDBROWSER-DELETE-FILE CD-SWAPDIRS)
(INITVARS (CD-LINELENGTH NIL))
(VARS CDTABLEBROWSER.MENUITEMS)
(FILES (SYSLOAD)
COMPARESOURCES COMPARETEXT)
(P (MOVD? 'NILL 'TEDIT.FILEDATE])
(* ;; "Compare the contents of two directories.")
(FILESLOAD (SYSLOAD)
PDFSTREAM)
(DEFINEQ
(COMPAREDIRECTORIES
[LAMBDA (DIR1 DIR2 SELECT INCLUDEDFILES EXCLUDEDFILES USEDIRECTORYDATE OUTPUTFILE ALLVERSIONS
FIXDIRECTORYDATES SHORTDIRNAMES) (* ; "Edited 1-May-2024 14:52 by rmk")
(* ; "Edited 29-Sep-2023 17:25 by rmk")
(* ; "Edited 5-Apr-2023 10:12 by rmk")
(* ; "Edited 29-Mar-2022 11:50 by rmk")
(* ; "Edited 23-Feb-2022 21:10 by rmk")
(* ; "Edited 4-Jan-2022 12:09 by rmk")
(* ; "Edited 31-Oct-2021 11:01 by rmk:")
(* ; "Edited 7-Jan-2021 23:21 by rmk:")
(* ;; "Compare the contents of two directories, e.g., for change-control purposes. Compares files matching FILEPATTERN (or *.*;) on DIR1 and DIR2, listing which is newer, or when one is not found on the other. If SELECT is or contains SAME/=, BEFORE/<, AFTER/>, then files where DIR1 is the same as, earlier than, or later than DIR2 are selected. SELECT= NIL is the same as (< >), T is the same as (< > =). Also allows selection based on file-length criteria.")
(* ;; "")
(* ;; "Unless USEDIRECTORYDATE, comparison is with respect to the the LISP filecreated dates if evailable.")
(* ;; "")
(* ;; "If OUTPUTFILE is NIL, the list of compared entries is returned. Otherwise the selected entries are printed on OUTPUTFILE (T for the display).")
[SETQ SELECT (SELECTQ SELECT
(NIL '(< > -* *-))
(T '(< > -* *- =))
(for S in (MKLIST SELECT) collect (SELECTQ S
((AFTER >)
'>)
((BEFORE <)
'<)
((SAME SAMEDATE =)
'=)
(AUTHOR 'AUTHOR)
(-* '-*)
(*- '*-)
(~= '~=)
(ERROR "UNRECOGNIZED SELECT PARAMETER" S]
(PROG (INFOS1 INFOS2 CDENTRIES DEPTH1 DEPTH2 CDVALUE (DATE (DATE)))
(* ;; "DIRECTORYNAME here to get unrelativized specifications for header.")
(* ;; "Allow all subdirectories if a directory ends in *, but peel it off for the resolution")
(CL:WHEN (EQ '* (NTHCHAR DIR1 -1))
(SETQ DEPTH1 T)
(SETQ DIR1 (SUBSTRING DIR1 1 -2)))
(CL:WHEN (EQ '* (NTHCHAR DIR2 -1))
(SETQ DEPTH2 T)
(SETQ DIR2 (SUBSTRING DIR2 1 -2)))
(SETQ DIR1 (OR (DIRECTORYNAME (OR DIR1 T))
DIR1))
(SETQ DIR2 (OR (DIRECTORYNAME (OR DIR2 T))
DIR2))
(CL:WHEN FIXDIRECTORYDATES
(PRINTOUT T "Fixing directory dates" T)
(FIX-DIRECTORY-DATES DIR1)
(FIX-DIRECTORY-DATES DIR2))
(CDPRINT.HEADER (OR (CAR SHORTDIRNAMES)
DIR1)
(OR (CADR SHORTDIRNAMES)
DIR2)
SELECT DATE T)
(PRINTOUT T " ... ")
(SETQ INFOS1 (COMPAREDIRECTORIES.INFOS DIR1 INCLUDEDFILES EXCLUDEDFILES ALLVERSIONS DEPTH1
USEDIRECTORYDATE (MEMB 'AUTHOR SELECT)))
(SETQ INFOS2 (COMPAREDIRECTORIES.INFOS DIR2 INCLUDEDFILES EXCLUDEDFILES ALLVERSIONS DEPTH2
USEDIRECTORYDATE))
(* ;; "The CAR of each info is the atomic match-name, the CDR is a list of infos with that matchname, only 1 unless AllVERSIONS. ")
(SETQ CDVALUE (CREATE CDVALUE
CDDIR1 _ DIR1
CDDIR2 _ DIR2
CDCOMPAREDATE _ DATE
CDSELECT _ SELECT))
(CL:UNLESS (OR INFOS2 INFOS1)
(RETURN CDVALUE))
(* ;; "Correlate the I1's and I2's with the same match name, then do the select filtering and insert the date relations")
(SETQ CDENTRIES (SORT (CDENTRIES.SELECT (COMPAREDIRECTORIES.CANDIDATES INFOS1 INFOS2)
SELECT)
(FUNCTION CD.SORT)))
(PRINTOUT T (LENGTH CDENTRIES)
" entries" T)
(REPLACE CDENTRIES OF CDVALUE WITH CDENTRIES)
(CD.UPDATEWIDTHS CDVALUE)
(SETQ LASTCDVALUE CDVALUE)
(CL:UNLESS OUTPUTFILE (RETURN CDVALUE))
(RETURN (CDPRINT CDVALUE OUTPUTFILE NIL (MEMB 'AUTHOR SELECT])
(COMPAREDIRECTORIES.INFOS
[LAMBDA (DIR INCLUDEDFILES EXCLUDEDFILES ALLVERSIONS DEPTH USEDIRECTORYDATE INCLUDEAUTHOR)
(* ;; "Edited 29-Sep-2023 17:25 by rmk")
(* ;; "Edited 22-May-2022 14:17 by rmk")
(* ;; "Edited 29-Mar-2022 11:53 by rmk: Produces a list of CDINFOS with the match-name consed on to the front.")
(* ;; "Each entry is a list of the form (matchname . CDINFOS). CDINFOS is guaranteed to be a singleton, unless ALLVERSIONS. ")
(FOR FULLNAME TYPE LDATE STREAM (STARTPOS _ (ADD1 (NCHARS DIR)))
IN (CDFILES DIR INCLUDEDFILES EXCLUDEDFILES ALLVERSIONS DEPTH)
COLLECT
(* ;; "GDATE/IDATE in case Y2K")
(SETQ STREAM (OPENSTREAM FULLNAME 'INPUT)) (* ;
"So all the GETFILEINFO's, FILEDATES, etc. don't have to do the directory searching.")
(* ;
"Is it a Lisp file? Get it's internal filecreated date. ")
(CL:MULTIPLE-VALUE-SETQ (TYPE LDATE)
(COMPAREDIRECTORIES.INFOS.TYPE STREAM))
(PROG1 (LIST (MATCHNAME FULLNAME STARTPOS)
(CREATE CDINFO
FULLNAME _ (FULLNAME STREAM)
DATE _ (GDATE (IDATE (IF (OR USEDIRECTORYDATE (NULL LDATE))
THEN (GETFILEINFO STREAM 'CREATIONDATE)
ELSE (SETFILEINFO STREAM 'CREATIONDATE LDATE)
LDATE)))
LENGTH _ (GETFILEINFO STREAM 'LENGTH)
AUTHOR _ (AND INCLUDEAUTHOR (GETFILEINFO STREAM 'AUTHOR))
TYPE _ TYPE
EOL _ (EOLTYPE STREAM)))
(CLOSEF? STREAM))
FINALLY
(* ;; "Sort to get all entries with the same matchname adjacent. Presumably we would only need to collect multiples if ALLVERSIONS, but in a case-sensitive file system we might see files with names that differ in case. We have deliberately given them a case-insensitive matchname, so we can expose this issue in the display.")
(* ;; "If we see (MN X)(MN Y), smash the Y in after the X")
(RETURN (FOR ITAIL I VAL MN ON (SORT $$VAL T)
DO (SETQ I (CAR ITAIL))
(SETQ MN (CAR I))
[WHILE (EQ MN (CAADR ITAIL)) DO (POP ITAIL)
(PUSH (CDR I)
(CADR (CAR ITAIL]
(PUSH VAL I) FINALLY (RETURN (DREVERSE VAL])
(COMPAREDIRECTORIES.CANDIDATES
[LAMBDA (INFOS1 INFOS2)
(* ;; "Edited 24-Feb-2022 10:00 by rmk: Correlate the I1's and I2's with the same match name. Rely on the fact that the lists are sorted.")
(SETQ INFOS1 (SORT INFOS1 T))
(SETQ INFOS2 (SORT INFOS2 T))
(LET (PAIRS)
(BIND I1 I2 (I1TAIL _ INFOS1)
(I2TAIL _ INFOS2) DO (IF (AND I1TAIL I2TAIL)
THEN (SETQ I1 (CAR I1TAIL))
(SETQ I2 (CAR I2TAIL))
(IF (EQ (CAR I1)
(CAR I2))
THEN (PUSH PAIRS (LIST (CAR I1)
(CDR I1)
(CDR I2)))
(POP I1TAIL)
(POP I2TAIL)
ELSEIF (ALPHORDER (CAR I1)
(CAR I2))
THEN (PUSH PAIRS (LIST (CAR I1)
(CDR I1)
(CONS NIL)))
(POP I1TAIL)
ELSE (PUSH PAIRS (LIST (CAR I2)
(CONS NIL)
(CDR I2)))
(POP I2TAIL))
ELSEIF I1TAIL
THEN [FOR I1 IN I1TAIL
DO (PUSH PAIRS (LIST (CAR I1)
(CDR I1)
(CONS NIL]
(RETURN)
ELSEIF I2TAIL
THEN [FOR I2 IN I2TAIL
DO (PUSH PAIRS (LIST (CAR I2)
(CONS NIL)
(CDR I2]
(RETURN)
ELSE (RETURN)))
(* ;; "Take the cross products (if ALLVERSIONS) to create a list of (MN I1 I2) CDENTRIES with singleton infos.")
(FOR P MN CANDIDATES IN PAIRS
DO (SETQ MN (CAR P))
[FOR I1 IN (CADR P)
DO (FOR I2 IN (CADDR P)
DO (PUSH CANDIDATES (CREATE CDENTRY
MATCHNAME _ MN
INFO1 _ I1
INFO2 _ I2] FINALLY (RETURN CANDIDATES])
(CDENTRIES.SELECT
[LAMBDA (CANDIDATES SELECT) (* ; "Edited 23-Feb-2022 20:45 by rmk")
(* ; "Edited 4-Jan-2022 21:31 by rmk")
(* ;; "Does the pairwise select filter and inserts the date relation")
(for CDE MATCHNAME INFO1 INFO2 IDATE1 IDATE2 DATEREL BINCOMP
[COMPAREDATE _ (INTERSECTION SELECT '(< > =] in CANDIDATES
eachtime (SETQ MATCHNAME (FETCH (CDENTRY MATCHNAME) OF CDE))
(SETQ INFO1 (FETCH (CDENTRY INFO1) OF CDE))
(SETQ INFO2 (FETCH (CDENTRY INFO2) OF CDE))
(if (AND INFO1 INFO2)
then (SETQ IDATE1 (IDATE (fetch DATE of INFO1)))
(SETQ IDATE2 (IDATE (fetch DATE of INFO2)))
(SETQ DATEREL (if (IGREATERP IDATE1 IDATE2)
then '>
elseif (ILESSP IDATE1 IDATE2)
then '<
else '=))
else
(* ;; "Just for printing--no comparison")
(SETQ DATEREL '*))
when (if (AND INFO1 INFO2)
then (CL:WHEN (OR (NULL COMPAREDATE)
(SELECTQ DATEREL
(> (MEMB '> COMPAREDATE))
(< (MEMB '< COMPAREDATE))
(= (MEMB '= COMPAREDATE))
(SHOULDNT)))
(SETQ BINCOMP (BINCOMP (fetch (CDINFO FULLNAME) OF INFO1)
(fetch (CDINFO FULLNAME) OF INFO2)
T
(fetch (CDINFO EOL) OF INFO1)
(fetch (CDINFO EOL) OF INFO2)))
(CL:WHEN (EQ T BINCOMP)
(* ;; "Byte-equivalent files with different dates. Presumably the earlier date is more accurate, move back the date of the later file and make DATEREL be =. Perhaps we should do this even if there is only an EOL difference (BINCOMP non-NIL).;; Byte-equivalent files with different dates. Presumably the earlier date is more accurate, move back the date of the earlier file and make DATEREL be =. Perhaps we should do this even if there is only an EOL difference (BINCOMP non-NIL). ")
(* ;; "We do this even if FIXDIRECTORYDATES is false, that addresses a property of individual Lisp source files.")
(SELECTQ DATEREL
(> (SETFILEINFO (FETCH (CDINFO FULLNAME) OF INFO1)
'CREATIONDATE
(REPLACE (CDINFO DATE) OF INFO1 WITH (FETCH (CDINFO DATE)
OF INFO2))))
(< (SETFILEINFO (FETCH (CDINFO FULLNAME) OF INFO2)
'CREATIONDATE
(REPLACE (CDINFO DATE) OF INFO2 WITH (FETCH (CDINFO DATE)
OF INFO1))))
NIL)
(SETQ DATEREL '=))
(* ;; "We want the ~= test to reflect exact byte equivalence, including the same EOL. We use the BINCOMP value below to indicate EOL differences, so we check it here.")
[NOT (AND (MEMB '~= SELECT)
BINCOMP
(EQ (fetch (CDINFO EOL) OF INFO1)
(fetch (CDINFO EOL) OF INFO2])
elseif INFO1
then
(* ;; "OK if INFO2 is missing?")
(MEMB '*- SELECT)
else
(* ;; "OK if INFO1 is missing?")
(MEMB '-* SELECT)) collect (REPLACE (CDENTRY DATEREL) OF CDE WITH DATEREL)
(REPLACE (CDENTRY EQUIV) OF CDE
WITH (CL:UNLESS (EQ DATEREL '*)
BINCOMP))
CDE])
(COMPAREDIRECTORIES.INFOS.TYPE
[LAMBDA (FILE) (* ; "Edited 28-Sep-2023 23:09 by rmk")
(* ; "Edited 22-May-2022 14:27 by rmk")
(* ; "Edited 25-Apr-2022 09:02 by rmk")
(* ; "Edited 4-Jan-2022 13:10 by rmk")
(* ; "Edited 12-Dec-2021 22:50 by rmk")
(LET (TYPE DATE)
(CL:MULTIPLE-VALUE-SETQ (TYPE DATE)
(LISPFILETYPE FILE))
(CL:UNLESS TYPE
(SETQ TYPE (IF (SETQ DATE (TEDIT.FILEDATE FILE))
THEN 'TEDIT
ELSEIF (PRINTFILETYPE FILE)
ELSE (MEMB (FILENAMEFIELD FILE 'EXTENSION)
'(TXT TEXT SH MD C))
THEN 'TEXT
ELSE 'OTHER)))
(CL:VALUES TYPE DATE])
(MATCHNAME
[LAMBDA (NAME STARTPOS) (* ; "Edited 24-Feb-2022 09:10 by rmk")
(* ; "Edited 23-Dec-2021 22:41 by rmk")
(* ; "Edited 5-Sep-2020 13:41 by rmk:")
(* ;; "The canonical name for matching related files")
(LET [(M (UNSLASHIT (U-CASE (PACKFILENAME 'VERSION NIL 'BODY (SUBATOM NAME STARTPOS]
(* ;; "Strip off the nuisance period")
(CL:IF (EQ (CHARCODE %.)
(NTHCHARCODE M -1))
(SUBATOM M 1 -2)
(MKATOM M))])
(CD.INSURECDVALUE
[LAMBDA (CDVALUE?) (* ; "Edited 30-Nov-2021 14:37 by rmk:")
(* ;; "Maybe just a list of entries without the global information. Try to fix it")
(CL:UNLESS CDVALUE?
(PRINTOUT T T "Note: Using LASTCDVALUE" T T)
(SETQ CDVALUE? LASTCDVALUE))
(CD.UPDATEWIDTHS (IF (STRINGP (FETCH (CDVALUE CDDIR2) OF CDVALUE?))
THEN CDVALUE?
ELSE (create CDVALUE
CDENTRIES _ CDVALUE?
CDDIR1 _ [for E in CDVALUE? when (fetch INFO1 of E)
do (RETURN (PACKFILENAME 'NAME NIL 'EXTENSION NIL
'VERSION NIL 'BODY
(fetch (CDINFO FULLNAME)
OF (fetch INFO1 of E]
CDDIR2 _ [for E in CDVALUE? when (fetch INFO2 of E)
do (RETURN (PACKFILENAME 'NAME NIL 'EXTENSION NIL
'VERSION NIL 'BODY
(fetch (CDINFO FULLNAME)
OF (fetch INFO2 of E]
CDCOMPAREDATE _ (DATE])
(CD.UPDATEWIDTHS
[LAMBDA (CDVALUE) (* ; "Edited 4-Dec-2021 09:25 by rmk")
(* ; "Edited 30-Nov-2021 13:34 by rmk:")
(LET ((WIDTHS (CDPRINT.MAXWIDTHS CDVALUE)))
(REPLACE (CDVALUE CDMAXNC1) OF CDVALUE WITH (CAR WIDTHS))
(REPLACE (CDVALUE CDMAXNC2) OF CDVALUE WITH (CADR WIDTHS)))
CDVALUE])
)
(DEFINEQ
(CDFILES
[LAMBDA (DIR INCLUDEDFILES EXCLUDEDFILES ALLVERSIONS DEPTH)(* ; "Edited 17-Jun-2023 23:04 by rmk")
(* ; "Edited 3-Oct-2022 12:03 by rmk")
(* ; "Edited 25-Apr-2022 08:42 by rmk")
(* ; "Edited 5-Mar-2022 15:05 by rmk")
(* ; "Edited 16-Oct-2020 13:42 by rmk:")
(* ;; "Returns a list of fullnames for files that satisfy the criteria. We generate all candidates that match INCLUDEDFILES but not EXCLUDEDFILES in DIR.")
(* ;; "For each name returned by (DIRECTORY DIR), assumes that INCLUDEDFILES applies to the suffix after the directory (i.e. after NAMEPOS). That includes possibly subdirectories, dotted files in ultimate file names, and versions.")
(* ;; " Exclude subdirectories unless INCLUDEDFILES includes *>*")
(* ;; " Exclude dotted files (.xxx) unless INCLUDEDFILES includes .*")
(* ;; " Exclude older versions unless ALLVERSIONS=T")
(* ;; " DEPTH is the number of subdirectories below the ones specified in DIR (NIL top-level of DIR only, T = any depth)")
(* ;; "Resolve relative directories, so we can suppress subdirectory matches. ")
(* ;; "EXCLUDEDFILES is a filepattern with * meaning everything, COM means *.LCOM and *.DFASL")
[SETQ EXCLUDEDFILES `(*>.DS_Store
,@(MKLIST EXCLUDEDFILES]
(CL:UNLESS (EQMEMB '.* INCLUDEDFILES) (* ;
"Excluded dot files unless specifically asked for")
[SETQ EXCLUDEDFILES `(.* ,@(MKLIST EXCLUDEDFILES])
(SETQ EXCLUDEDFILES (LDIFFERENCE EXCLUDEDFILES INCLUDEDFILES))
(LET ([INCLUDES (CDFILES.PATS (OR INCLUDEDFILES '*.*]
(EXCLUDES (AND EXCLUDEDFILES (CDFILES.PATS EXCLUDEDFILES)))
(*UPPER-CASE-FILE-NAMES* NIL)
HOST ENUMPAT)
(SETQ HOST (FILENAMEFIELD.STRING DIR 'HOST))
(SETQ DIR (FILENAMEFIELD.STRING DIR 'DIRECTORY))
(CL:UNLESS DEPTH
(* ;; "DEPTH is the number of internal > or /")
(SETQ DEPTH (FOR P IN INCLUDES LARGEST (CADDDR P) FINALLY (RETURN $$EXTREME))))
(* ;; "ENUMPAT is the single pattern that we use for the directory enumeration (given the enumeration depth). We have to go to the most general specification, then filter the generated results.")
(FOR P (N _ (CAAR INCLUDES))
(E _ (CADAR INCLUDES))
(SD _ (CADDAR INCLUDES)) IN (CDR INCLUDES)
DO (CL:UNLESS (EQ '* N)
(SETQ N (POP P)))
(CL:UNLESS (EQ '* E)
(SETQ E (POP P)))
(CL:UNLESS (OR (EQ SD '*)
(EQ SD (CAR P)))
(SETQ SD NIL)) FINALLY (CL:WHEN (EQ SD '*)
(SETQ SD ""))
(* ;;
"If We don't prefix TOPDIR with <, then if TOPDIR contains a colon it is interpreted as a device.")
(SETQ ENUMPAT (PACKFILENAME.STRING 'HOST HOST 'DIRECTORY
(CONCAT "<" DIR ">" (OR SD ""))
'NAME N 'EXTENSION E 'VERSION
(CL:IF ALLVERSIONS
'*
"")))
(CL:UNLESS (CDR INCLUDES)
(* ;
"No further filtering if there is only one pattern")
(SETQ INCLUDES NIL)))
(* ;; "We enumerate all the files, checking to see that")
(FOR FULLNAME NAME EXT SUBDIR UNPACK THISDEPTH (STARTPOS _ (IPLUS 2 (NCHARS DIR)))
IN (DIRECTORY ENUMPAT `(DEPTH ,DEPTH COLLECT)
NIL
(CL:IF ALLVERSIONS
"*"
"")) EACHTIME (SETQ UNPACK (UNPACKFILENAME FULLNAME))
(SETQ NAME (LISTGET UNPACK 'NAME))
(SETQ EXT (LISTGET UNPACK 'EXTENSION))
(CL:UNLESS NAME
(CL:WHEN EXT (* ; ".XY")
(SETQ NAME (PACK* "." EXT))
(SETQ EXT NIL)))
(CL:UNLESS (OR NAME EXT)(* ; "Must have been a directory")
(GO $$ITERATE))
(SETQ SUBDIR (SUBATOM (LISTGET UNPACK 'DIRECTORY)
STARTPOS))
(SETQ THISDEPTH (FOR I (CNT _ 1) FROM 1
DO (SELCHARQ (NTHCHARCODE SUBDIR I)
((> /)
(ADD CNT 1))
(NIL (RETURN CNT))
NIL)))
WHEN (OR (NULL INCLUDES)
(CDFILES.MATCH SUBDIR NAME EXT THISDEPTH INCLUDES))
UNLESS (CDFILES.MATCH SUBDIR NAME EXT THISDEPTH EXCLUDES) COLLECT FULLNAME])
(CDFILES.MATCH
[LAMBDA (SUBDIR NAME EXT THISDEPTH PATTERNS) (* ; "Edited 26-Jan-2022 15:33 by rmk")
(* ; "Edited 23-Dec-2021 21:47 by rmk")
(* ;; "True if the components of the fullname match at least one of the patterns")
(THEREIS P IN PATTERNS SUCHTHAT (AND [OR (STRING.EQUAL NAME (CAR P)
FILEDIRCASEARRAY)
(EQ '* (CAR P))
(AND (EQ (CHARCODE %.)
(CHCON1 (CAR P)))
(EQ (CHARCODE %.)
(CHCON1 NAME))
(OR (STRING.EQUAL NAME (SUBATOM (CAR P)
2))
(EQ (CHARCODE *)
(NTHCHARCODE (CAR P)
2]
(OR (STRING.EQUAL EXT (CADR P))
(EQ '* (CADR P)))
(OR (STRING.EQUAL SUBDIR (CADDR P))
(NULL (CADDR P))
(EQ '* (CADDR P)))
(ILEQ THISDEPTH (CADDDR P])
(CDFILES.PATS
[LAMBDA (PATTERNS) (* ; "Edited 17-Jun-2023 23:36 by rmk")
(* ; "Edited 23-Dec-2021 17:02 by rmk")
(* ;; "Returns (NAME EXT SUBDIR DEPTH) items where NAME or EXT may be the wildcard *, SD is the subdirectory (if any) and DEPTH is the number of / or > in the subdirectory")
(IF (OR (NULL PATTERNS)
(EQMEMB '* PATTERNS))
THEN '(
(* * NIL 1)
)
ELSE (FOR P N E SD DEPTH UNPACK INSIDE PATTERNS
JOIN (SETQ UNPACK (UNPACKFILENAME.STRING P)) (* ;
"String so we can tell the difference between x and x.")
[SETQ SD (MKATOM (LISTGET UNPACK 'SUBDIRECTORY]
(* ;; "Count the subdirectory depth")
[SETQ DEPTH (IF (EQ SD '*)
THEN MAX.SMALLP
ELSE (FOR I (CNT _ 1) FROM 1 DO (SELCHARQ (NTHCHARCODE SD I)
((/ >)
(ADD CNT 1))
(NIL (RETURN CNT))
NIL]
(SETQ N (LISTGET UNPACK 'NAME))
(SETQ N (if (NULL N)
then '*
elseif (NEQ 0 (NCHARS N))
then (MKATOM N)))
(SETQ E (LISTGET UNPACK 'EXTENSION))
(SETQ E (if (NULL E)
then '*
elseif (NEQ 0 (NCHARS E))
then (MKATOM E)))
(if [OR (AND (STRING.EQUAL N 'COM)
(NULL E))
(AND (STRING.EQUAL E 'COM)
(MEMB N ' (* NIL)]
THEN (FOR CE IN *COMPILED-EXTENSIONS* COLLECT (LIST '* CE SD DEPTH))
ELSE (CONS (IF N
THEN (LIST N E SD DEPTH)
ELSEIF E
THEN
(* ;; "This is the case .XXX, which presumably identifies a dotted file. If this is supposed to be all files with extension XXX, it shoud be specified as *.XXX, the case above. So we move .E into the N field.")
(LIST (PACK* '%. E)
NIL SD DEPTH)
ELSE `
(* * (\, SD) (\, DEPTH))
])
)
(DEFINEQ
(CDPRINT
[LAMBDA (CDVALUE FILE COLHEADINGS PRINTAUTHOR) (* ; "Edited 15-Jul-2022 12:03 by rmk")
(* ; "Edited 26-Jan-2022 13:43 by rmk")
(* ; "Edited 19-Dec-2021 20:10 by rmk")
(* ; "Edited 30-Nov-2021 20:59 by rmk:")
(* ; "Edited 13-Oct-2020 08:38 by rmk:")
(* ;; "Typically CDVALUE will have a provdenance header. If not, we fake one up, at least for the directories and today's date.")
(SETQ CDVALUE (CD.INSURECDVALUE CDVALUE))
(RESETLST
(LET* [STREAM (COLUMNS (CDPRINT.COLUMNS CDVALUE COLHEADINGS PRINTAUTHOR))
(DATE1POS (POP COLUMNS))
(ENDDATE1 (POP COLUMNS))
(COL1WIDTH (POP COLUMNS))
(COL2WIDTH (POP COLUMNS))
(COL2START (POP COLUMNS))
(LENGTH2END (POP COLUMNS))
(NCHARSDIR1 (FETCH NCDIR OF (FETCH CDMAXNC1 OF CDVALUE)))
(NCHARSDIR2 (FETCH NCDIR OF (FETCH CDMAXNC2 OF CDVALUE]
(CL:UNLESS (SETQ STREAM (GETSTREAM FILE 'OUTPUT T))
[RESETSAVE (SETQ STREAM (OPENSTREAM (PACKFILENAME 'EXTENSION 'TXT 'BODY FILE)
'OUTPUT
'NEW))
'(PROGN (CLOSEF? OLDVALUE])
(LINELENGTH 1000 STREAM) (* ; "Don't wrap")
(CL:WHEN (FETCH (CDVALUE CDDIR1) OF CDVALUE)
(CDPRINT.HEADER CDVALUE STREAM)
(PRINTOUT STREAM -2 (LENGTH (fetch CDENTRIES of CDVALUE))
" entries" T T))
(if (fetch CDENTRIES of CDVALUE)
then (CDPRINT.COLHEADERS STREAM COLHEADINGS ENDDATE1 COL1WIDTH COL2START COL2WIDTH)
(for E in (fetch CDENTRIES of CDVALUE)
do (CDPRINT.LINE STREAM E PRINTAUTHOR DATE1POS ENDDATE1 NCHARSDIR1
NCHARSDIR2 LENGTH2END))
else (PRINTOUT T "CDVALUE is empty" T))
(AND STREAM (CLOSEF? STREAM))))])
(CDPRINT.HEADER
[LAMBDA (DIR1 DIR2 SELECT DATE STREAM) (* ; "Edited 26-Jan-2022 13:36 by rmk")
(CL:WHEN (LISTP DIR1)
(* ;; "A CDVALUE")
(CL:UNLESS STREAM (SETQ STREAM DIR2))
(SETQ DIR2 (FETCH CDDIR2 OF DIR1))
(SETQ SELECT (FETCH CDSELECT OF DIR1))
(SETQ DATE (FETCH CDCOMPAREDATE OF DIR1))
(SETQ DIR1 (FETCH CDDIR1 OF DIR1)))
(CL:WHEN DIR1
(PRINTOUT STREAM "Comparing ")
(PRINTOUT STREAM DIR1 %# (CL:WHEN (IGREATERP (IPLUS (NCHARS DIR1)
(NCHARS DIR2))
70)
(TAB 5))
" vs. " DIR2)
(PRINTOUT STREAM T 3 "as of " DATE)
(CL:WHEN SELECT (PRINTOUT STREAM " selecting " SELECT)))])
(CDPRINT.LINE
[LAMBDA (STREAM ENTRY PRINTAUTHOR DATE1POS ENDDATE1 NCHARSDIR1 NCHARSDIR2 LENGTH2END)
(* ; "Edited 16-Jul-2022 10:19 by rmk")
(* ; "Edited 22-Nov-2021 22:38 by rmk:")
(* ; "Edited 9-Jan-2021 10:12 by rmk:")
(* ;; "Format one line of the directory comparison listing. If PRINTAUTHOR and AUTHOR1 or AUTHOR2 are non-NIL, list the author in parens; otherwise omit it.")
(LET ((INFO1 (fetch INFO1 of ENTRY))
(INFO2 (fetch INFO2 of ENTRY)))
(PRINTOUT STREAM (SELECTQ (fetch EQUIV of ENTRY)
(T "==")
(NIL " ")
(CONCAT (SELECTQ (CAR (fetch EQUIV of ENTRY))
(CR 'C)
(LF 'L)
(CRLF 2)
"x")
(SELECTQ (CADR (fetch EQUIV of ENTRY))
(CR 'C)
(LF 'L)
(CRLF 2)
"x")))
" ")
(CL:WHEN INFO1
(PRINTOUT STREAM (SUBSTRING (fetch (CDINFO FULLNAME) OF INFO1)
(ADD1 NCHARSDIR1)
NIL
(CONSTANT (CONCAT)))
" ")
(CL:WHEN PRINTAUTHOR
(PRINTOUT STREAM "(" (fetch (CDINFO AUTHOR) OF INFO1)
") "))
(PRINTOUT STREAM .FR (IDIFFERENCE DATE1POS 2)
(fetch (CDINFO LENGTH) OF INFO1)
" "
(fetch DATE of INFO1)))
(PRINTOUT STREAM .TAB0 ENDDATE1 " " (SELECTQ (fetch DATEREL of ENTRY)
(< "< ")
(> " >")
(* (CL:IF INFO1
" *"
"* "))
(SHOULDNT))
" ")
(CL:WHEN INFO2
(PRINTOUT STREAM (fetch DATE of INFO2)
" "
(SUBSTRING (fetch (CDINFO FULLNAME) OF INFO2)
(ADD1 NCHARSDIR2)
NIL
(CONSTANT (CONCAT)))
" ")
(CL:WHEN PRINTAUTHOR
(PRINTOUT STREAM "(" (fetch (CDINFO AUTHOR) OF INFO2)
") "))
(PRINTOUT STREAM .FR LENGTH2END (fetch (CDINFO LENGTH) OF INFO2))
(PRINTOUT STREAM " ")) (* ; "A little margin in the window")
(TERPRI STREAM])
(CDPRINT.MAXWIDTHS
[LAMBDA (CDVALUE) (* ; "Edited 30-Nov-2021 13:51 by rmk:")
(* ;;
"This computes the maximum widths needed for a printer to get all the entry-columns lined up. ")
(* ;; "The FULLNAME field of INFOs includes the full directory. The caller is responsible for discounting the lengths of the common directory prefixes.")
(* ;; "")
(LET ((CDENTRIES (CL:IF (STRINGP (FETCH CDDIR2 OF CDVALUE))
(FETCH CDENTRIES OF CDVALUE)
CDVALUE)))
(CL:WHEN CDENTRIES
[LIST (CREATE CDMAXNCHARS
NCFULLNAME _ (FOR CD IN CDENTRIES
LARGEST (NCHARS (OR (FETCH (CDINFO FULLNAME)
OF (FETCH (CDENTRY INFO1)
OF CD))
""))
FINALLY (RETURN (OR $$EXTREME 0)))
NCLENGTH _ (FOR CD IN CDENTRIES
LARGEST (NCHARS (OR (FETCH (CDINFO LENGTH)
OF (FETCH (CDENTRY INFO1) OF CD))
"")) FINALLY (RETURN (OR $$EXTREME 0)))
NCAUTHOR _ (FOR CD IN CDENTRIES
LARGEST (NCHARS (OR (FETCH (CDINFO AUTHOR)
OF (FETCH (CDENTRY INFO1) OF CD))
"")) FINALLY (RETURN (OR $$EXTREME 0)))
NCTYPE _ (FOR CD IN CDENTRIES
LARGEST (NCHARS (OR (FETCH (CDINFO TYPE)
OF (FETCH (CDENTRY INFO1) OF CD))
"")) FINALLY (RETURN (OR $$EXTREME 0)))
NCDIR _ (NCHARS (FETCH (CDVALUE CDDIR1) OF CDVALUE)))
(CREATE CDMAXNCHARS
NCFULLNAME _ (FOR CD IN CDENTRIES
LARGEST (NCHARS (OR (FETCH (CDINFO FULLNAME)
OF (FETCH (CDENTRY INFO2)
OF CD))
""))
FINALLY (RETURN (OR $$EXTREME 0)))
NCLENGTH _ (FOR CD IN CDENTRIES
LARGEST (NCHARS (OR (FETCH (CDINFO LENGTH)
OF (FETCH (CDENTRY INFO2) OF CD))
"")) FINALLY (RETURN (OR $$EXTREME 0)))
NCAUTHOR _ (FOR CD IN CDENTRIES
LARGEST (NCHARS (OR (FETCH (CDINFO AUTHOR)
OF (FETCH (CDENTRY INFO2) OF CD))
"")) FINALLY (RETURN (OR $$EXTREME 0)))
NCTYPE _ (FOR CD IN CDENTRIES
LARGEST (NCHARS (OR (FETCH (CDINFO TYPE)
OF (FETCH (CDENTRY INFO2) OF CD))
"")) FINALLY (RETURN (OR $$EXTREME 0)))
NCDIR _ (NCHARS (FETCH (CDVALUE CDDIR2) OF CDVALUE])])
(CDPRINT.COLHEADERS
[LAMBDA (STREAM COLHEADINGS ENDDATE1 COL1WIDTH COL2START COL2WIDTH)
(* ; "Edited 16-Jul-2022 10:38 by rmk")
(* ; "Edited 30-Nov-2021 14:47 by rmk:")
(* ;; "If column headers are provided, center them over the columns")
(CL:WHEN (LISTP COLHEADINGS)
(LET (HEADING)
(CL:WHEN (SETQ HEADING (CAR COLHEADINGS))
(CL:WHEN (IGREATERP (NCHARS HEADING)
COL1WIDTH) (* ; "Truncate to column width")
(SETQ HEADING (SUBSTRING HEADING 1 COL1WIDTH)))
(TAB (DIFFERENCE ENDDATE1 COL1WIDTH)
0 STREAM)
(FLUSHRIGHT ENDDATE1 HEADING 0 NIL T STREAM))
(CL:WHEN [SETQ HEADING (CAR (LISTP (CDR COLHEADINGS]
(CL:WHEN (IGREATERP (NCHARS HEADING)
COL2WIDTH)
(SETQ HEADING (SUBSTRING HEADING 1 COL2WIDTH)))
(TAB COL2START 0 STREAM)
(FLUSHRIGHT (PLUS COL2START COL2WIDTH)
HEADING 0 NIL T STREAM))
(TERPRI STREAM)))])
(CDPRINT.COLUMNS
[LAMBDA (CDVALUE COLHEADINGS PRINTAUTHOR) (* ; "Edited 20-Jul-2022 08:53 by rmk")
(* ; "Edited 16-Jul-2022 10:40 by rmk")
(* ; "Edited 30-Nov-2021 14:03 by rmk:")
(* ;; "Compute the column locations for CDPRINT.LINE")
(* ;; "Even though the longest length and author might not go with the longest file name, it is a reasonable approximation to assume that in fact the longest filename did have the longest length. Lengths differ by just a few characters, and a long length with a short filename might balance out. If the long file did have a long length, then it would all be exact. ")
(SETQ CDVALUE (CD.INSURECDVALUE CDVALUE))
(LET (INFO1 DATE1POS ENDDATE1 (COL1WIDTH 10)
(COL2WIDTH 10)
(DATERELWIDTH 6)
(MAXWIDTHS1 (FETCH (CDVALUE CDMAXNC1) OF CDVALUE))
(MAXWIDTHS2 (FETCH (CDVALUE CDMAXNC2) OF CDVALUE))
(MAXAUTHOR1 0)
(MAXAUTHOR2 0)
[DATEWIDTH (CONSTANT (NCHARS (DATE]
MAXNAME1 MAXNAME2 (EQUIV 4)
COL2START LENGTH2END)
(* ;; "DATE1POS is the position of the first character of INFO1's date, used for tabbing. We have to measure the filename, date, size, and author if desired")
(if (fetch CDENTRIES of CDVALUE)
then
(* ;; "Compute the column locations")
(* ;; "Even though the longest length and author might not go with the longest file name, it is a reasonable approximation to assume that in fact the longest filename did have the longest length. Lengths differ by just a few characters, and a long length with a short filename might balance out. If the long file did have a long length, then it would all be exact. ")
[SETQ MAXNAME1 (IF (IGREATERP (fetch NCFULLNAME of MAXWIDTHS1)
0)
THEN (IDIFFERENCE (fetch NCFULLNAME of MAXWIDTHS1)
(fetch NCDIR OF MAXWIDTHS1))
ELSE (* ;
"Nothing in column 1, space out a bit")
(IMAX 20 (NCHARS (CAR (LISTP COLHEADINGS]
[SETQ MAXNAME2 (IF (IGREATERP (fetch NCFULLNAME of MAXWIDTHS2)
0)
THEN (IDIFFERENCE (fetch NCFULLNAME of MAXWIDTHS2)
(fetch NCDIR OF MAXWIDTHS2))
ELSE (IMAX 20 (NCHARS (CAR (LISTP COLHEADINGS]
(CL:WHEN PRINTAUTHOR
(* ;; "MAXAUTHOR includes its own suffixspace")
[SETQ MAXAUTHOR1 (IPLUS (CONSTANT (NCHARS "("))
(fetch NCAUTHOR of MAXWIDTHS1)
(CONSTANT (NCHARS ") "]
[SETQ MAXAUTHOR2 (IPLUS (CONSTANT (NCHARS (NCHARS "(")))
(fetch NCAUTHOR of MAXWIDTHS2)
(CONSTANT (NCHARS ") "])
(SETQ COL1WIDTH (IPLUS MAXNAME1 1 MAXAUTHOR1 (fetch NCLENGTH of MAXWIDTHS1)
2 DATEWIDTH))
(SETQ DATE1POS (IPLUS EQUIV (IDIFFERENCE COL1WIDTH DATEWIDTH)))
(SETQ ENDDATE1 (IPLUS EQUIV COL1WIDTH))
(SETQ COL2WIDTH (IPLUS DATEWIDTH 2 MAXNAME2 1 MAXAUTHOR2 (fetch NCLENGTH
of MAXWIDTHS2)))
(* ;; "If column headers are provided, center them over the columns. But don't expand the column, the headers will be truncated.")
(* (CL:WHEN (CAR (LISTP COLHEADINGS))
(SETQ COL1WIDTH (IMAX 10
(NCHARS (CAR COLHEADINGS)) COL1WIDTH))))
(SETQ COL2START (PLUS EQUIV COL1WIDTH DATERELWIDTH))
(* (CL:WHEN (CAR (LISTP
(CDR COLHEADINGS))) (SETQ COL2WIDTH
(IMAX 10 (NCHARS (CADR COLHEADINGS))
COL2WIDTH))))
(SETQ LENGTH2END (IPLUS COL2START COL2WIDTH))
(LIST DATE1POS ENDDATE1 COL1WIDTH COL2WIDTH COL2START LENGTH2END])
(CDTEDIT
[LAMBDA (CDVALUE TITLE COLHEADINGS PRINTAUTHOR) (* ; "Edited 5-Nov-2021 16:44 by rmk:")
(* ; "Edited 31-Oct-2021 11:02 by rmk:")
(* ;; "CDPRINT to a read-only TEDIT file.")
(LET ((TSTREAM (OPENTEXTSTREAM)))
(DSPFONT DEFAULTFONT TSTREAM)
(CDPRINT CDVALUE TSTREAM COLHEADINGS PRINTAUTHOR)
(TERPRI TSTREAM)
(TEDIT TSTREAM NIL NIL `(READONLY T WINDOWTYPE CDTEDIT TITLE ,(OR TITLE
"Compare directories"])
)
(DEFINEQ
(CDMAP
[LAMBDA (CDVALUE FN) (* ; "Edited 5-Nov-2021 16:46 by rmk:")
(* ; "Edited 6-Sep-2020 15:58 by rmk:")
(CL:UNLESS CDVALUE
(PRINTOUT T T "Note: Using LASTCDVALUE" T T)
(SETQ CDVALUE LASTCDVALUE))
(FOR CDE MATCHNAME INFO1 DATEREL INFO2 EQUIV IN (FETCH CDENTRIES OF CDVALUE)
DECLARE (SPECVARS MATCHNAME INFO1 DATEREL INFO2 EQUIV) EACHTIME (SETQ MATCHNAME
(FETCH MATCHNAME OF CDE))
(SETQ INFO1 (FETCH INFO1
OF CDE))
(SETQ DATEREL
(FETCH DATEREL OF CDE))
(SETQ INFO2 (FETCH INFO2
OF CDE))
(SETQ EQUIV (FETCH EQUIV
OF CDE))
DO (APPLY* FN CDE])
(CDENTRY
[LAMBDA (MATCHNAME CDVALUE) (* ; "Edited 5-Nov-2021 16:47 by rmk:")
(* ; "Edited 5-Sep-2020 21:09 by rmk:")
(ASSOC MATCHNAME (FETCH CDENTRIES OF (OR CDVALUE LASTCDVALUE])
(CDSUBSET
[LAMBDA (CDVALUE FN) (* ; "Edited 4-Dec-2021 09:08 by rmk")
(* ; "Edited 30-Nov-2021 11:01 by rmk:")
(* ; "Edited 5-Nov-2021 16:56 by rmk:")
(* ; "Edited 15-Sep-2020 13:49 by rmk:")
(SETQ CDVALUE (CD.INSURECDVALUE CDVALUE))
(CD.UPDATEWIDTHS (CREATE CDVALUE USING CDVALUE CDENTRIES _
(FOR CDE MATCHNAME INFO1 DATEREL INFO2 EQUIV
IN (FETCH CDENTRIES OF CDVALUE)
DECLARE (SPECVARS MATCHNAME INFO1 DATEREL INFO2 EQUIV)
EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE))
(SETQ INFO1 (FETCH INFO1 OF CDE))
(SETQ DATEREL (FETCH DATEREL OF CDE))
(SETQ INFO2 (FETCH INFO2 OF CDE))
(SETQ EQUIV (FETCH EQUIV OF CDE))
WHEN (APPLY* FN CDE) COLLECT CDE])
(CDMERGE
[LAMBDA (CDVALUES) (* ; "Edited 5-Apr-2023 10:10 by rmk")
(* ; "Edited 24-Jan-2022 17:01 by rmk")
(* ;; "This merges a collection of CDVALUES on different directories into a single CDVALUE with the union of the CDENTRIES, provided that they have the same selection criteria. The merged directories will be the minimal common prefix of all of the entries on each side, and the residual of the directory will be packed onto all the names.")
(IF (CDR CDVALUES)
THEN
[LET
(CDSELECTS)
(* ;; "Group by selects")
(FOR CDV TMP IN CDVALUES
DO (PUSH [CDR (OR (SASSOC (FETCH CDSELECT OF CDV)
CDSELECTS)
(CAR (PUSH CDSELECTS (CONS (FETCH CDSELECT OF CDV]
CDV))
(* ;; "For each group, find the longest common directory prefixes")
(FOR CDS IDATE DIR1 DIR2 MERGEDENTRIES IN CDSELECTS
COLLECT (SETQ DIR1 (FETCH CDDIR1 OF (CADR CDS)))
(SETQ DIR2 (FETCH CDDIR2 OF (CADR CDS)))
[SETQ IDATE (IDATE (FETCH CDCOMPAREDATE OF (CADR CDS]
(* ;; "Calculate the common directory prefixes and latest date")
[FOR CDV IN (CDDR CDS) DO (SETQ DIR1 (CDMERGE.COMMON DIR1 (FETCH CDDIR1
OF CDV)))
(SETQ DIR2 (CDMERGE.COMMON DIR2 (FETCH CDDIR2
OF CDV)))
(CL:WHEN (IGREATERP IDATE (IDATE (FETCH CDCOMPAREDATE
OF CDV)))
(SETQ IDATE (IDATE (FETCH CDCOMPAREDATE OF CDV))))]
(* ;;
"Merge the CDENTRIES with matchnames pulled back so that subdirectories show up")
(SETQ MERGEDENTRIES
(SORT [FOR CDV (NC1 _ (ADD1 (NCHARS DIR1)))
(NC2 _ (ADD1 (NCHARS DIR2))) IN (CDR CDS)
JOIN (FOR CDE IN (FETCH CDENTRIES OF CDV)
COLLECT (CREATE CDENTRY
USING CDE MATCHNAME _
(IF (FETCH INFO1 OF CDE)
THEN (MATCHNAME (FETCH (CDINFO FULLNAME)
OF (FETCH INFO1
OF CDE))
NC1)
ELSE (MATCHNAME (FETCH (CDINFO FULLNAME)
OF (FETCH INFO2
OF CDE))
NC2]
(FUNCTION CD.SORT)))
(CD.UPDATEWIDTHS (CREATE CDVALUE
CDDIR1 _ DIR1
CDDIR2 _ DIR2
CDCOMPAREDATE _ (GDATE IDATE)
CDSELECT _ (CAR CDS)
CDENTRIES _ MERGEDENTRIES]
ELSE CDVALUES])
(CDMERGE.COMMON
[LAMBDA (DIRX DIRY) (* ; "Edited 24-Jan-2022 16:40 by rmk")
(* ;;
"Returns the longest common prefix of DIRX and DIRY, collapsing brackets, slashes, and case")
(FOR I CX CY (LASTDIRPOS _ 1) FROM 1 EACHTIME (SETQ CX (NTHCHARCODE DIRX I))
(SETQ CY (NTHCHARCODE DIRY I))
(CL:WHEN (MEMB CX (CHARCODE (< > /)))
(SETQ CX (CHARCODE /)))
(CL:WHEN (MEMB CY (CHARCODE (< > /)))
(SETQ CY (CHARCODE /)))
(CL:WHEN (AND (EQ CX (CHARCODE /))
(EQ CY (CHARCODE /)))
(SETQ LASTDIRPOS I))
UNLESS [AND CX CY (OR (EQ CX CY)
(EQ (L-CASECODE CX)
(L-CASECODE CY] DO (RETURN (CL:IF (EQ I 1)
""
(SUBSTRING DIRX 1 LASTDIRPOS))])
(CD.SORT
[LAMBDA (ENTRY1 ENTRY2) (* ; "Edited 5-Apr-2023 10:15 by rmk")
(* ;; "Groups same file with different extensions together. FOO and FOO.LCOM together, even if FOO-FUM exists (hyphen comes before period).")
(LET ((M1 (FETCH MATCHNAME OF ENTRY1))
(M2 (FETCH MATCHNAME OF ENTRY2))