1
0
mirror of synced 2026-01-26 12:21:52 +00:00

GITFNS: fix-ups prompted mostly by the pattern of git renames

This commit is contained in:
rmkaplan
2022-02-26 22:16:50 -08:00
parent d3b1c6a3b4
commit fbf33fe8e5
3 changed files with 343 additions and 129 deletions

View File

@@ -1,11 +1,11 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "19-Feb-2022 10:22:09" {DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>GITFNS.;58 58648
(FILECREATED "26-Feb-2022 12:26:02" {DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>GITFNS.;102 70973
:CHANGES-TO (FNS GIT-COMPARE-WITH-MYMEDLEY GIT-COMPARE-BRANCHES)
:CHANGES-TO (FNS GIT-REPO-FILENAME)
:PREVIOUS-DATE "13-Feb-2022 21:27:07"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>GITFNS.;57)
:PREVIOUS-DATE "26-Feb-2022 11:58:56"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>GITFNS.;101)
(PRETTYCOMPRINT GITFNSCOMS)
@@ -16,16 +16,25 @@
(FILES (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES)
COMPAREDIRECTORIES COMPARESOURCES COMPARETEXT PSEUDOHOSTS)
(INITVARS [GITMEDLEYDIR (OR (UNIX-GETENV "GITMEDLEYDIR")
(CONCAT "{UNIX}" (SLASHIT (PACKFILENAME 'HOST NIL 'BODY MEDLEYDIR
)
T]
(* ;; "GITMEDLEYDIR and MYMEDLEYDIR collapse to MEDLEYDIR if not provided")
(INITVARS (GITMEDLEYDIR (SLASHIT (PACKFILENAME 'BODY (OR (UNIX-GETENV "GITMEDLEYDIR")
MEDLEYDIR)
'HOST
'UNIX)
T))
(MYMEDLEYDIR (UNSLASHIT (PACKFILENAME 'BODY (OR (UNIX-GETENV "MYMEDLEYDIR")
MEDLEYDIR)
'HOST
'DSK)
T))
(MYMEDLEYHOST 'MM)
(GITMEDLEYHOST 'GIT))
(INITVARS (GIT-IGNORE-FILES '(EXPORTS.ALL RDSYS RDSYS.LCOM))
(GIT-IGNORE-DIRECTORIES '(loadups patches tmp fontsold deleted clos cltl2))
(GIT-MERGE-COMPARES T))
(P (PSEUDOHOST MYMEDLEYHOST MEDLEYDIR)
(P (PSEUDOHOST MYMEDLEYHOST MYMEDLEYDIR)
(PSEUDOHOST GITMEDLEYHOST GITMEDLEYDIR))
(FNS GIT-CLONEP)
@@ -43,7 +52,7 @@
(FNS ALLSUBDIRS MEDLEYSUBDIRS GITSUBDIRS)
(FNS TOGIT FROMGIT GIT-DELETE-FILE MYMEDLEY-DELETE-FILES)
(FNS MEDLEYSUBDIR GITSUBDIR STRIPDIR STRIPHOST STRIPNAME)
(FNS MYMEDLEYSUBDIR GITSUBDIR STRIPDIR STRIPHOST STRIPNAME)
(FNS GFILE4MFILE MFILE4GFILE GIT-REPO-FILENAME)
(* ;; "")
@@ -59,7 +68,8 @@
(* ;; "Branches")
(FNS GIT-CHECKOUT GIT-WHICH-BRANCH GIT-MAKE-BRANCH GIT-BRANCHES GIT-BRANCH-EXISTS?)
(FNS GIT-CHECKOUT GIT-WHICH-BRANCH GIT-MAKE-BRANCH GIT-BRANCHES GIT-BRANCH-EXISTS?
PICK-BRANCH GIT-PULL-REQUESTS)
(* ;; "My branches")
@@ -79,6 +89,7 @@
(FNS GIT-GET-DIFFERENT-FILES GIT-COMPARE-BRANCHES GIT-COMPARE-WITH-MYMEDLEY
GIT-COMPARE-WORKTREE GITCDOBJBUTTONFN GIT-CD-LABELFN GIT-CD-MENUFN)
(INITVARS (FROMGITN 0))
(* ;; "")
@@ -95,9 +106,22 @@
(FILESLOAD (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES)
COMPAREDIRECTORIES COMPARESOURCES COMPARETEXT PSEUDOHOSTS)
(RPAQ? GITMEDLEYDIR (OR (UNIX-GETENV "GITMEDLEYDIR")
(CONCAT "{UNIX}" (SLASHIT (PACKFILENAME 'HOST NIL 'BODY MEDLEYDIR)
T))))
(* ;; "GITMEDLEYDIR and MYMEDLEYDIR collapse to MEDLEYDIR if not provided")
(RPAQ? GITMEDLEYDIR (SLASHIT (PACKFILENAME 'BODY (OR (UNIX-GETENV "GITMEDLEYDIR")
MEDLEYDIR)
'HOST
'UNIX)
T))
(RPAQ? MYMEDLEYDIR (UNSLASHIT (PACKFILENAME 'BODY (OR (UNIX-GETENV "MYMEDLEYDIR")
MEDLEYDIR)
'HOST
'DSK)
T))
(RPAQ? MYMEDLEYHOST 'MM)
@@ -109,7 +133,7 @@
(RPAQ? GIT-MERGE-COMPARES T)
(PSEUDOHOST MYMEDLEYHOST MEDLEYDIR)
(PSEUDOHOST MYMEDLEYHOST MYMEDLEYDIR)
(PSEUDOHOST GITMEDLEYHOST GITMEDLEYDIR)
(DEFINEQ
@@ -164,8 +188,16 @@
(* ;; "Compares REMOTEBRANCH against origin/master, for pull-request assessment")
(CL:UNLESS REMOTEBRANCH (ERROR "PR branch not specified" ""))
(GIT-COMPARE-BRANCHES REMOTEBRANCH 'origin/master NIL))
(IF REMOTEBRANCH
THEN (GIT-COMPARE-BRANCHES REMOTEBRANCH 'origin/master NIL)
ELSE (LET [(PRITEMS (FOR PR IN (GIT-PULL-REQUESTS T) COLLECT (LIST (CADDR PR)
(CADDR PR)
(CONCAT " " (CADR PR)
" #"
(CAR PR]
(GIT-COMPARE-BRANCHES (PICK-BRANCH (OR PRITEMS 'REMOTE)
"Pull requests")
'origin/master NIL))))
(DEFCOMMAND cob (BRANCH)
@@ -194,12 +226,14 @@
[LAMBDA (HOST1 HOST2)
(* ;;
 "Edited 4-Feb-2022 17:57 by rmk: the union of the subdirectories that exist under all the hosts")
 "Edited 25-Feb-2022 21:57 by rmk: the union of the subdirectories that exist under all the hosts")
(* ;; "Returns the union of the subdirectories that exist under all the hosts")
(LET ((HOSTS (MKLIST HOST1))
(FILING.ENUMERATION.DEPTH 1)
VAL)
(DECLARE (SPECVARS FILING.ENUMERATION.DEPTH))
(CL:WHEN HOST2 (PUSHNEW HOSTS HOST2))
(CL:UNLESS HOSTS
(SETQ HOSTS (LIST MYMEDLEYHOST GITMEDLEYHOST)))
@@ -312,20 +346,22 @@
)
(DEFINEQ
(MEDLEYSUBDIR
[LAMBDA (SUBDIR STAR) (* ; "Edited 21-Jan-2022 15:18 by rmk")
(* ; "Edited 18-Jan-2022 16:19 by rmk")
(PACKFILENAME 'HOST MYMEDLEYHOST 'BODY (CONCAT SUBDIR (CL:IF STAR
">*"
"")])
(MYMEDLEYSUBDIR
[LAMBDA (SUBDIR STAR HOST) (* ; "Edited 26-Feb-2022 11:57 by rmk")
(* ; "Edited 21-Jan-2022 15:18 by rmk")
(UNSLASHIT (PACK* (PACKFILENAME 'HOST (OR HOST MYMEDLEYHOST)
'DIRECTORY SUBDIR)
(CL:IF STAR
"*"
"")])
(GITSUBDIR
[LAMBDA (SUBDIR STAR) (* ; "Edited 21-Jan-2022 15:18 by rmk")
(* ; "Edited 18-Jan-2022 16:19 by rmk")
(* ; "Edited 30-Oct-2021 23:59 by rmk:")
(SLASHIT (PACKFILENAME 'HOST GITMEDLEYHOST 'BODY (CONCAT SUBDIR (CL:IF STAR
"/*"
"")])
[LAMBDA (SUBDIR STAR HOST) (* ; "Edited 26-Feb-2022 11:56 by rmk")
(SLASHIT (PACK* (PACKFILENAME 'HOST (OR HOST GITMEDLEYHOST)
'DIRECTORY SUBDIR)
(CL:IF STAR
"*"
"")])
(STRIPDIR
[LAMBDA (FILE DIRECTORY) (* ; "Edited 18-Jan-2022 16:09 by rmk")
@@ -371,14 +407,18 @@
'VERSION NIL 'BODY GFILE])
(GIT-REPO-FILENAME
[LAMBDA (GFILE) (* ; "Edited 18-Jan-2022 15:42 by rmk")
[LAMBDA (GFILE) (* ; "Edited 26-Feb-2022 12:25 by rmk")
(* ; "Edited 18-Jan-2022 15:42 by rmk")
(* ;; "Returns the string that the repo expects for a file name. {GIT} or GITMEDLEYDIR is stripped, brackets go to slashes, subdirectories are lower cased, and a final period is remove.")
(* ;; "Returns the string that the repo expects for a file name. {GIT} or GITMEDLEYDIR is stripped, brackets go to slashes, subdirectories are lower cased, an initial / and a final period is remove.")
(SETQ GFILE (SLASHIT (IF (EQ GITMEDLEYHOST (FILENAMEFIELD GFILE 'HOST))
(SETQ GFILE (SLASHIT (IF (EQ GITMEDLEYHOST (FILENAMEFIELD GFILE 'HOST))
THEN (STRIPHOST GFILE)
ELSE (STRIPDIR GFILE GITMEDLEYDIR))
T))
(CL:WHEN (EQ (CHARCODE /)
(CHCON1 GFILE))
(SETQ GFILE (SUBSTRING GFILE 2)))
(CL:WHEN (EQ (CHARCODE %.)
(NTHCHARCODE GFILE -1))
(SETQ GFILE (SUBSTRING GFILE 1 -2)))
@@ -425,24 +465,69 @@
(GIT-COMMAND (CONCAT "git pull " (OR BRANCH (GIT-WHICH-BRANCH])
(GIT-BRANCH-DIFF
[LAMBDA (BRANCH1 BRANCH2) (* ; "Edited 24-Nov-2021 16:30 by rmk:")
(* ; "Edited 22-Nov-2021 09:07 by rmk:")
(* ; "Edited 16-Nov-2021 08:41 by rmk:")
[LAMBDA (BRANCH1 BRANCH2)
(* ;; "Edited 23-Feb-2022 17:45 by rmk: returns an ALIST that classifies how the files in BRANCH1 and BRANCH2 differ (changed, renamed, added, deleted, copied).")
(* ;; "This returns an ALIST that classifies how the files in BRANCH1 and BRANCH2 differ (changed, renamed, added, deleted, copied).")
(CL:UNLESS BRANCH1 (SETQ BRANCH1 "origin/master"))
(CL:UNLESS BRANCH2 (SETQ BRANCH2 "origin/master"))
(GIT-REMOTE-UPDATE)
(GIT-REMOTE-UPDATE)
(LET ([MERGE (CAR (GIT-COMMAND (CONCAT "git merge-base " BRANCH1 " " BRANCH2]
FILES POS)
LINES POS)
(CL:WHEN (STRPOS "fatal" MERGE)
(ERROR (CONCAT "merge-base failed for " (LIST BRANCH1 BRANCH2))))
(SETQ FILES (GIT-COMMAND (CONCAT "git diff --name-only " MERGE " " BRANCH1)))
(CL:WHEN (SETQ POS (STRPOS "fatal: ambiguous argument '" (CAR FILES)
(SETQ LINES (GIT-COMMAND (CONCAT "git diff --name-status -C --find-copies-harder " MERGE " "
BRANCH1)))
(CL:WHEN (SETQ POS (STRPOS "fatal: ambiguous argument '" (CAR LINES)
1 NIL T T))
(ERROR "Unknown branch " (IF (STRPOS BRANCH1 (CAR FILES)
(ERROR "Unknown branch " (IF (STRPOS BRANCH1 (CAR LINES)
POS NIL T)
THEN BRANCH1
ELSE BRANCH2)))
FILES])
(FOR L ADDED DELETED RENAMED CHANGED COPIED IN LINES
DO (SELCHARQ (CHCON1 L)
(A (CL:IF (EQ (CHARCODE TAB)
(NTHCHARCODE L 2))
(PUSH ADDED (SUBSTRING L 3))
(ERROR "ADDED NOT RECOGNIZED" L)))
(D (CL:IF (EQ (CHARCODE TAB)
(NTHCHARCODE L 2))
(PUSH DELETED (SUBSTRING L 3))
(ERROR "DELETED NOT RECOGNIZED" L)))
(M (CL:IF (SETQ POS (STRPOS " " L))
(PUSH CHANGED (SUBSTRING L (ADD1 POS)))
(ERROR "CHANGED NOT RECOGNIZED" L)))
(C (HELP "COPY NOT UNDERSTOOD" L)
(IF (SETQ POS (STRPOS " " L))
THEN [PUSH COPIED (LIST [SUBSTRING L (ADD1 POS)
(SUB1 (SETQ POS (STRPOS " " L (ADD1 POS]
(SUBSTRING L (ADD1 POS]
ELSE (HELP "COPY NOT UNDERSTOOD" L)))
(R (IF (AND (EQ (CHARCODE TAB)
(NTHCHARCODE L 5))
(SETQ POS (STRPOS " " L 7)))
THEN [PUSH RENAMED (LIST (SUBSTRING L 6 (SUB1 POS))
(SUBSTRING L (ADD1 POS))
(OR (FIXP (SUBATOM L 2 4))
(HELP "R without a number" L]
ELSE (HELP "RENAME NOT RECOGNIZED" L)))
(w (CL:UNLESS (STRPOS "warning: " L 1)
(HELP "UNRECOGNZED GIT LINE" L))
(CL:UNLESS (EQ 'Y (ASKUSER NIL NIL (CONCAT L " Ignore remaining files? ")))
(ERROR!)))
(HELP "Unrecognized git-diff code" (NTHCHAR L 1)))
FINALLY (CL:WHEN ADDED
(PUSH $$VAL (CONS 'ADDED ADDED)))
(CL:WHEN DELETED
(PUSH $$VAL (CONS 'DELETED DELETED)))
(CL:WHEN RENAMED
(PUSH $$VAL (CONS 'RENAMED RENAMED)))
(CL:WHEN CHANGED
(PUSH $$VAL (CONS 'CHANGED CHANGED)))
(CL:WHEN COPIED
(PUSH $$VAL (CONS 'COPIED COPIED)))])
(GIT-APPROVAL
[LAMBDA (BRANCH) (* ; "Edited 19-Nov-2021 15:08 by rmk:")
@@ -450,24 +535,44 @@
(GIT-ADD-WORKTREE "master" T])
(GIT-GET-FILE
[LAMBDA (BRANCH GITFILE LOCALFILE) (* ; "Edited 12-Feb-2022 18:06 by rmk")
(* ; "Edited 3-Jan-2022 23:52 by rmk")
(* ; "Edited 20-Nov-2021 20:28 by rmk:")
[LAMBDA (BRANCH GITFILE LOCALFILE NOERROR)
(* ;; "If GITFILE in (remote) BRANCH exists, it is copied to LOCALFILE and LOCALFILE is returned. If it doesn't exist, return value is NIL. Maybe it should cause a FILENOTFOUND error?")
(* ;; "Edited 24-Feb-2022 19:42 by rmk: the stream, not the name because of the NODIRCORE case.")
(CL:WHEN (GIT-FILE-EXISTS? BRANCH GITFILE)
(CL:WITH-OPEN-FILE (STREAM (OR LOCALFILE '{NODIRCORE)
:IF-EXISTS :NEW-VERSION :DIRECTION :IO)
(CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM (CONCAT (CDGITDIR)
"git show " BRANCH ":" GITFILE))
(* ;; "Returns the stream, not the name because of the NODIRCORE case.")
(* ;; "If GITFILE in (remote) BRANCH exists, it is copied to LOCALFILE and LOCALFILE is returned. If it doesn't exist, return value is NIL if NOERROR, otherwise an ERROR.")
(CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM (CONCAT (CDGITDIR)
"git show " BRANCH ":" GITFILE)))
(SETFILEINFO s 'ENDOFSTREAMOP (FUNCTION NILL))
(LET (BYTES)
(IF (FOR I B C FROM 1 WHILE (SETQ C (NTHCHARCODE "fatal: path '" I))
DO
(* ;;
 "Returns NIL if we run off the fatal string with a match, otherwise T")
(CL:UNLESS (SETQ B (\BIN s))
(RETURN T))
(PUSH BYTES B)
(CL:UNLESS (EQ B C)
(RETURN T)))
THEN
(* ;; "Don't open STREAM until we know the file is real")
(CL:WITH-OPEN-FILE (STREAM (OR LOCALFILE '{NODIRCORE)
:IF-EXISTS :NEW-VERSION :DIRECTION :IO)
(FOR B IN (DREVERSE BYTES) DO (\BOUT STREAM B))
[DO (\BOUT STREAM (OR (\BIN s)
(RETURN]
(SETFILEINFO STREAM 'CREATIONDATE (OR (FILEDATE STREAM T)
(FILEDATE STREAM)
(GIT-FILE-DATE GITFILE BRANCH))
)
(SETFILEINFO s 'ENDOFSTREAMOP (FUNCTION NILL))
(BIND C WHILE (SETQ C (\BIN s)) DO (\BOUT STREAM C)))
(SETFILEINFO STREAM 'CREATIONDATE (OR (FILEDATE STREAM T)
(FILEDATE STREAM)
(GIT-FILE-DATE GITFILE BRANCH)))
STREAM))])
STREAM)
ELSEIF NOERROR
THEN NIL
ELSE (ERROR "GIT FILE NOT FOUND" GITFILE])
(GIT-FILE-EXISTS?
[LAMBDA (BRANCH GITFILE) (* ; "Edited 10-Feb-2022 20:55 by rmk")
@@ -574,18 +679,21 @@
ELSE (HELP "Unexpected git result" RESULT])
(GIT-BRANCHES
[LAMBDA (WHERE) (* ; "Edited 8-Dec-2021 08:43 by rmk")
[LAMBDA (WHERE) (* ; "Edited 24-Feb-2022 21:20 by rmk")
(* ; "Edited 8-Dec-2021 08:43 by rmk")
(* ; "Edited 17-Nov-2021 18:20 by rmk:")
(* ; "Edited 16-Nov-2021 09:21 by rmk:")
(* ;;
 "Strips of the %"* %" that indicates the current branch and the 2-space padding on other branches")
(LET [(LOCAL (CL:WHEN (MEMB WHERE '(NIL ALL LOCAL))
(LET [(LOCAL (CL:WHEN (MEMB (U-CASE WHERE)
'(NIL ALL LOCAL))
(GIT-COMMAND "git branch")))
(REMOTE (CL:WHEN (MEMB WHERE '(NIL ALL REMOTE T))
(REMOTE (CL:WHEN (MEMB (U-CASE WHERE)
'(NIL ALL REMOTE T))
(GIT-COMMAND "git branch -r"]
(FOR B IN (APPEND LOCAL REMOTE) COLLECT (SUBATOM B 3])
(SORT (FOR B IN (APPEND LOCAL REMOTE) COLLECT (SUBATOM B 3])
(GIT-BRANCH-EXISTS?
[LAMBDA (BRANCH WHERE NOERROR) (* ; "Edited 16-Dec-2021 08:50 by rmk")
@@ -604,6 +712,31 @@
(GIT-BRANCHES WHERE)))
ELSEIF (NOT NOERROR)
THEN (ERROR "Unknown branch" BRANCH])
(PICK-BRANCH
[LAMBDA (BRANCHES TITLE) (* ; "Edited 25-Feb-2022 09:02 by rmk")
(MENU (CREATE MENU
TITLE _ (OR TITLE 'Branches)
ITEMS _ (OR (LISTP BRANCHES)
(GIT-BRANCHES BRANCHES))
MENUFONT _ DEFAULTFONT])
(GIT-PULL-REQUESTS
[LAMBDA (ALLINFO INCLUDEDRAFTS) (* ; "Edited 25-Feb-2022 09:26 by rmk")
(FOR LINE TAB1 TAB2 TAB3 VAL IN (GIT-COMMAND "gh pr list" T)
WHEN [AND (SETQ TAB1 (STRPOS " " LINE))
(SETQ TAB2 (STRPOS " " LINE (ADD1 TAB1)))
(SETQ TAB3 (STRPOS " " LINE (ADD1 TAB2)))
(OR INCLUDEDRAFTS (NEQ 'DRAFT (SUBATOM LINE (ADD1 TAB3]
COLLECT (IF ALLINFO
THEN `[,(SUBATOM LINE 1 (SUB1 TAB1))
,(SUBSTRING LINE (ADD1 TAB1)
(SUB1 TAB2))
,(SUBSTRING LINE (ADD1 TAB2)
(SUB1 TAB3))
,(SUBATOM LINE (ADD1 TAB3]
ELSE (SUBATOM LINE (ADD1 TAB2)
(SUB1 TAB3])
)
@@ -748,36 +881,86 @@
(DEFINEQ
(GIT-GET-DIFFERENT-FILES
[LAMBDA (BRANCH1 BRANCH2 DIR1 DIR2) (* ; "Edited 12-Feb-2022 18:35 by rmk")
[LAMBDA (BRANCH1 BRANCH2 DIR1 DIR2) (* ; "Edited 24-Feb-2022 23:57 by rmk")
(* ; "Edited 23-Feb-2022 18:47 by rmk")
(* ; "Edited 12-Feb-2022 18:35 by rmk")
(* ; "Edited 23-Jan-2022 21:45 by rmk")
(* ; "Edited 11-Jan-2022 11:03 by rmk")
(* ; "Edited 5-Jan-2022 08:01 by rmk")
(* ;; "Ask git for the files that differ between the branches, copy those files down to local DIR1 and DIR2, return the directories.")
(* ;; "Ask git for the files that differ between the branches, copy those files down to local DIR1 and DIR2, return the directories and a list of (dir1-file1 file2) mappings for renamed and copied files.")
(SETQ BRANCH1 (GIT-BRANCH-EXISTS? BRANCH1))
(SETQ BRANCH2 (GIT-BRANCH-EXISTS? BRANCH2))
(LET ([MERGE (CAR (GIT-COMMAND (CONCAT "git merge-base " BRANCH1 " " BRANCH2]
DIFFS)
(SETQ DIFFS (GIT-BRANCH-DIFF BRANCH1 MERGE))
(CL:WHEN DIFFS
(PSEUDOHOST 'FROMGIT (CONCAT "{CORE}<gitfiles>" (DATE)
">"))
(LET
([MERGE (CAR (GIT-COMMAND (CONCAT "git merge-base " BRANCH1 " " BRANCH2]
DIFFS MAPPINGS FROMGIT)
(* ;; "UNSLASHIT because CORE doesn't know about slash")
(* ;; "Collapse them together for now")
(CL:UNLESS DIR1
(SETQ DIR1 (CONCAT "{FROMGIT}" (UNSLASHIT BRANCH1)
">")))
(CL:UNLESS DIR2
(SETQ DIR2 (CONCAT "{FROMGIT}" (UNSLASHIT BRANCH2)
">")))
(FOR GFILE IN DIFFS DO (GIT-GET-FILE BRANCH1 GFILE (CONCAT DIR1 GFILE))
(GIT-GET-FILE MERGE GFILE (CONCAT DIR2 GFILE)))
(LIST DIR1 DIR2))])
(SETQ DIFFS (GIT-BRANCH-DIFF BRANCH1 MERGE))
(* ;; "DIFFS is an alist with keys ADDED, DELETED, CHANGED, MOVED")
(CL:WHEN DIFFS
(SETQ FROMGIT (PACK* '{FROMGIT (ADD FROMGITN 1)
'}))
(PSEUDOHOST FROMGIT (CONCAT "{CORE}<gitfiles>" (DATE)
">"))
(* ;; "UNSLASHIT because CORE doesn't know about slash")
(CL:UNLESS DIR1
(SETQ DIR1 (CONCAT FROMGIT "<" (UNSLASHIT BRANCH1)
">")))
(CL:UNLESS DIR2
(SETQ DIR2 (CONCAT FROMGIT "<" (UNSLASHIT BRANCH2)
">")))
(FOR DLIST IN DIFFS
DO
(SELECTQ (CAR DLIST)
(ADDED (* ;
 "Shouldn't exist in MERGE, should exist in BRANCH1")
(FOR GFILE IN (CDR DLIST) DO (GIT-GET-FILE BRANCH1 GFILE (CONCAT DIR1 GFILE))))
(DELETED (* ;
 "Shouldn't exist in BRANCH1, should exist in MERGE")
(FOR GFILE IN (CDR DLIST) DO (GIT-GET-FILE MERGE GFILE (CONCAT DIR2 GFILE))))
(CHANGED (* ; "Should exist in both branches")
(FOR GFILE IN (CDR DLIST) DO (GIT-GET-FILE BRANCH1 GFILE (CONCAT DIR1 GFILE)
)
(GIT-GET-FILE MERGE GFILE (CONCAT DIR2 GFILE))))
(RENAMED
(* ;; "These entries are from-to filename pairs. If (CADDR) is 100, only need to fetch one, mappings is returned so the connection can be reestablished higher up. If renamed, it has disappared from the first location and appeared in the second. The destination is in the CADR, the CAR file doesn't exist. But we store the files in DIR1 because they are coming from branch1")
[FOR GFILE IN (CDR DLIST)
DO (IF (EQ (CADDR GFILE)
100)
THEN (PUSH MAPPINGS (LIST [FULLNAME (GIT-GET-FILE
BRANCH1
(CADR GFILE)
(CONCAT DIR1 (CADR GFILE]
(CONCAT DIR2 (CAR GFILE))
'R))
ELSE (* ;
 "Deleted from MERGE, added to BRANCH1")
(GIT-GET-FILE MERGE (CAR GFILE)
(CONCAT DIR1 (CAR GFILE)))
(GIT-GET-FILE BRANCH1 (CADR GFILE)
(CONCAT DIR2 (CADR GFILE])
(COPIED
(* ;; "Same issue as for renaming")
[FOR GFILE IN (CDR DLIST)
DO (PUSH MAPPINGS (LIST [FULLNAME (GIT-GET-FILE BRANCH1 (CADR GFILE)
(CONCAT DIR1 (CADR GFILE]
(CONCAT DIR2 (CAR GFILE))
'C])
(HELP "UNKNOWN GIT-DIFF TAG" DLIST)))
(LIST DIR1 DIR2 MAPPINGS))])
(GIT-COMPARE-BRANCHES
[LAMBDA (BRANCH1 BRANCH2 LOCAL) (* ; "Edited 19-Feb-2022 10:21 by rmk")
[LAMBDA (BRANCH1 BRANCH2 LOCAL) (* ; "Edited 22-Feb-2022 22:53 by rmk")
(* ; "Edited 19-Feb-2022 10:21 by rmk")
(* ; "Edited 13-Feb-2022 21:27 by rmk")
(* ; "Edited 2-Feb-2022 08:46 by rmk")
(* ; "Edited 28-Jan-2022 23:58 by rmk")
@@ -787,9 +970,10 @@
(SETQ BRANCH2 (GITORIGIN (OR BRANCH2 "master")
LOCAL))
(PRINTOUT T "Comparing all subdirectories of " BRANCH1 " and " BRANCH2 T)
(LET (CDVALUE DIRS NENTRIES)
(LET (CDVALUE DIRS NENTRIES MAPPINGS)
(PRINTOUT T "Fetching differences" T)
(SETQ DIRS (GIT-GET-DIFFERENT-FILES BRANCH1 BRANCH2))
(SETQ MAPPINGS (CADDR DIRS))
(IF DIRS
THEN (TERPRI T)
(SETQ CDVALUE (COMPAREDIRECTORIES (CAR DIRS)
@@ -802,22 +986,42 @@
(* ;;
 " Also, lower case the directories. Perhaps can be done when the files are fetched?")
[CDMAP CDVALUE (FUNCTION (LAMBDA (CDE)
(DECLARE (USEDFREE INFO1 INFO2))
(CL:WHEN INFO1
(CHANGE (FETCH (CDINFO FULLNAME) OF INFO1)
(SLASHIT (CL:IF
(STRPOS ";1" DATUM -2 NIL T)
(SUBSTRING DATUM 1 -3)
DATUM)
T)))
(CL:WHEN INFO2
(CHANGE (FETCH (CDINFO FULLNAME) OF INFO2)
(SLASHIT (CL:IF
(STRPOS ";1" DATUM -2 NIL T)
(SUBSTRING DATUM 1 -3)
DATUM)
T)))]
[CDMAP CDVALUE
(FUNCTION (LAMBDA (CDE)
(DECLARE (USEDFREE INFO1 INFO2))
(LET [(MAP (CL:UNLESS INFO2
(FIND M IN MAPPINGS
SUCHTHAT (STRING.EQUAL (CAR M)
(FETCH (CDINFO FULLNAME)
OF INFO1)
FILEDIRCASEARRAY)))]
(CL:WHEN INFO1
(CHANGE (FETCH (CDINFO FULLNAME) OF INFO1)
(SLASHIT (CL:IF (STRPOS ";1" DATUM -2 NIL T)
(SUBSTRING DATUM 1 -3)
DATUM)
T)))
(CL:WHEN INFO2
(CHANGE (FETCH (CDINFO FULLNAME) OF INFO2)
(SLASHIT (CL:IF (STRPOS ";1" DATUM -2 NIL T)
(SUBSTRING DATUM 1 -3)
DATUM)
T)))
(IF MAP
THEN
(* ;; "This handles renames and copies. We want the nominal source of a rename to be in the first column, even though the target location is the one that was fetched.")
(REPLACE (CDENTRY INFO2) OF CDE
WITH (CREATE CDINFO
FULLNAME _ (CADR MAP)
DATE _ ""
LENGTH _ ""
AUTHOR _ ""
TYPE _ ""
EOL _ ""))
(REPLACE (CDENTRY DATEREL) OF CDE
WITH (CADDR MAP]
(TERPRI T)
(IF (FETCH (CDVALUE CDENTRIES) OF CDVALUE)
THEN (SETQ LAST-BRANCH-CDVALUE CDVALUE)
@@ -839,7 +1043,7 @@
[LAMBDA (SUBDIRS SELECT EXCLUDEDFILES TEDIT FIXDIRECTORYDATES UPDATE HOST1 HOST2)
(* ;;
 "Edited 19-Feb-2022 10:19 by rmk: my medley subdirectories with the current local git branch.")
 "Edited 26-Feb-2022 11:58 by rmk: my medley subdirectories with the current local git branch.")
(* ;; "Compares my medley subdirectories with the current local git branch.")
@@ -859,7 +1063,7 @@
(for SUBDIR TITLE CDVAL (NENTRIES _ 0)
(BRANCH2 _ (GIT-WHICH-BRANCH)) INSIDE SUBDIRS
collect (TERPRI T)
(SETQ CDVAL (COMPAREDIRECTORIES (MEDLEYSUBDIR SUBDIR T)
(SETQ CDVAL (COMPAREDIRECTORIES (MYMEDLEYSUBDIR SUBDIR T)
(GITSUBDIR SUBDIR T)
(OR SELECT '(> < ~= -* *-))
NIL GIT-IGNORE-FILES NIL NIL NIL FIXDIRECTORYDATES))
@@ -1062,7 +1266,8 @@
(OR LABEL2 FILE2])
(GIT-CD-MENUFN
[LAMBDA (TBITEM MENUITEM CDBROWSER KEY) (* ; "Edited 5-Feb-2022 17:36 by rmk")
[LAMBDA (TBITEM MENUITEM CDBROWSER KEY) (* ; "Edited 24-Feb-2022 11:30 by rmk")
(* ; "Edited 5-Feb-2022 17:36 by rmk")
(* ; "Edited 19-Dec-2021 23:28 by rmk")
(* ; "Edited 16-Dec-2021 13:49 by rmk")
(* ; "Edited 10-Dec-2021 08:52 by rmk")
@@ -1076,7 +1281,8 @@
(IF FILE1
THEN (PRIN3 "Use 'Delete BOTH' instead")
ELSE (GIVE.TTY.PROCESS PWINDOW)
(CL:WHEN (EQ 'Y (ASKUSER NIL 'N (CONCAT "Delete " LABEL2 " ? ")))
(CL:WHEN [OR (EQ KEY 'MIDDLE)
(EQ 'Y (ASKUSER NIL 'N (CONCAT "Delete " LABEL2 " ? "]
(GIT-DELETE-FILE FILE2)
(TB.DELETE.ITEM CDBROWSER TBITEM))))
(|Delete ALL <-|
@@ -1084,9 +1290,10 @@
(IF FILE2
THEN (PRIN3 "Use 'Delete BOTH' instead")
ELSE (GIVE.TTY.PROCESS PWINDOW)
(CL:WHEN (EQ 'Y (ASKUSER NIL 'N (CONCAT "Delete ALL versions of "
(NAMEFIELD LABEL1 T)
" ? ")))
(CL:WHEN [OR (EQ KEY 'MIDDLE)
(EQ 'Y (ASKUSER NIL 'N (CONCAT "Delete ALL versions of "
(NAMEFIELD LABEL1 T)
" ? "]
(MYMEDLEY-DELETE-FILES FILE1)
(TB.DELETE.ITEM CDBROWSER TBITEM))))
(Delete% BOTH (FLASHWINDOW PWINDOW)
@@ -1101,6 +1308,8 @@
(SHOULDNT])
)
(RPAQ? FROMGITN 0)
(* ;; "")
@@ -1124,15 +1333,17 @@
" ; "])
(GIT-COMMAND
[LAMBDA (CMD ALL NOERROR) (* ; "Edited 3-Jan-2022 10:47 by rmk")
(* ; "Edited 24-Nov-2021 16:44 by rmk:")
(* ; "Edited 16-Nov-2021 09:07 by rmk:")
(* ; "Edited 2-Nov-2021 21:08 by rmk:")
(* ; "Edited 7-Oct-2021 11:15 by rmk:")
[LAMBDA (CMD ALL NOERROR) (* ; "Edited 25-Feb-2022 09:25 by rmk")
(* ; "Edited 3-Jan-2022 10:47 by rmk")
(* ; "Edited 24-Nov-2021 16:44 by rmk:")
(* ; "Edited 16-Nov-2021 09:07 by rmk:")
(* ; "Edited 2-Nov-2021 21:08 by rmk:")
(* ; "Edited 7-Oct-2021 11:15 by rmk:")
(* ;; "Suppress .git lines unless ALL")
(CL:UNLESS (EQ 1 (STRPOS "git" CMD))
(CL:UNLESS (OR (EQ 1 (STRPOS "git" CMD))
(EQ 1 (STRPOS "gh" CMD)))
(SETQ CMD (CONCAT "git " CMD)))
[BIND LPOS WHILE (SETQ LPOS (STRPOS "local/" CMD))
DO (SETQ CMD (CONCAT (SUBSTRING CMD 1 (SUB1 LPOS))
@@ -1146,7 +1357,10 @@
WHEN [PROGN (SETQ LINE (CL:READ-LINE STREAM :EOF-ERROR-P NIL :EOF-VALUE NIL))
(OR ALL (NOT (STRPOS ".git" LINE 1 NIL T] COLLECT LINE
FINALLY (CL:UNLESS NOERROR
(CL:WHEN (STRPOS "fatal" (CAR $$VAL))
(CL:WHEN (OR (EQ 1 (STRPOS "fatal" (CAR $$VAL)
1 NIL NIL T))
(EQ 1 (STRPOS "gh: Command not found" (CAR $$VAL)
1 NIL NIL T)))
(ERROR (CONCAT "Git command %"" CMD "%" failed")
(CAR $$VAL))))])
@@ -1174,22 +1388,22 @@
(ERROR "INITIALS is not set"])
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (3466 4312 (GIT-CLONEP 3476 . 4310)) (5552 7490 (ALLSUBDIRS 5562 . 6688) (MEDLEYSUBDIRS
6690 . 7129) (GITSUBDIRS 7131 . 7488)) (7491 12965 (TOGIT 7501 . 9649) (FROMGIT 9651 . 10629) (
GIT-DELETE-FILE 10631 . 11525) (MYMEDLEY-DELETE-FILES 11527 . 12963)) (12966 15362 (MEDLEYSUBDIR 12976
. 13416) (GITSUBDIR 13418 . 13994) (STRIPDIR 13996 . 14367) (STRIPHOST 14369 . 14605) (STRIPNAME
14607 . 15360)) (15363 16664 (GFILE4MFILE 15373 . 15619) (MFILE4GFILE 15621 . 15963) (
GIT-REPO-FILENAME 15965 . 16662)) (16713 23632 (GIT-COMMIT 16723 . 17301) (GIT-PUSH 17303 . 17859) (
GIT-PULL 17861 . 18267) (GIT-BRANCH-DIFF 18269 . 19464) (GIT-APPROVAL 19466 . 19667) (GIT-GET-FILE
19669 . 21044) (GIT-FILE-EXISTS? 21046 . 21770) (GIT-REMOTE-UPDATE 21772 . 22814) (GIT-REMOTE-ADD
22816 . 23123) (GIT-FILE-DATE 23125 . 23630)) (23677 27854 (GIT-CHECKOUT 23687 . 23928) (
GIT-WHICH-BRANCH 23930 . 24514) (GIT-MAKE-BRANCH 24516 . 26007) (GIT-BRANCHES 26009 . 26789) (
GIT-BRANCH-EXISTS? 26791 . 27852)) (27884 30589 (GIT-MY-CURRENT-BRANCH 27894 . 28067) (GIT-MY-BRANCHP
28069 . 28988) (GIT-MY-NEXT-BRANCH 28990 . 29431) (GIT-MY-BRANCHES 29433 . 30587)) (30635 34405 (
GIT-ADD-WORKTREE 30645 . 32405) (GIT-REMOVE-WORKTREE 32407 . 32985) (GIT-LIST-WORKTREES 32987 . 33791)
(WORKTREEDIR 33793 . 34403)) (34453 55532 (GIT-GET-DIFFERENT-FILES 34463 . 36052) (
GIT-COMPARE-BRANCHES 36054 . 39902) (GIT-COMPARE-WITH-MYMEDLEY 39904 . 43622) (GIT-COMPARE-WORKTREE
43624 . 47101) (GITCDOBJBUTTONFN 47103 . 52107) (GIT-CD-LABELFN 52109 . 53191) (GIT-CD-MENUFN 53193 .
55530)) (55578 58625 (CDGITDIR 55588 . 56168) (GIT-COMMAND 56170 . 57738) (GITORIGIN 57740 . 58317) (
GIT-INITIALS 58319 . 58623)))))
(FILEMAP (NIL (4364 5210 (GIT-CLONEP 4374 . 5208)) (7068 9104 (ALLSUBDIRS 7078 . 8302) (MEDLEYSUBDIRS
8304 . 8743) (GITSUBDIRS 8745 . 9102)) (9105 14579 (TOGIT 9115 . 11263) (FROMGIT 11265 . 12243) (
GIT-DELETE-FILE 12245 . 13139) (MYMEDLEY-DELETE-FILES 13141 . 14577)) (14580 16729 (MYMEDLEYSUBDIR
14590 . 15036) (GITSUBDIR 15038 . 15361) (STRIPDIR 15363 . 15734) (STRIPHOST 15736 . 15972) (STRIPNAME
15974 . 16727)) (16730 18258 (GFILE4MFILE 16740 . 16986) (MFILE4GFILE 16988 . 17330) (
GIT-REPO-FILENAME 17332 . 18256)) (18307 28711 (GIT-COMMIT 18317 . 18895) (GIT-PUSH 18897 . 19453) (
GIT-PULL 19455 . 19861) (GIT-BRANCH-DIFF 19863 . 23715) (GIT-APPROVAL 23717 . 23918) (GIT-GET-FILE
23920 . 26123) (GIT-FILE-EXISTS? 26125 . 26849) (GIT-REMOTE-UPDATE 26851 . 27893) (GIT-REMOTE-ADD
27895 . 28202) (GIT-FILE-DATE 28204 . 28709)) (28756 34375 (GIT-CHECKOUT 28766 . 29007) (
GIT-WHICH-BRANCH 29009 . 29593) (GIT-MAKE-BRANCH 29595 . 31086) (GIT-BRANCHES 31088 . 32066) (
GIT-BRANCH-EXISTS? 32068 . 33129) (PICK-BRANCH 33131 . 33475) (GIT-PULL-REQUESTS 33477 . 34373)) (
34405 37110 (GIT-MY-CURRENT-BRANCH 34415 . 34588) (GIT-MY-BRANCHP 34590 . 35509) (GIT-MY-NEXT-BRANCH
35511 . 35952) (GIT-MY-BRANCHES 35954 . 37108)) (37156 40926 (GIT-ADD-WORKTREE 37166 . 38926) (
GIT-REMOVE-WORKTREE 38928 . 39506) (GIT-LIST-WORKTREES 39508 . 40312) (WORKTREEDIR 40314 . 40924)) (
40974 67428 (GIT-GET-DIFFERENT-FILES 40984 . 46074) (GIT-COMPARE-BRANCHES 46076 . 51568) (
GIT-COMPARE-WITH-MYMEDLEY 51570 . 55290) (GIT-COMPARE-WORKTREE 55292 . 58769) (GITCDOBJBUTTONFN 58771
. 63775) (GIT-CD-LABELFN 63777 . 64859) (GIT-CD-MENUFN 64861 . 67426)) (67498 70950 (CDGITDIR 67508
. 68088) (GIT-COMMAND 68090 . 70063) (GITORIGIN 70065 . 70642) (GIT-INITIALS 70644 . 70948)))))
STOP

Binary file not shown.

Binary file not shown.