Rmk19: Updates and remaining components for managing comparisons and interactions between git and Medley (#658)
* PSEUDOHOSTS: Overlay a file system at the end of a path in another file system New package, please look through it. * REGIONMANAGER: added RELCREATEPOSITION, allow for arguments to be spread If the WIDTH argument looks like a list of arguments, the arguments are spread out. Means that a relative region can be passed through intermediate functions. * EXAMINEDEFS: More control over regions and windows Examination windows are returned so that callers can manipulate them * TEDIT-PF-SEE: tf respects reader environment and bold faces of DEFUN and DEFMACRO names * COMPAREDIRECTORIES: refactored for more flexibility and easier maintenance Also, based on SPY, made more internal operations work on streams that are located and created once, rather than on file Added CDMERGE to merge CDVALUES for different subdirectories, to permit scrolling of all differences in a single browser window * COMPARESOURCES: Region for CS browser is passed through, window is returned Also tried to eliminate mismatching of simple edit timestamps * COMPARETEXT: Files can be input streams, region is passed in, window is returned * COMPAREDIRECTORIES again: Fixed a promptwindow bug * GITFNS: New package for comparing and copying back and forth from My Medley to the git clone
This commit is contained in:
rmkaplan
GitHub
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "30-Dec-2021 18:22:13"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>COMPAREDIRECTORIES.;116 100755
|
||||
(FILECREATED "27-Jan-2022 17:47:36"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>COMPAREDIRECTORIES.;160 112621
|
||||
|
||||
:CHANGES-TO (FNS CD-MENUFN)
|
||||
:CHANGES-TO (FNS CD.COMMANDSELECTEDFN)
|
||||
|
||||
:PREVIOUS-DATE "25-Dec-2021 12:59:47"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>COMPAREDIRECTORIES.;114)
|
||||
:PREVIOUS-DATE "26-Jan-2022 15:33:55"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>COMPAREDIRECTORIES.;159)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -19,11 +19,12 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
(
|
||||
(* ;; "Compare the contents of two directories.")
|
||||
|
||||
(FNS COMPAREDIRECTORIES COMPAREDIRECTORIES.INFOS COMPAREDIRECTORIES.INFOS.TYPE MATCHNAME
|
||||
CD.INSURECDVALUE CD.UPDATEWIDTHS)
|
||||
(FNS COMPAREDIRECTORIES COMPAREDIRECTORIES.INFOS CDENTRIES.SELECT
|
||||
COMPAREDIRECTORIES.INFOS.TYPE MATCHNAME CD.INSURECDVALUE CD.UPDATEWIDTHS)
|
||||
(FNS CDFILES CDFILES.MATCH CDFILES.PATS)
|
||||
(FNS CDPRINT CDPRINT.LINE CDPRINT.MAXWIDTHS CDPRINT.COLHEADERS CDPRINT.COLUMNS CDTEDIT)
|
||||
(FNS CDMAP CDENTRY CDSUBSET)
|
||||
(FNS CDPRINT CDPRINT.HEADER CDPRINT.LINE CDPRINT.MAXWIDTHS CDPRINT.COLHEADERS CDPRINT.COLUMNS
|
||||
CDTEDIT)
|
||||
(FNS CDMAP CDENTRY CDSUBSET CDMERGE CDMERGE.COMMON)
|
||||
(FNS BINCOMP EOLTYPE EOLTYPE.SHOW)
|
||||
(RECORDS CDVALUE CDENTRY CDINFO CDMAXNCHARS)
|
||||
|
||||
@@ -63,13 +64,10 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
|
||||
(COMPAREDIRECTORIES
|
||||
[LAMBDA (DIR1 DIR2 SELECT INCLUDEDFILES EXCLUDEDFILES USEDIRECTORYDATE OUTPUTFILE ALLVERSIONS
|
||||
FIXDIRECTORYDATES) (* ; "Edited 23-Dec-2021 18:59 by rmk")
|
||||
(* ; "Edited 19-Dec-2021 20:07 by rmk")
|
||||
(* ; "Edited 30-Nov-2021 13:51 by rmk:")
|
||||
(* ; "Edited 23-Nov-2021 12:57 by rmk:")
|
||||
(* ; "Edited 6-Nov-2021 12:08 by rmk:")
|
||||
(* ; "Edited 31-Oct-2021 11:01 by rmk:")
|
||||
(* ; "Edited 7-Jan-2021 23:21 by rmk:")
|
||||
FIXDIRECTORYDATES) (* ; "Edited 26-Jan-2022 13:33 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.")
|
||||
|
||||
@@ -96,8 +94,7 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
(*- '*-)
|
||||
(~= '~=)
|
||||
(ERROR "UNRECOGNIZED SELECT PARAMETER" S]
|
||||
(PROG (INFOS1 INFOS2 CANDIDATES CDENTRIES COMPAREDATE DEPTH1 DEPTH2 CDVALUE)
|
||||
[SETQ COMPAREDATE (INTERSECTION SELECT '(< > =]
|
||||
(PROG (INFOS1 INFOS2 CANDIDATES CDENTRIES DEPTH1 DEPTH2 CDVALUE (DATE (DATE)))
|
||||
|
||||
(* ;; "DIRECTORYNAME here to get unrelativized specifications for header.")
|
||||
|
||||
@@ -117,8 +114,8 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
(PRINTOUT T "Fixing directory dates" T)
|
||||
(FIX-DIRECTORY-DATES DIR1)
|
||||
(FIX-DIRECTORY-DATES DIR2))
|
||||
(PRINTOUT T "Comparing " DIR1 6 "vs. " DIR2 T "as of " (DATE)
|
||||
" selecting " SELECT " ... ")
|
||||
(CDPRINT.HEADER DIR1 DIR2 SELECT DATE T)
|
||||
(PRINTOUT T " ... ")
|
||||
(SETQ INFOS1 (COMPAREDIRECTORIES.INFOS (CDFILES DIR1 INCLUDEDFILES EXCLUDEDFILES
|
||||
ALLVERSIONS DEPTH1)
|
||||
USEDIRECTORYDATE DIR1))
|
||||
@@ -128,7 +125,7 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
(SETQ CDVALUE (CREATE CDVALUE
|
||||
CDDIR1 _ DIR1
|
||||
CDDIR2 _ DIR2
|
||||
CDCOMPAREDATE _ (DATE)
|
||||
CDCOMPAREDATE _ DATE
|
||||
CDSELECT _ SELECT))
|
||||
(CL:UNLESS (OR INFOS2 INFOS1)
|
||||
(RETURN CDVALUE))
|
||||
@@ -166,58 +163,7 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
|
||||
(* ;; "Do the SELECT filtering and insert the date relation.")
|
||||
|
||||
[SETQ CDENTRIES
|
||||
(for C MATCHNAME INFO1 INFO2 IDATE1 IDATE2 DATEREL BINCOMP in CANDIDATES
|
||||
eachtime (SETQ MATCHNAME (pop C))
|
||||
(SETQ INFO1 (pop C))
|
||||
(SETQ INFO2 (pop C))
|
||||
(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 '> SELECT))
|
||||
(< (MEMB '< SELECT))
|
||||
(= (MEMB '= SELECT))
|
||||
(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)))
|
||||
|
||||
(* ;; "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 (create CDENTRY
|
||||
MATCHNAME _ MATCHNAME
|
||||
INFO1 _ INFO1
|
||||
DATEREL _ DATEREL
|
||||
INFO2 _ INFO2
|
||||
EQUIV _ (CL:UNLESS (EQ DATEREL '*)
|
||||
BINCOMP]
|
||||
(SETQ CDENTRIES (CDENTRIES.SELECT CANDIDATES SELECT))
|
||||
(PRINTOUT T (LENGTH CDENTRIES)
|
||||
" entries" T)
|
||||
(REPLACE CDENTRIES OF CDVALUE WITH CDENTRIES)
|
||||
@@ -227,37 +173,118 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
(RETURN (CDPRINT CDVALUE OUTPUTFILE NIL (MEMB 'AUTHOR SELECT])
|
||||
|
||||
(COMPAREDIRECTORIES.INFOS
|
||||
[LAMBDA (FILES USEDIRECTORYDATE DIR) (* ; "Edited 23-Dec-2021 18:59 by rmk")
|
||||
[LAMBDA (FILES USEDIRECTORYDATE DIR) (* ; "Edited 4-Jan-2022 15:23 by rmk")
|
||||
(* ; "Edited 23-Dec-2021 18:59 by rmk")
|
||||
(* ; "Edited 12-Dec-2021 22:50 by rmk")
|
||||
(* ; "Edited 23-Nov-2021 12:27 by rmk:")
|
||||
(* ; "Edited 13-Oct-2020 08:42 by rmk:")
|
||||
|
||||
(* ;; "Value is a list of CDINFOS with the match-name consed on to the front")
|
||||
|
||||
(FOR FULLNAME TYPE LDATE (STARTPOS _ (ADD1 (NCHARS DIR))) IN FILES
|
||||
(FOR FULLNAME TYPE LDATE STREAM (STARTPOS _ (ADD1 (NCHARS DIR))) IN FILES
|
||||
COLLECT
|
||||
|
||||
(* ;; "GDATE/IDATE in case Y2K")
|
||||
|
||||
(SETQ LDATE (OR (FILEDATE FULLNAME T)
|
||||
(FILEDATE FULLNAME))) (* ;
|
||||
(* ;
|
||||
"Is it a Lisp file? Get it's internal filecreated date. ")
|
||||
(CONS (MATCHNAME FULLNAME STARTPOS)
|
||||
(CREATE CDINFO
|
||||
FULLNAME _ FULLNAME
|
||||
DATE _ [GDATE (IDATE (IF USEDIRECTORYDATE
|
||||
THEN (GETFILEINFO FULLNAME 'CREATIONDATE)
|
||||
ELSEIF (OR LDATE (GETFILEINFO FULLNAME
|
||||
'CREATIONDATE]
|
||||
LENGTH _ (GETFILEINFO FULLNAME 'LENGTH)
|
||||
AUTHOR _ (GETFILEINFO FULLNAME 'AUTHOR)
|
||||
TYPE _ (COMPAREDIRECTORIES.INFOS.TYPE FULLNAME LDATE)
|
||||
EOL _ (EOLTYPE FULLNAME])
|
||||
(SETQ STREAM (OPENSTREAM FULLNAME 'INPUT)) (* ;
|
||||
"So all the GETFILEINFO's, FILEDATES, etc. don't have to do the directory searching.")
|
||||
(SETQ LDATE (OR (FILEDATE STREAM T)
|
||||
(FILEDATE STREAM)))
|
||||
(PROG1 (CONS (MATCHNAME FULLNAME STARTPOS)
|
||||
(CREATE CDINFO
|
||||
FULLNAME _ FULLNAME
|
||||
DATE _ (GDATE (IDATE (IF (OR USEDIRECTORYDATE (NULL LDATE))
|
||||
THEN (GETFILEINFO STREAM 'CREATIONDATE)
|
||||
ELSE (SETFILEINFO STREAM 'CREATIONDATE LDATE)
|
||||
LDATE)))
|
||||
LENGTH _ (GETFILEINFO STREAM 'LENGTH)
|
||||
AUTHOR _ (GETFILEINFO STREAM 'AUTHOR)
|
||||
TYPE _ (COMPAREDIRECTORIES.INFOS.TYPE STREAM LDATE)
|
||||
EOL _ (EOLTYPE STREAM)))
|
||||
(CLOSEF? STREAM])
|
||||
|
||||
(CDENTRIES.SELECT
|
||||
[LAMBDA (CANDIDATES SELECT) (* ; "Edited 4-Jan-2022 21:31 by rmk")
|
||||
|
||||
(* ;; "Does the pairwise select filter and inserts the date relation")
|
||||
|
||||
(for C MATCHNAME INFO1 INFO2 IDATE1 IDATE2 DATEREL BINCOMP [COMPAREDATE
|
||||
_
|
||||
(INTERSECTION SELECT
|
||||
'(< > =] in CANDIDATES
|
||||
eachtime (SETQ MATCHNAME (pop C))
|
||||
(SETQ INFO1 (pop C))
|
||||
(SETQ INFO2 (pop C))
|
||||
(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 (create CDENTRY
|
||||
MATCHNAME _ MATCHNAME
|
||||
INFO1 _ INFO1
|
||||
DATEREL _ DATEREL
|
||||
INFO2 _ INFO2
|
||||
EQUIV _ (CL:UNLESS (EQ DATEREL '*)
|
||||
BINCOMP])
|
||||
|
||||
(COMPAREDIRECTORIES.INFOS.TYPE
|
||||
[LAMBDA (FULLNAME LDATE) (* ; "Edited 12-Dec-2021 22:50 by rmk")
|
||||
(IF (OR LDATE (FILEDATE FULLNAME T)
|
||||
(FILEDATE FULLNAME))
|
||||
[LAMBDA (FULLNAME LDATE) (* ; "Edited 4-Jan-2022 13:10 by rmk")
|
||||
(* ; "Edited 12-Dec-2021 22:50 by rmk")
|
||||
(IF LDATE
|
||||
THEN (CL:IF (MEMB (FILENAMEFIELD FULLNAME 'EXTENSION)
|
||||
*COMPILED-EXTENSIONS*)
|
||||
'COMPILED
|
||||
@@ -318,9 +345,12 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
(DEFINEQ
|
||||
|
||||
(CDFILES
|
||||
[LAMBDA (DIR INCLUDEDFILES EXCLUDEDFILES ALLVERSIONS DEPTH)(* ; "Edited 23-Dec-2021 22:49 by rmk")
|
||||
(* ; "Edited 6-Nov-2021 12:08 by rmk:")
|
||||
(* ; "Edited 16-Oct-2020 13:42 by rmk:")
|
||||
[LAMBDA (DIR INCLUDEDFILES EXCLUDEDFILES ALLVERSIONS DEPTH)(* ; "Edited 26-Jan-2022 15:25 by rmk")
|
||||
(* ; "Edited 21-Jan-2022 22:40 by rmk")
|
||||
(* ; "Edited 5-Jan-2022 15:07 by rmk")
|
||||
(* ; "Edited 23-Dec-2021 22:49 by rmk")
|
||||
(* ; "Edited 6-Nov-2021 12:08 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.")
|
||||
|
||||
@@ -338,7 +368,7 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
|
||||
(* ;; "EXCLUDEDFILES is a filepattern with * meaning everything, COM means *.LCOM and *.DFASL")
|
||||
|
||||
[SETQ EXCLUDEDFILES `(.DS_Store
|
||||
[SETQ EXCLUDEDFILES `(*>.DS_Store
|
||||
,@(MKLIST EXCLUDEDFILES]
|
||||
(CL:UNLESS (EQMEMB '.* INCLUDEDFILES) (* ;
|
||||
"Excluded dot files unless specifically asked for")
|
||||
@@ -372,9 +402,14 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
(CL:UNLESS (OR (EQ SD '*)
|
||||
(EQ SD (CAR P)))
|
||||
(SETQ SD NIL)) FINALLY (CL:WHEN (EQ SD '*)
|
||||
(SETQ 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 'HOST HOST 'DIRECTORY
|
||||
(CONCAT TOPDIR ">" (OR SD ""))
|
||||
(CONCAT "<" TOPDIR ">"
|
||||
(OR SD ""))
|
||||
'NAME N 'EXTENSION E 'VERSION
|
||||
(CL:IF ALLVERSIONS
|
||||
'*
|
||||
@@ -387,48 +422,52 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
(* ;; "We enumerate all the files, checking to see that")
|
||||
|
||||
(FOR FULLNAME NAME EXT SUBDIR UNPACK THISDEPTH (STARTPOS _ (ADD1 (NCHARS TOPDIR)))
|
||||
IN (DIRECTORY ENUMPAT) EACHTIME (CL:WHEN (DIRECTORYNAMEP FULLNAME)
|
||||
(* ; "Skip directories")
|
||||
(GO $$ITERATE))
|
||||
(SETQ UNPACK (UNPACKFILENAME FULLNAME))
|
||||
(SETQ NAME (LISTGET UNPACK 'NAME))
|
||||
(SETQ EXT (LISTGET UNPACK 'EXTENSION))
|
||||
(SETQ SUBDIR (SUBATOM (LISTGET UNPACK 'DIRECTORY)
|
||||
STARTPOS))
|
||||
(CL:UNLESS NAME
|
||||
(CL:WHEN EXT (* ; ".XY")
|
||||
(SETQ NAME (PACK* "." EXT))
|
||||
(SETQ EXT NIL)))
|
||||
(SETQ THISDEPTH (FOR I (CNT _ 1) FROM 1
|
||||
DO (SELCHARQ (NTHCHARCODE SUBDIR I)
|
||||
((> /)
|
||||
(ADD CNT 1))
|
||||
(NIL (RETURN CNT))
|
||||
NIL)))
|
||||
IN (DIRECTORY ENUMPAT NIL 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 23-Dec-2021 21:47 by rmk")
|
||||
[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))
|
||||
(THEREIS P IN PATTERNS SUCHTHAT (AND [OR (STRING.EQUAL NAME (CAR P)
|
||||
FILEDIRCASEARRAY)
|
||||
(EQ '* (CAR P))
|
||||
(AND (EQ (CHARCODE %.)
|
||||
(CHCON1 (CAR P)))
|
||||
(EQ (EQ (CHARCODE %.)
|
||||
(CHCON1 NAME)))
|
||||
(EQ (CHARCODE %.)
|
||||
(CHCON1 NAME))
|
||||
(OR (STRING.EQUAL NAME (SUBATOM (CAR P)
|
||||
2))
|
||||
(EQ (CHARCODE *1)
|
||||
(EQ (CHARCODE *)
|
||||
(NTHCHARCODE (CAR P)
|
||||
2]
|
||||
(OR (STRING.EQUAL EXT (CADR P))
|
||||
(EQ '* (CADR P)))
|
||||
(OR (STRING.EQUAL SUBDIR (CADDR P))
|
||||
(NULL (CADDR P)))
|
||||
(NULL (CADDR P))
|
||||
(EQ '* (CADDR P)))
|
||||
(ILEQ THISDEPTH (CADDDR P])
|
||||
|
||||
(CDFILES.PATS
|
||||
@@ -479,9 +518,10 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
(DEFINEQ
|
||||
|
||||
(CDPRINT
|
||||
[LAMBDA (CDVALUE FILE COLHEADINGS PRINTAUTHOR) (* ; "Edited 19-Dec-2021 20:10 by rmk")
|
||||
(* ; "Edited 30-Nov-2021 20:59 by rmk:")
|
||||
(* ; "Edited 13-Oct-2020 08:38 by rmk:")
|
||||
[LAMBDA (CDVALUE FILE COLHEADINGS PRINTAUTHOR) (* ; "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.")
|
||||
|
||||
@@ -502,11 +542,7 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
'(PROGN (CLOSEF? OLDVALUE])
|
||||
(LINELENGTH 1000 STREAM) (* ; "Don't wrap")
|
||||
(CL:WHEN (FETCH (CDVALUE CDDIR1) OF CDVALUE)
|
||||
(PRINTOUT STREAM "Comparing " (FETCH (CDVALUE CDDIR1) OF CDVALUE)
|
||||
6 "vs. " (FETCH (CDVALUE CDDIR2) OF CDVALUE)
|
||||
T "as of " (FETCH (CDVALUE CDCOMPAREDATE) OF CDVALUE))
|
||||
(CL:WHEN (FETCH (CDVALUE CDSELECT) OF CDVALUE)
|
||||
(PRINTOUT STREAM " selecting " (FETCH (CDVALUE CDSELECT) OF CDVALUE)))
|
||||
(CDPRINT.HEADER CDVALUE STREAM)
|
||||
(PRINTOUT STREAM -2 (LENGTH (fetch CDENTRIES of CDVALUE))
|
||||
" entries" T T))
|
||||
(if (fetch CDENTRIES of CDVALUE)
|
||||
@@ -517,6 +553,27 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
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)
|
||||
(* ; "Edited 22-Nov-2021 22:38 by rmk:")
|
||||
@@ -752,6 +809,89 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
(SETQ INFO2 (FETCH INFO2 OF CDE))
|
||||
(SETQ EQUIV (FETCH EQUIV OF CDE))
|
||||
WHEN (APPLY* FN CDE) COLLECT CDE])
|
||||
|
||||
(CDMERGE
|
||||
[LAMBDA (CDVALUES) (* ; "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]
|
||||
T))
|
||||
(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))])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
@@ -827,40 +967,51 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
FINALLY (RETURN (OR EOLDIFF T]))])
|
||||
|
||||
(EOLTYPE
|
||||
[LAMBDA (FILE SHOWCONTEXT) (* ; "Edited 21-Feb-2021 20:34 by rmk:")
|
||||
[LAMBDA (FILE SHOWCONTEXT)
|
||||
|
||||
(* ;; "Returns the EOLCONVENTION of FILE if it only sees one kind, NIL if it can't decide.")
|
||||
(* ;; "Edited 4-Jan-2022 15:10 by rmk: Allow FILE to be an already open stream")
|
||||
|
||||
(* ;; "If SHOWCONTEXT, it is the number of bytes before and after an EOL inconsistency (e.g. seeing CR after having seen LF) that will be displayed on the TTY. The position of the inconsistency will be marked with ##.")
|
||||
(* ;; "Edited 21-Feb-2021 20:34 by rmk:")
|
||||
|
||||
(* ;; "Returns the EOLCONVENTION of FILE if it only sees one kind, NIL if it can't decide.")
|
||||
|
||||
(* ;; "If SHOWCONTEXT, it is the number of bytes before and after an EOL inconsistency (e.g. seeing CR after having seen LF) that will be displayed on the TTY. The position of the inconsistency will be marked with ##.")
|
||||
|
||||
(SELECTQ SHOWCONTEXT
|
||||
(NIL)
|
||||
(T (SETQ SHOWCONTEXT 100))
|
||||
(CL:UNLESS (FIXP SHOWCONTEXT)
|
||||
(ERROR "SHOWCONTEXT must be an integer" SHOWCONTEXT)))
|
||||
(CL:WITH-OPEN-FILE
|
||||
(STREAM FILE :DIRECTION :INPUT)
|
||||
(SETFILEINFO STREAM 'ENDOFSTREAMOP (FUNCTION NILL))
|
||||
(BIND EOLTYPE
|
||||
DO (SELCHARQ (OR (\BIN STREAM)
|
||||
(RETURN EOLTYPE))
|
||||
(CR (IF (EQ (CHARCODE LF)
|
||||
(RESETLST
|
||||
(LET (STREAM)
|
||||
[IF (GETSTREAM FILE 'INPUT T)
|
||||
THEN (SETQ STREAM FILE)
|
||||
[RESETSAVE NIL `(PROGN (SETFILEPTR ,STREAM ,(GETFILEPTR STREAM))
|
||||
(STREAMPROP ,STREAM 'ENDOFSTREAMOP
|
||||
',(STREAMPROP STREAM 'ENDOFSTREAMOP]
|
||||
(SETFILEPTR STREAM 0)
|
||||
ELSE (RESETSAVE NIL `(CLOSEF? ,(SETQ STREAM (OPENSTREAM FILE 'INPUT]
|
||||
(SETFILEINFO STREAM 'ENDOFSTREAMOP (FUNCTION NILL))
|
||||
(BIND EOLTYPE
|
||||
DO (SELCHARQ (OR (\BIN STREAM)
|
||||
(RETURN EOLTYPE))
|
||||
(CR (IF (EQ (CHARCODE LF)
|
||||
(\PEEKBIN STREAM T))
|
||||
THEN (\BIN STREAM)
|
||||
(IF (MEMB EOLTYPE '(LF CR))
|
||||
THEN (CL:UNLESS (EOLTYPE.SHOW SHOWCONTEXT EOLTYPE
|
||||
'LF STREAM)
|
||||
(RETURN NIL))
|
||||
ELSE (SETQ EOLTYPE 'CRLF))
|
||||
ELSEIF (MEMB EOLTYPE '(LF CRLF))
|
||||
THEN (CL:UNLESS (EOLTYPE.SHOW SHOWCONTEXT EOLTYPE 'CR STREAM)
|
||||
THEN (\BIN STREAM)
|
||||
(IF (MEMB EOLTYPE '(LF CR))
|
||||
THEN (CL:UNLESS (EOLTYPE.SHOW SHOWCONTEXT EOLTYPE
|
||||
'LF STREAM)
|
||||
(RETURN NIL))
|
||||
ELSE (SETQ EOLTYPE 'CRLF))
|
||||
ELSEIF (MEMB EOLTYPE '(LF CRLF))
|
||||
THEN (CL:UNLESS (EOLTYPE.SHOW SHOWCONTEXT EOLTYPE 'CR STREAM)
|
||||
(RETURN NIL))
|
||||
ELSE (SETQ EOLTYPE 'CR)))
|
||||
(LF (IF (MEMB EOLTYPE '(CR CRLF))
|
||||
THEN (CL:UNLESS (EOLTYPE.SHOW SHOWCONTEXT EOLTYPE 'LF STREAM)
|
||||
ELSE (SETQ EOLTYPE 'CR)))
|
||||
(LF (IF (MEMB EOLTYPE '(CR CRLF))
|
||||
THEN (CL:UNLESS (EOLTYPE.SHOW SHOWCONTEXT EOLTYPE 'LF STREAM)
|
||||
(RETURN NIL))
|
||||
ELSE (SETQ EOLTYPE 'LF)))
|
||||
NIL])
|
||||
ELSE (SETQ EOLTYPE 'LF)))
|
||||
NIL))))])
|
||||
|
||||
(EOLTYPE.SHOW
|
||||
[LAMBDA (SHOWCONTEXT OLDTYPE NEWTYPE STREAM) (* ; "Edited 21-Feb-2021 20:20 by rmk:")
|
||||
@@ -1435,18 +1586,16 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
|
||||
(CDBROWSER
|
||||
[LAMBDA (CDVALUE TITLE COLHEADINGS BROWSERPROPS SEPARATEDIRECTIONS MENUITEMS)
|
||||
(* ; "Edited 25-Dec-2021 12:50 by rmk")
|
||||
(* ; "Edited 16-Dec-2021 11:51 by rmk")
|
||||
(* ; "Edited 14-Dec-2021 21:41 by rmk")
|
||||
(* ; "Edited 10-Dec-2021 21:38 by rmk")
|
||||
(* ; "Edited 30-Nov-2021 15:03 by rmk:")
|
||||
(* ; "Edited 29-Nov-2021 14:18 by rmk:")
|
||||
|
||||
(* ;; "Edited 25-Jan-2022 13:05 by rmk: a table browser for the differences in CDVALUE.")
|
||||
|
||||
(* ;; "Creates a table browser for the differences in CDVALUE.")
|
||||
|
||||
(SETQ MENUITEMS (IF MENUITEMS
|
||||
THEN (FOR I IN MENUITEMS COLLECT (OR (LISTP I)
|
||||
(SASSOC I CDTABLEBROWSER.MENUITEMS)
|
||||
(AND (STREQUAL I "")
|
||||
"")
|
||||
(ERROR "UNKNOWN CDBROWSER MENU ITEM" I))
|
||||
)
|
||||
ELSE CDTABLEBROWSER.MENUITEMS))
|
||||
@@ -1466,8 +1615,8 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
DEFAULTFONT]
|
||||
[SETQ REGION (GETREGION (PLUS TB.LEFT.MARGIN ITEMWIDTH (TIMES 2 WBorder)
|
||||
MENUWIDTH)
|
||||
(TIMES [IMIN 15 (IMAX (IPLUS 4 (LENGTH STRINGS))
|
||||
(ADD1 (LENGTH MENUITEMS]
|
||||
(TIMES (IMAX (IMIN 15 (LENGTH STRINGS))
|
||||
(ADD1 (LENGTH MENUITEMS)))
|
||||
(FONTPROP DEFAULTFONT 'HEIGHT]
|
||||
|
||||
(* ;; "Promptwindow seems to do its own thing, even if under construction. So we preshrink the main window.")
|
||||
@@ -1476,8 +1625,13 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
OF REGION)
|
||||
(FONTPROP DEFAULTFONT
|
||||
'HEIGHT]
|
||||
(SETQ WINDOW (CREATEW REGION (OR TITLE "Compare directories")
|
||||
(SETQ WINDOW (CREATEW REGION (OR TITLE (CONCAT "Compare directories " (LENGTH
|
||||
STRINGS)
|
||||
" files"))
|
||||
NIL T))
|
||||
[WINDOWADDPROP WINDOW 'CLOSEFN (FUNCTION (LAMBDA (W)
|
||||
(FOR W INSIDE (WINDOWPROP W 'SUBWINDOWS)
|
||||
DO (CLOSEW (WFROMDS W]
|
||||
(WINDOWPROP WINDOW 'UNDERCONSTRUCTION T)
|
||||
|
||||
(* ;; "TABLEBROWSER is odd: USERDATA is a single recognized property. But it allows for other unrecognized properties in the list, it pushes them on to a list USERPROPS...and then throws it away. So here I'm using USERDATA to hold the directory lengths so they can be stripped off for display. It may actually be better to have a field name in CDVALUE for all of the shared stuff in front of the entries, and keep it all.")
|
||||
@@ -1610,105 +1764,153 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
'DON'T])
|
||||
|
||||
(CD.COMMANDSELECTEDFN
|
||||
[LAMBDA (MENUITEM MENU KEY) (* ; "Edited 25-Dec-2021 11:20 by rmk")
|
||||
(* ; "Edited 16-Dec-2021 13:45 by rmk")
|
||||
(* ; "Edited 13-Dec-2021 17:13 by rmk")
|
||||
(* ; "Edited 9-Dec-2021 21:36 by rmk")
|
||||
(* ; "Edited 8-Dec-2021 11:27 by rmk")
|
||||
(* ; "Edited 5-Dec-2021 13:28 by rmk")
|
||||
(* ; "Edited 3-Dec-2021 00:21 by rmk:")
|
||||
(* ; "Edited 29-Nov-2021 23:08 by rmk:")
|
||||
[LAMBDA (MENUITEM MENU KEY) (* ; "Edited 27-Jan-2022 17:46 by rmk")
|
||||
(* ; "Edited 10-Jan-2022 22:51 by rmk")
|
||||
(* ; "Edited 25-Dec-2021 11:20 by rmk")
|
||||
(* ; "Edited 12-Jan-87 12:57 by bvm:")
|
||||
|
||||
(* ;; "Cobbled from FB.COMMANDSELECTEDFN. But here we assume that the menu item is of the form (display-string FN . EXTRAS), we peel out the FN to apply, leave the rest alone.")
|
||||
|
||||
(DECLARE (SPECVARS MENUITEM MENU KEY))
|
||||
(RESETLST
|
||||
[LET* [(WINDOW (WINDOWPROP (WFROMMENU MENU)
|
||||
'MAINWINDOW))
|
||||
(PROMPTWINDOW (GETPROMPTWINDOW WINDOW))
|
||||
(CDBROWSER (WINDOWPROP WINDOW 'TABLEBROWSER))
|
||||
(USERDATA (TB.USERDATA CDBROWSER))
|
||||
(CDVALUE (LISTGET USERDATA 'CDVALUE))
|
||||
(FN (CADR (LISTP MENUITEM]
|
||||
(DECLARE (SPECVARS WINDOW PROMPTWINDOW CDVALUE USERDATA))
|
||||
(GIVE.TTY.PROCESS PROMPTWINDOW)
|
||||
(TTYDISPLAYSTREAM PROMPTWINDOW) (* ; "Pwindow")
|
||||
(IF (EQ 0 (TB.NUMBER.OF.ITEMS CDBROWSER 'SELECTED))
|
||||
THEN (FLASHWINDOW PROMPTWINDOW)
|
||||
(PRIN3 "Please make a selection" T)
|
||||
ELSE (TB.MAP.SELECTED.ITEMS CDBROWSER
|
||||
[FUNCTION (LAMBDA (CDBROWSER TBITEM)
|
||||
(LET* ((CDENTRY (CADR (FETCH TIDATA OF TBITEM)))
|
||||
(FILE1 (FETCH (CDINFO FULLNAME)
|
||||
(FETCH (CDENTRY INFO1) OF CDENTRY)))
|
||||
(FILE2 (FETCH (CDINFO FULLNAME)
|
||||
(FETCH (CDENTRY INFO2) OF CDENTRY)))
|
||||
(TYPE (FETCH (CDINFO TYPE) OF (FETCH (CDENTRY INFO1)
|
||||
OF CDENTRY)))
|
||||
(LABELS (APPLY* (OR (LISTGET USERDATA 'LABELFN)
|
||||
(FUNCTION NILL))
|
||||
FILE1 FILE2 USERDATA))
|
||||
(LABEL1 (OR (CAR LABELS)
|
||||
FILE1))
|
||||
(LABEL2 (OR (CADR LABELS)
|
||||
FILE2)))
|
||||
(DECLARE (SPECVARS . T))
|
||||
(CL:UNLESS (STREQUAL MENUITEM "") (* ; "For blank lines")
|
||||
(RESETLST
|
||||
[LET* [(WINDOW (WINDOWPROP (WFROMMENU MENU)
|
||||
'MAINWINDOW))
|
||||
(PWINDOW (GETPROMPTWINDOW WINDOW))
|
||||
(CDBROWSER (WINDOWPROP WINDOW 'TABLEBROWSER))
|
||||
(USERDATA (TB.USERDATA CDBROWSER))
|
||||
(CDVALUE (LISTGET USERDATA 'CDVALUE))
|
||||
(FN (CADR (LISTP MENUITEM]
|
||||
(DECLARE (SPECVARS WINDOW PWINDOW CDVALUE USERDATA))
|
||||
(GIVE.TTY.PROCESS PWINDOW)
|
||||
(TTYDISPLAYSTREAM PWINDOW) (* ; "Pwindow")
|
||||
(COND
|
||||
((EQ 0 (TB.NUMBER.OF.ITEMS CDBROWSER 'SELECTED))
|
||||
(FLASHWINDOW PWINDOW)
|
||||
(PRIN3 "Please make a selection" T))
|
||||
(T (TB.MAP.SELECTED.ITEMS
|
||||
CDBROWSER
|
||||
[FUNCTION (LAMBDA (CDBROWSER TBITEM)
|
||||
(LET* ((CDENTRY (CADR (FETCH TIDATA OF TBITEM)))
|
||||
(FILE1 (FETCH (CDINFO FULLNAME)
|
||||
(FETCH (CDENTRY INFO1) OF CDENTRY)))
|
||||
(FILE2 (FETCH (CDINFO FULLNAME)
|
||||
(FETCH (CDENTRY INFO2) OF CDENTRY)))
|
||||
(TYPE (FETCH (CDINFO TYPE) OF (FETCH (CDENTRY INFO1)
|
||||
OF CDENTRY)))
|
||||
(LABELS (APPLY* (OR (LISTGET USERDATA 'LABELFN)
|
||||
(FUNCTION NILL))
|
||||
FILE1 FILE2 USERDATA))
|
||||
(LABEL1 (OR (CAR LABELS)
|
||||
FILE1))
|
||||
(LABEL2 (OR (CADR LABELS)
|
||||
FILE2)))
|
||||
(DECLARE (SPECVARS . T))
|
||||
|
||||
(* ;; "If USERDATA contains a LABELFN, then it is applied to the files and the rest of the USERDATA to produce abbreviated labels for titles and headers.")
|
||||
|
||||
(CLEARW T)
|
||||
(CL:FUNCALL FN TBITEM MENUITEM CDBROWSER KEY]
|
||||
(FUNCTION NILL])])
|
||||
(CLEARW T)
|
||||
(CL:FUNCALL FN TBITEM MENUITEM CDBROWSER KEY]
|
||||
(FUNCTION NILL]))])
|
||||
|
||||
(CD-MENUFN
|
||||
[LAMBDA (TBITEM MENUITEM CDBROWSER KEY) (* ; "Edited 30-Dec-2021 18:21 by rmk")
|
||||
(* ; "Edited 20-Dec-2021 09:56 by rmk")
|
||||
(* ; "Edited 16-Dec-2021 13:30 by rmk")
|
||||
(* ; "Edited 13-Dec-2021 22:11 by rmk")
|
||||
(* ; "Edited 10-Dec-2021 21:42 by rmk")
|
||||
(* ; "Edited 9-Dec-2021 21:24 by rmk")
|
||||
[LAMBDA (TBITEM MENUITEM CDBROWSER KEY)
|
||||
|
||||
(* ;; "Edited 25-Jan-2022 10:19 by rmk: FILELABELFN, if provided, can be used to calculate abbreviated labels for the file, for example, to strip off any long common prefixes.")
|
||||
|
||||
(* ;; "The FILELABELFN, if provided, can be used to calculate abbreviated labels for the file, for example, to strip off any long common prefixes.")
|
||||
|
||||
(* ;; "MENUITEM is of the form (display-atom <this function> . extrainfo). The selector for the selectq is either the CAR of the extrainfo or the display atom.")
|
||||
|
||||
(SELECTQ (OR (CADDR MENUITEM)
|
||||
(CAR MENUITEM))
|
||||
(Compare (IF (AND FILE1 FILE2)
|
||||
THEN (SELECTQ TYPE
|
||||
(SOURCE (CSBROWSER FILE1 FILE2 NIL LABEL1 LABEL2))
|
||||
(COMPILED (PRIN3 "Cannot compare compiled files" T))
|
||||
((TEXT TEDIT)
|
||||
(* ;;
|
||||
(LET
|
||||
(SUBWINDOWS)
|
||||
(CL:WHEN (MEMB (OR (CADDR MENUITEM)
|
||||
(CAR MENUITEM))
|
||||
'(Compare See% right See% both See% left))
|
||||
(FOR W IN (WINDOWPROP WINDOW 'SUBWINDOWS) WHEN (OPENWP W) DO (CLOSEW W)))
|
||||
(SELECTQ (OR (CADDR MENUITEM)
|
||||
(CAR MENUITEM))
|
||||
(Compare (IF (AND FILE1 FILE2)
|
||||
THEN [SETQ SUBWINDOWS
|
||||
(SELECTQ TYPE
|
||||
(SOURCE (CSBROWSER FILE1 FILE2 NIL LABEL1 LABEL2
|
||||
(RELCREATEREGION
|
||||
[FIXR (TIMES 0.75 (FETCH (REGION WIDTH)
|
||||
OF (WINDOWPROP WINDOW
|
||||
'REGION]
|
||||
200
|
||||
'LEFT
|
||||
'TOP
|
||||
`(,WINDOW 0.125)
|
||||
(IPLUS (FETCH (REGION BOTTOM)
|
||||
OF (WINDOWPROP WINDOW 'REGION))
|
||||
20)
|
||||
T)))
|
||||
(COMPILED (FLASHWINDOW T)
|
||||
(PRIN3 "Cannot compare compiled files" T))
|
||||
((TEXT TEDIT)
|
||||
(* ;;
|
||||
"Works for TEDIT, but doesn't detect image object differences")
|
||||
|
||||
(COMPARETEXT FILE1 FILE2 'LINE NIL (LIST LABEL1 LABEL2)))
|
||||
(PROGN (PRIN3 "Unable to compare, showing both" T)
|
||||
(TEDIT-SEE-VERSIONS FILE1 FILE2 LABEL1 LABEL2)))
|
||||
ELSE (PRIN3 "Only one file" T)))
|
||||
(See% left (IF FILE1
|
||||
THEN (TEDIT-SEE FILE1 NIL NIL (CONCAT "SEE window for " LABEL1))
|
||||
ELSE (FLASHWINDOW T)
|
||||
(PRIN3 "No file to print" T)))
|
||||
(See% right (IF FILE2
|
||||
THEN (TEDIT-SEE FILE2 NIL NIL (CONCAT "SEE window for " LABEL2))
|
||||
(COMPARETEXT FILE1 FILE2 'LINE
|
||||
(RELCREATEPOSITION `(,WINDOW 0.5)
|
||||
(IPLUS (FETCH (REGION BOTTOM)
|
||||
OF (WINDOWPROP WINDOW 'REGION))
|
||||
20))
|
||||
(LIST LABEL1 LABEL2)))
|
||||
(PROGN (FLASHWINDOW T)
|
||||
(PRIN3 "Unable to compare, showing both" T)
|
||||
(TEDIT-SEE-VERSIONS FILE1 FILE2 LABEL1 LABEL2]
|
||||
ELSE (FLASHWINDOW T)
|
||||
(PRIN3 "Only one file" T)))
|
||||
(See% left (IF FILE1
|
||||
THEN (SETQ SUBWINDOWS (TEDIT-SEE FILE1
|
||||
(RELCREATEREGION
|
||||
700 700 'RIGHT 'TOP `(,WINDOW 0.5)
|
||||
(IPLUS (FETCH (REGION BOTTOM)
|
||||
OF (WINDOWPROP WINDOW 'REGION))
|
||||
-1)
|
||||
T)
|
||||
NIL
|
||||
(CONCAT "SEE window for " LABEL1)))
|
||||
ELSE (FLASHWINDOW T)
|
||||
(PRIN3 "No file to print" T)))
|
||||
(See% both (IF (AND FILE1 FILE2)
|
||||
THEN (EXAMINEFILES FILE1 FILE2 LABEL1 LABEL2)
|
||||
ELSE (PRIN3 "Only one file" T)))
|
||||
(Copy% -> (LET [(DEST (COPYFILE FILE1 (PACKFILENAME 'VERSION NIL FILE2]
|
||||
(PRIN3 (CL:IF DEST
|
||||
(CONCAT "Copied to " DEST)
|
||||
(CONCAT FILE2 " could not be copied"))
|
||||
T)))
|
||||
(Copy% <- (LET [(DEST (COPYFILE FILE2 (PACKFILENAME 'VERSION NIL FILE1]
|
||||
(PRIN3 (CL:IF DEST
|
||||
(CONCAT "Copied to " DEST)
|
||||
(CONCAT FILE1 " could not be copied"))
|
||||
T)))
|
||||
(SHOULDNT])
|
||||
(See% right (IF FILE2
|
||||
THEN (SETQ SUBWINDOWS (TEDIT-SEE FILE2
|
||||
(RELCREATEREGION
|
||||
700 700 'LEFT 'TOP `(,WINDOW 0.5)
|
||||
(IPLUS (FETCH (REGION BOTTOM)
|
||||
OF (WINDOWPROP WINDOW 'REGION))
|
||||
-1)
|
||||
T)
|
||||
NIL
|
||||
(CONCAT "SEE window for " LABEL2)))
|
||||
ELSE (FLASHWINDOW T)
|
||||
(PRIN3 "No file to print" T)))
|
||||
(See% both (IF (AND FILE1 FILE2)
|
||||
THEN (SETQ SUBWINDOWS (EXAMINEFILES FILE1 FILE2 LABEL1 LABEL2
|
||||
(RELCREATEREGION
|
||||
1400 700 'LEFT 'TOP `(,WINDOW 0.5 -701)
|
||||
(IPLUS (FETCH (REGION BOTTOM)
|
||||
OF (WINDOWPROP WINDOW 'REGION))
|
||||
-1)
|
||||
T)))
|
||||
ELSE (FLASHWINDOW T)
|
||||
(PRIN3 "Only one file" T)))
|
||||
(Copy% -> (LET [(DEST (COPYFILE FILE1 (PACKFILENAME 'VERSION NIL FILE2]
|
||||
(PRIN3 (CL:IF DEST
|
||||
(CONCAT "Copied to " DEST)
|
||||
(PROGN (FLASHWINDOW T)
|
||||
(CONCAT FILE2 " could not be copied")))
|
||||
T)))
|
||||
(Copy% <- (LET [(DEST (COPYFILE FILE2 (PACKFILENAME 'VERSION NIL FILE1]
|
||||
(PRIN3 (CL:IF DEST
|
||||
(CONCAT "Copied to " DEST)
|
||||
(PROGN (FLASHWINDOW T)
|
||||
(CONCAT FILE1 " could not be copied")))
|
||||
T)))
|
||||
(SHOULDNT))
|
||||
(FOR W INSIDE SUBWINDOWS DO (WINDOWADDPROP WINDOW 'SUBWINDOWS (WFROMDS W])
|
||||
)
|
||||
|
||||
(RPAQQ CDTABLEBROWSER.MENUITEMS ((Compare CD-MENUFN)
|
||||
@@ -1723,21 +1925,23 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
(PUTPROPS COMPAREDIRECTORIES COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1994 1998
|
||||
2018 2020 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (2418 17067 (COMPAREDIRECTORIES 2428 . 12186) (COMPAREDIRECTORIES.INFOS 12188 . 13867) (
|
||||
COMPAREDIRECTORIES.INFOS.TYPE 13869 . 14451) (MATCHNAME 14453 . 14983) (CD.INSURECDVALUE 14985 . 16599
|
||||
) (CD.UPDATEWIDTHS 16601 . 17065)) (17068 26728 (CDFILES 17078 . 23061) (CDFILES.MATCH 23063 . 24449)
|
||||
(CDFILES.PATS 24451 . 26726)) (26729 41174 (CDPRINT 26739 . 29343) (CDPRINT.LINE 29345 . 31901) (
|
||||
CDPRINT.MAXWIDTHS 31903 . 36018) (CDPRINT.COLHEADERS 36020 . 36658) (CDPRINT.COLUMNS 36660 . 40539) (
|
||||
CDTEDIT 40541 . 41172)) (41175 44371 (CDMAP 41185 . 42617) (CDENTRY 42619 . 42928) (CDSUBSET 42930 .
|
||||
44369)) (44372 51313 (BINCOMP 44382 . 48671) (EOLTYPE 48673 . 50638) (EOLTYPE.SHOW 50640 . 51311)) (
|
||||
51841 65048 (FIND-UNCOMPILED-FILES 51851 . 55494) (FIND-UNSOURCED-FILES 55496 . 58305) (
|
||||
FIND-SOURCE-FILES 58307 . 60011) (FIND-COMPILED-FILES 60013 . 62091) (FIND-UNLOADED-FILES 62093 .
|
||||
62837) (FIND-LOADED-FILES 62839 . 63393) (FIND-MULTICOMPILED-FILES 63395 . 65046)) (65049 73251 (
|
||||
CREATED-AS 65059 . 69856) (SOURCE-FOR-COMPILED-P 69858 . 72556) (COMPILE-SOURCE-DATE-DIFF 72558 .
|
||||
73249)) (73252 83558 (FIX-DIRECTORY-DATES 73262 . 76255) (FIX-EQUIV-DATES 76257 . 77782) (
|
||||
COPY-COMPARED-FILES 77784 . 79605) (COPY-MISSING-FILES 79607 . 81764) (COMPILED-ON-SAME-SOURCE 81766
|
||||
. 83556)) (83752 91440 (CDBROWSER 83762 . 88335) (CDBROWSER.STRINGS 88337 . 91438)) (91602 92874 (
|
||||
CD.TABLEITEM 91612 . 91832) (CD.TABLEITEM.PRINTFN 91834 . 92033) (CD.TABLEITEM.COPYFN 92035 . 92629) (
|
||||
CDTABLEBROWSER.HEADING.REPAINTFN 92631 . 92872)) (92875 100220 (CDTABLEBROWSER.WHENSELECTEDFN 92885 .
|
||||
93353) (CD.COMMANDSELECTEDFN 93355 . 97161) (CD-MENUFN 97163 . 100218)))))
|
||||
(FILEMAP (NIL (2497 19012 (COMPAREDIRECTORIES 2507 . 8956) (COMPAREDIRECTORIES.INFOS 8958 . 11078) (
|
||||
CDENTRIES.SELECT 11080 . 15766) (COMPAREDIRECTORIES.INFOS.TYPE 15768 . 16396) (MATCHNAME 16398 . 16928
|
||||
) (CD.INSURECDVALUE 16930 . 18544) (CD.UPDATEWIDTHS 18546 . 19010)) (19013 29285 (CDFILES 19023 .
|
||||
25379) (CDFILES.MATCH 25381 . 27006) (CDFILES.PATS 27008 . 29283)) (29286 44371 (CDPRINT 29296 . 31641
|
||||
) (CDPRINT.HEADER 31643 . 32540) (CDPRINT.LINE 32542 . 35098) (CDPRINT.MAXWIDTHS 35100 . 39215) (
|
||||
CDPRINT.COLHEADERS 39217 . 39855) (CDPRINT.COLUMNS 39857 . 43736) (CDTEDIT 43738 . 44369)) (44372
|
||||
52741 (CDMAP 44382 . 45814) (CDENTRY 45816 . 46125) (CDSUBSET 46127 . 47566) (CDMERGE 47568 . 51422) (
|
||||
CDMERGE.COMMON 51424 . 52739)) (52742 60280 (BINCOMP 52752 . 57041) (EOLTYPE 57043 . 59605) (
|
||||
EOLTYPE.SHOW 59607 . 60278)) (60808 74015 (FIND-UNCOMPILED-FILES 60818 . 64461) (FIND-UNSOURCED-FILES
|
||||
64463 . 67272) (FIND-SOURCE-FILES 67274 . 68978) (FIND-COMPILED-FILES 68980 . 71058) (
|
||||
FIND-UNLOADED-FILES 71060 . 71804) (FIND-LOADED-FILES 71806 . 72360) (FIND-MULTICOMPILED-FILES 72362
|
||||
. 74013)) (74016 82218 (CREATED-AS 74026 . 78823) (SOURCE-FOR-COMPILED-P 78825 . 81523) (
|
||||
COMPILE-SOURCE-DATE-DIFF 81525 . 82216)) (82219 92525 (FIX-DIRECTORY-DATES 82229 . 85222) (
|
||||
FIX-EQUIV-DATES 85224 . 86749) (COPY-COMPARED-FILES 86751 . 88572) (COPY-MISSING-FILES 88574 . 90731)
|
||||
(COMPILED-ON-SAME-SOURCE 90733 . 92523)) (92719 100458 (CDBROWSER 92729 . 97353) (CDBROWSER.STRINGS
|
||||
97355 . 100456)) (100620 101892 (CD.TABLEITEM 100630 . 100850) (CD.TABLEITEM.PRINTFN 100852 . 101051)
|
||||
(CD.TABLEITEM.COPYFN 101053 . 101647) (CDTABLEBROWSER.HEADING.REPAINTFN 101649 . 101890)) (101893
|
||||
112086 (CDTABLEBROWSER.WHENSELECTEDFN 101903 . 102371) (CD.COMMANDSELECTEDFN 102373 . 105764) (
|
||||
CD-MENUFN 105766 . 112084)))))
|
||||
STOP
|
||||
|
||||
Reference in New Issue
Block a user