github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-01-13 15:37:38 +00:00
Code Issues Projects Releases Wiki Activity

GITFNS gwc looks at all subdirectories, like prc (#2131)

Browse Source 
Co-authored-by: Matt Heffron <heffron@alumni.caltech.edu>
This commit is contained in:
rmkaplan 2025-05-14 10:11:29 -07:00 committed by GitHub
parent 9feba7f7c7
commit 7ad65469b1
No known key found for this signature in database
GPG Key ID: B5690EEEBB952194
2 changed files with 204 additions and 201 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

405
lispusers/GITFNS
View File

@ -1,28 +1,29 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "31-Mar-2025 21:25:00" {WMEDLEY}<lispusers>GITFNS.;539 133841 (FILECREATED "29-Apr-2025 15:17:37" {WMEDLEY}<lispusers>GITFNS.;541 134267
:EDIT-BY rmk :EDIT-BY rmk
:CHANGES-TO (FNS GIT-GET-FILE GIT-RESULT-TO-LINES) :CHANGES-TO (VARS GITFNSCOMS)
(FNS GIT-WORKING-COMPARE-DIRECTORIES)
:PREVIOUS-DATE "21-Mar-2025 19:07:34" {WMEDLEY}<lispusers>GITFNS.;536) :PREVIOUS-DATE "31-Mar-2025 21:25:00" {WMEDLEY}<lispusers>GITFNS.;539)
(PRETTYCOMPRINT GITFNSCOMS) (PRETTYCOMPRINT GITFNSCOMS)
(RPAQQ GITFNSCOMS (RPAQQ GITFNSCOMS
( (
(* ;; "Set up") (* ;; "Set up")
(FILES (SYSLOAD FROM LISPUSERS) (FILES (SYSLOAD FROM LISPUSERS)
COMPAREDIRECTORIES COMPARESOURCES COMPARETEXT PSEUDOHOSTS JSON UNIXUTILS REGIONMANAGER COMPAREDIRECTORIES COMPARESOURCES COMPARETEXT PSEUDOHOSTS JSON UNIXUTILS REGIONMANAGER
) )
(* ;; "") (* ;; "")
(* ;; "GIT projects") (* ;; "GIT projects")
(COMS (FNS GIT-CLONEP GIT-INIT GIT-MAKE-PROJECT GIT-GET-PROJECT GIT-PUT-PROJECT-FIELD (COMS (FNS GIT-CLONEP GIT-INIT GIT-MAKE-PROJECT GIT-GET-PROJECT GIT-PUT-PROJECT-FIELD
GIT-PROJECT-PATH FIND-ANCESTOR-DIRECTORY GIT-FIND-CLONE GIT-MAINBRANCH GIT-PROJECT-PATH FIND-ANCESTOR-DIRECTORY GIT-FIND-CLONE GIT-MAINBRANCH
@ -43,94 +44,94 @@
(P (GIT-INIT)) (P (GIT-INIT))
(ADDVARS (AROUNDEXITFNS GIT-INIT)) (ADDVARS (AROUNDEXITFNS GIT-INIT))
(* ;; "") (* ;; "")
(* ;; "Lisp exec commands") (* ;; "Lisp exec commands")
(INITVARS (GIT-MERGE-COMPARES T) (INITVARS (GIT-MERGE-COMPARES T)
(GIT-CDBROWSER-SEPARATE-DIRECTIONS T)) (GIT-CDBROWSER-SEPARATE-DIRECTIONS T))
(COMMANDS gwc bbc prc cob b? cdg cdw) (COMMANDS gwc bbc prc cob b? cdg cdw)
(FNS PRC-COMMAND) (FNS PRC-COMMAND)
(* ;; "") (* ;; "")
(* ;; "File correspondents") (* ;; "File correspondents")
(FNS ALLSUBDIRS MEDLEYSUBDIRS GITSUBDIRS) (FNS ALLSUBDIRS MEDLEYSUBDIRS GITSUBDIRS)
(FNS TOGIT FROMGIT GIT-DELETE-FILE MYMEDLEY-DELETE-FILES) (FNS TOGIT FROMGIT GIT-DELETE-FILE MYMEDLEY-DELETE-FILES)
(FNS MYMEDLEYSUBDIR GITSUBDIR STRIPDIR STRIPHOST STRIPNAME STRIPWHERE) (FNS MYMEDLEYSUBDIR GITSUBDIR STRIPDIR STRIPHOST STRIPNAME STRIPWHERE)
(FNS GFILE4MFILE MFILE4GFILE GIT-REPO-FILENAME) (FNS GFILE4MFILE MFILE4GFILE GIT-REPO-FILENAME)
(* ;; "") (* ;; "")
(* ;; "Git commands") (* ;; "Git commands")
(FNS GIT-COMMIT GIT-PUSH GIT-PULL GIT-APPROVAL GIT-GET-FILE GIT-FILE-EXISTS? (FNS GIT-COMMIT GIT-PUSH GIT-PULL GIT-APPROVAL GIT-GET-FILE GIT-FILE-EXISTS?
GIT-REMOTE-UPDATE GIT-REMOTE-ADD GIT-FILE-DATE GIT-FILE-HISTORY GIT-PRINT-FILE-HISTORY GIT-REMOTE-UPDATE GIT-REMOTE-ADD GIT-FILE-DATE GIT-FILE-HISTORY GIT-PRINT-FILE-HISTORY
GIT-FETCH) GIT-FETCH)
(* ;; "Differences") (* ;; "Differences")
(FNS GIT-BRANCH-DIFF GIT-COMMIT-DIFFS GIT-BRANCH-RELATIONS) (FNS GIT-BRANCH-DIFF GIT-COMMIT-DIFFS GIT-BRANCH-RELATIONS)
(* ;; "") (* ;; "")
(* ;; "Branches") (* ;; "Branches")
(FNS GIT-BRANCH-NUM GIT-CHECKOUT GIT-WHICH-BRANCH GIT-MAKE-BRANCH GIT-BRANCHES (FNS GIT-BRANCH-NUM GIT-CHECKOUT GIT-WHICH-BRANCH GIT-MAKE-BRANCH GIT-BRANCHES
GIT-BRANCH-EXISTS? GIT-PICK-BRANCH GIT-BRANCH-MENU GIT-BRANCH-WHENSELECTEDFN GIT-BRANCH-EXISTS? GIT-PICK-BRANCH GIT-BRANCH-MENU GIT-BRANCH-WHENSELECTEDFN
GIT-PULL-REQUESTS GIT-SHORT-BRANCH-NAME GIT-LONG-NAME GIT-PRC-BRANCHES) GIT-PULL-REQUESTS GIT-SHORT-BRANCH-NAME GIT-LONG-NAME GIT-PRC-BRANCHES)
(* ;; "My branches") (* ;; "My branches")
(FNS GIT-MY-CURRENT-BRANCH GIT-MY-BRANCHP GIT-MY-NEXT-BRANCH GIT-MY-BRANCHES) (FNS GIT-MY-CURRENT-BRANCH GIT-MY-BRANCHP GIT-MY-NEXT-BRANCH GIT-MY-BRANCHES)
(* ;; "") (* ;; "")
(* ;; "Worktrees") (* ;; "Worktrees")
(FNS GIT-ADD-WORKTREE GIT-REMOVE-WORKTREE GIT-LIST-WORKTREES WORKTREEDIR) (FNS GIT-ADD-WORKTREE GIT-REMOVE-WORKTREE GIT-LIST-WORKTREES WORKTREEDIR)
(* ;; "") (* ;; "")
(* ;; "Comparisons") (* ;; "Comparisons")
(FNS GIT-GET-DIFFERENT-FILES GIT-BRANCHES-COMPARE-DIRECTORIES GIT-WORKING-COMPARE-DIRECTORIES (FNS GIT-GET-DIFFERENT-FILES GIT-BRANCHES-COMPARE-DIRECTORIES GIT-WORKING-COMPARE-DIRECTORIES
GIT-COMPARE-WORKTREE GITCDOBJBUTTONFN GIT-CD-LABELFN GIT-CD-MENUFN GIT-COMPARE-WORKTREE GITCDOBJBUTTONFN GIT-CD-LABELFN GIT-CD-MENUFN
GIT-WORKING-COMPARE-FILES GIT-BRANCHES-COMPARE-FILES GIT-PR-COMPARE) GIT-WORKING-COMPARE-FILES GIT-BRANCHES-COMPARE-FILES GIT-PR-COMPARE)
(INITVARS (FROMGITN 0)) (INITVARS (FROMGITN 0))
(* ;; "") (* ;; "")
(* ;; "Utilities") (* ;; "Utilities")
(FNS CDGITDIR GIT-COMMAND GITORIGIN GIT-INITIALS GIT-COMMAND-TO-FILE GIT-RESULT-TO-LINES (FNS CDGITDIR GIT-COMMAND GITORIGIN GIT-INITIALS GIT-COMMAND-TO-FILE GIT-RESULT-TO-LINES
STRIPLOCAL) STRIPLOCAL)
(PROPS (GITFNS FILETYPE)))) (PROPS (GITFNS FILETYPE))))
(* ;; "Set up") (* ;; "Set up")
(FILESLOAD (SYSLOAD FROM LISPUSERS) (FILESLOAD (SYSLOAD FROM LISPUSERS)
COMPAREDIRECTORIES COMPARESOURCES COMPARETEXT PSEUDOHOSTS JSON UNIXUTILS REGIONMANAGER) COMPAREDIRECTORIES COMPARESOURCES COMPARETEXT PSEUDOHOSTS JSON UNIXUTILS REGIONMANAGER)
(* ;; "") (* ;; "")
(* ;; "GIT projects") (* ;; "GIT projects")
(DEFINEQ (DEFINEQ
@ -401,15 +402,15 @@
(DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE (DECLARE%: EVAL@COMPILE
(TYPERECORD GIT-PROJECT (PROJECTNAME GITHOST WHOST EXCLUSIONS DEFAULTSUBDIRS CLONEPATH MAINBRANCH)) (TYPERECORD GIT-PROJECT (PROJECTNAME GITHOST WHOST EXCLUSIONS DEFAULTSUBDIRS CLONEPATH MAINBRANCH))
(RECORD PULLREQUEST (PRNUMBER PRDESCRIPTION PRNAME PRSTATUS PRPROJECT PRURL PRLOGIN)) (RECORD PULLREQUEST (PRNUMBER PRDESCRIPTION PRNAME PRSTATUS PRPROJECT PRURL PRLOGIN))
) )
) )
(RPAQ? GIT-DEFAULT-PROJECT 'MEDLEY) (RPAQ? GIT-DEFAULT-PROJECT 'MEDLEY)
(RPAQ? GIT-DEFAULT-PROJECTS (RPAQ? GIT-DEFAULT-PROJECTS
'((MEDLEY NIL NIL (EXPORTS.ALL RDSYS RDSYS.LCOM loadups/ patches/ tmp/ fontsold/ clos/ cltl2/) '((MEDLEY NIL NIL (EXPORTS.ALL RDSYS RDSYS.LCOM loadups/ patches/ tmp/ fontsold/ clos/ cltl2/)
(greetfiles scripts sources library lispusers internal doctools rooms)) (greetfiles scripts sources library lispusers internal doctools rooms))
(NOTECARDS) (NOTECARDS)
@ -417,120 +418,120 @@
(TEST) (TEST)
(MAIKO))) (MAIKO)))
(RPAQ? GIT-PROJECTS NIL) (RPAQ? GIT-PROJECTS NIL)
(RPAQ? GIT-PRC-MENUS NIL) (RPAQ? GIT-PRC-MENUS NIL)
(GIT-INIT) (GIT-INIT)
(ADDTOVAR AROUNDEXITFNS GIT-INIT) (ADDTOVAR AROUNDEXITFNS GIT-INIT)
(* ;; "") (* ;; "")
(* ;; "Lisp exec commands") (* ;; "Lisp exec commands")
(RPAQ? GIT-MERGE-COMPARES T) (RPAQ? GIT-MERGE-COMPARES T)
(RPAQ? GIT-CDBROWSER-SEPARATE-DIRECTIONS T) (RPAQ? GIT-CDBROWSER-SEPARATE-DIRECTIONS T)
(DEFCOMMAND gwc (SUBDIR . OTHERS) (DEFCOMMAND gwc (SUBDIR . OTHERS)
(* ;; "Compares the specified local git-medley subdirectories against my working Medley. The SUBDIRS are the arguments up to one that looks like a project") (* ;; "Compares the specified local git-medley subdirectories against my working Medley. The SUBDIRS are the arguments up to one that looks like a project")
(LET ((SUBDIRS (AND SUBDIR (CONS SUBDIR OTHERS))) (LET ((SUBDIRS (AND SUBDIR (CONS SUBDIR OTHERS)))
PROJECT) PROJECT)
(SETQ SUBDIRS (FOR STAIL ON SUBDIRS COLLECT (IF (GIT-GET-PROJECT (CAR STAIL) (SETQ SUBDIRS (FOR STAIL ON SUBDIRS COLLECT (IF (GIT-GET-PROJECT (CAR STAIL)
NIL T) NIL T)
THEN (SETQ PROJECT (CAR STAIL)) THEN (SETQ PROJECT (CAR STAIL))
(GO $$OUT)) (GO $$OUT))
(CAR STAIL))) (CAR STAIL)))
(GIT-WORKING-COMPARE-DIRECTORIES SUBDIRS NIL NIL NIL T PROJECT))) (GIT-WORKING-COMPARE-DIRECTORIES SUBDIRS NIL NIL NIL T PROJECT)))
(DEFCOMMAND bbc (BRANCH1 BRANCH2 LOCAL PROJECT) (DEFCOMMAND bbc (BRANCH1 BRANCH2 LOCAL PROJECT)
(* ;; "Compares 2 git branches. Defaults to local/ if LOCAL, otherwise defaults to origin/. BRANCH2 defaults to the main branch (origin/ or local/ depending on LOCAL)") (* ;; "Compares 2 git branches. Defaults to local/ if LOCAL, otherwise defaults to origin/. BRANCH2 defaults to the main branch (origin/ or local/ depending on LOCAL)")
(SETQ PROJECT (GIT-GET-PROJECT PROJECT)) (SETQ PROJECT (GIT-GET-PROJECT PROJECT))
(GIT-FETCH PROJECT) (GIT-FETCH PROJECT)
(SETQ BRANCH1 (SELECTQ (U-CASE BRANCH1) (SETQ BRANCH1 (SELECTQ (U-CASE BRANCH1)
((NIL T) ((NIL T)
(GIT-MY-CURRENT-BRANCH PROJECT)) (GIT-MY-CURRENT-BRANCH PROJECT))
((LOCAL REMOTE ORIGIN) ((LOCAL REMOTE ORIGIN)
(GIT-PICK-BRANCH (GIT-BRANCHES BRANCH1 PROJECT T))) (GIT-PICK-BRANCH (GIT-BRANCHES BRANCH1 PROJECT T)))
(OR (GIT-LONG-NAME BRANCH1 NIL PROJECT) (OR (GIT-LONG-NAME BRANCH1 NIL PROJECT)
BRANCH1))) BRANCH1)))
(SETQ BRANCH2 (SELECTQ (U-CASE BRANCH2) (SETQ BRANCH2 (SELECTQ (U-CASE BRANCH2)
((NIL T) ((NIL T)
(GIT-MAINBRANCH PROJECT LOCAL)) (GIT-MAINBRANCH PROJECT LOCAL))
((LOCAL REMOTE ORIGIN) ((LOCAL REMOTE ORIGIN)
(GIT-PICK-BRANCH (GIT-BRANCHES BRANCH2 PROJECT T))) (GIT-PICK-BRANCH (GIT-BRANCHES BRANCH2 PROJECT T)))
(OR (GIT-LONG-NAME BRANCH2 NIL PROJECT) (OR (GIT-LONG-NAME BRANCH2 NIL PROJECT)
BRANCH2))) BRANCH2)))
(GIT-BRANCHES-COMPARE-DIRECTORIES BRANCH1 (OR BRANCH2 (GIT-MAINBRANCH PROJECT LOCAL)) (GIT-BRANCHES-COMPARE-DIRECTORIES BRANCH1 (OR BRANCH2 (GIT-MAINBRANCH PROJECT LOCAL))
LOCAL PROJECT)) LOCAL PROJECT))
(DEFCOMMAND prc (REMOTEBRANCH DRAFTS PROJECT) (DEFCOMMAND prc (REMOTEBRANCH DRAFTS PROJECT)
(* ;; "Compares REMOTEBRANCH against the main orign branch, for pull-request assessment") (* ;; "Compares REMOTEBRANCH against the main orign branch, for pull-request assessment")
(PRC-COMMAND REMOTEBRANCH DRAFTS PROJECT)) (PRC-COMMAND REMOTEBRANCH DRAFTS PROJECT))
(DEFCOMMAND cob (BRANCH NEXTTITLESTRING PROJECT) (DEFCOMMAND cob (BRANCH NEXTTITLESTRING PROJECT)
(* ;; "Switches to BRANCH. T means my current branch, NEW/NEXT means my next branch (under wherever we are now), and NEXTTITLESTRING if given will be attached to the branch-name. Default is to bring up a menu of locally available branches.") (* ;; "Switches to BRANCH. T means my current branch, NEW/NEXT means my next branch (under wherever we are now), and NEXTTITLESTRING if given will be attached to the branch-name. Default is to bring up a menu of locally available branches.")
(CL:UNLESS (STRINGP NEXTTITLESTRING) (CL:UNLESS (STRINGP NEXTTITLESTRING)
(SETQ PROJECT NEXTTITLESTRING)) (SETQ PROJECT NEXTTITLESTRING))
(CL:UNLESS PROJECT (CL:UNLESS PROJECT
(CL:WHEN (GIT-GET-PROJECT BRANCH NIL T) (CL:WHEN (GIT-GET-PROJECT BRANCH NIL T)
(SETQ PROJECT BRANCH) (SETQ PROJECT BRANCH)
(SETQ BRANCH NIL))) (SETQ BRANCH NIL)))
(SETQ PROJECT (GIT-GET-PROJECT PROJECT)) (SETQ PROJECT (GIT-GET-PROJECT PROJECT))
(GIT-FETCH PROJECT) (GIT-FETCH PROJECT)
(SELECTQ (U-CASE BRANCH) (SELECTQ (U-CASE BRANCH)
(T (GIT-CHECKOUT (GIT-MY-CURRENT-BRANCH PROJECT) (T (GIT-CHECKOUT (GIT-MY-CURRENT-BRANCH PROJECT)
PROJECT)) PROJECT))
((NEW NEXT) ((NEW NEXT)
(GIT-MAKE-BRANCH NIL NEXTTITLESTRING PROJECT)) (GIT-MAKE-BRANCH NIL NEXTTITLESTRING PROJECT))
(CL:WHEN [SETQ BRANCH (IF BRANCH (CL:WHEN [SETQ BRANCH (IF BRANCH
THEN (GIT-LONG-NAME BRANCH NIL PROJECT) THEN (GIT-LONG-NAME BRANCH NIL PROJECT)
ELSE (GIT-PICK-BRANCH (GIT-BRANCHES 'LOCAL PROJECT T) ELSE (GIT-PICK-BRANCH (GIT-BRANCHES 'LOCAL PROJECT T)
(CONCAT (L-CASE (GIT-GET-PROJECT PROJECT 'PROJECTNAME) (CONCAT (L-CASE (GIT-GET-PROJECT PROJECT 'PROJECTNAME)
T) T)
" branches"] " branches"]
(GIT-CHECKOUT BRANCH PROJECT)))) (GIT-CHECKOUT BRANCH PROJECT))))
(DEFCOMMAND b? (PROJECT) (SETQ PROJECT (GIT-GET-PROJECT PROJECT)) (DEFCOMMAND b? (PROJECT) (SETQ PROJECT (GIT-GET-PROJECT PROJECT))
(GIT-FETCH PROJECT) (GIT-FETCH PROJECT)
(CONCAT (L-CASE (GIT-GET-PROJECT PROJECT 'PROJECTNAME) (CONCAT (L-CASE (GIT-GET-PROJECT PROJECT 'PROJECTNAME)
T) T)
" " " "
(GIT-WHICH-BRANCH PROJECT))) (GIT-WHICH-BRANCH PROJECT)))
(DEFCOMMAND cdg (PROJECT SUBDIR) (CL:UNLESS (GIT-GET-PROJECT PROJECT NIL T) (DEFCOMMAND cdg (PROJECT SUBDIR) (CL:UNLESS (GIT-GET-PROJECT PROJECT NIL T)
(SETQ SUBDIR PROJECT) (SETQ SUBDIR PROJECT)
(SETQ PROJECT GIT-DEFAULT-PROJECT)) (SETQ PROJECT GIT-DEFAULT-PROJECT))
(CL:WHEN [AND SUBDIR (NOT (MEMB (CHCON1 SUBDIR)) (CL:WHEN [AND SUBDIR (NOT (MEMB (CHCON1 SUBDIR))
(CHARCODE (> /] (CHARCODE (> /]
(SETQ SUBDIR (CONCAT SUBDIR "/"))) (SETQ SUBDIR (CONCAT SUBDIR "/")))
(SLASHIT (/CNDIR (CONCAT (GIT-GET-PROJECT PROJECT 'GITHOST) (SLASHIT (/CNDIR (CONCAT (GIT-GET-PROJECT PROJECT 'GITHOST)
(OR SUBDIR ""))) (OR SUBDIR "")))
T)) T))
(DEFCOMMAND cdw (PROJECT SUBDIR) (CL:UNLESS (GIT-GET-PROJECT PROJECT NIL T) (DEFCOMMAND cdw (PROJECT SUBDIR) (CL:UNLESS (GIT-GET-PROJECT PROJECT NIL T)
(SETQ SUBDIR PROJECT) (SETQ SUBDIR PROJECT)
(SETQ PROJECT GIT-DEFAULT-PROJECT)) (SETQ PROJECT GIT-DEFAULT-PROJECT))
(CL:WHEN [AND SUBDIR (NOT (MEMB (CHCON1 SUBDIR)) (CL:WHEN [AND SUBDIR (NOT (MEMB (CHCON1 SUBDIR))
(CHARCODE (> /] (CHARCODE (> /]
(SETQ SUBDIR (CONCAT SUBDIR "/"))) (SETQ SUBDIR (CONCAT SUBDIR "/")))
(SLASHIT (/CNDIR (CONCAT (GIT-GET-PROJECT PROJECT 'WHOST) (SLASHIT (/CNDIR (CONCAT (GIT-GET-PROJECT PROJECT 'WHOST)
(OR SUBDIR ""))) (OR SUBDIR "")))
T)) T))
(DEFINEQ (DEFINEQ
@ -616,12 +617,12 @@
(* ;; "") (* ;; "")
(* ;; "File correspondents") (* ;; "File correspondents")
(DEFINEQ (DEFINEQ
@ -864,12 +865,12 @@
(* ;; "") (* ;; "")
(* ;; "Git commands") (* ;; "Git commands")
(DEFINEQ (DEFINEQ
@ -1073,7 +1074,7 @@
(* ;; "Differences") (* ;; "Differences")
(DEFINEQ (DEFINEQ
@ -1261,12 +1262,12 @@
(* ;; "") (* ;; "")
(* ;; "Branches") (* ;; "Branches")
(DEFINEQ (DEFINEQ
@ -1574,7 +1575,7 @@
(* ;; "My branches") (* ;; "My branches")
(DEFINEQ (DEFINEQ
@ -1641,12 +1642,12 @@
(* ;; "") (* ;; "")
(* ;; "Worktrees") (* ;; "Worktrees")
(DEFINEQ (DEFINEQ
@ -1717,12 +1718,12 @@
(* ;; "") (* ;; "")
(* ;; "Comparisons") (* ;; "Comparisons")
(DEFINEQ (DEFINEQ
@ -1934,98 +1935,100 @@
else '(0 differences)) else '(0 differences))
else '(0 differences]) else '(0 differences])
(GIT-WORKING-COMPARE-DIRECTORIES (GIT-WORKING-COMPARE-DIRECTORIES
[LAMBDA (SUBDIRS SELECT EXCLUDEDFILES FIXDIRECTORYDATES UPDATE PROJECT) [LAMBDA (SUBDIRS SELECT EXCLUDEDFILES FIXDIRECTORYDATES UPDATE PROJECT)
(* ;; "Edited 12-Jun-2024 22:52 by mth") (* ;; "Edited 29-Apr-2025 15:14 by rmk")
(* ;; "Edited 26-Sep-2023 22:41 by rmk") (* ;; "Edited 12-Jun-2024 22:52 by mth")
(* ;; "Edited 17-Jun-2023 22:54 by rmk") (* ;; "Edited 26-Sep-2023 22:41 by rmk")
(* ;; "Edited 10-Jun-2023 21:32 by rmk") (* ;; "Edited 17-Jun-2023 22:54 by rmk")
(* ;; "Edited 20-Jul-2022 21:18 by rmk") (* ;; "Edited 10-Jun-2023 21:32 by rmk")
(* ;; "Edited 25-Jun-2022 21:37 by rmk") (* ;; "Edited 20-Jul-2022 21:18 by rmk")
(* ;; "Edited 17-May-2022 17:39 by rmk") (* ;; "Edited 25-Jun-2022 21:37 by rmk")
(* ;; "Edited 10-May-2022 10:41 by rmk") (* ;; "Edited 17-May-2022 17:39 by rmk")
(* ;; "Edited 10-May-2022 10:41 by rmk")
(* ;; (* ;;
 "Edited 29-Mar-2022 13:58 by rmk: working medley subdirectories with the current local git branch.") "Edited 29-Mar-2022 13:58 by rmk: working medley subdirectories with the current local git branch.")
(SETQ PROJECT (GIT-GET-PROJECT PROJECT)) (SETQ PROJECT (GIT-GET-PROJECT PROJECT))
(CL:WHEN UPDATE (GIT-REMOTE-UPDATE NIL PROJECT)) (* ; "Doesn't matter if we are looking only at local files in the current branch. We aren't fetching or checking out.") (CL:WHEN UPDATE (GIT-REMOTE-UPDATE NIL PROJECT)) (* ; "Doesn't matter if we are looking only at local files in the current branch. We aren't fetching or checking out.")
(CL:UNLESS (AND (fetch GITHOST of PROJECT) (CL:UNLESS (AND (fetch GITHOST of PROJECT)
(fetch WHOST of PROJECT)) (fetch WHOST of PROJECT))
(ERROR (fetch PROJECTNAME of PROJECT) (ERROR (fetch PROJECTNAME of PROJECT)
" does not have both git and working directories")) " does not have both git and working directories"))
(CL:WHEN (AND (LISTP SUBDIRS) (CL:WHEN (AND (LISTP SUBDIRS)
(NULL (CDR SUBDIRS))) (NULL (CDR SUBDIRS)))
(SETQ SUBDIRS (CAR SUBDIRS))) (SETQ SUBDIRS (CAR SUBDIRS)))
(CL:UNLESS SUBDIRS (CL:UNLESS SUBDIRS
(SETQ SUBDIRS (OR (fetch DEFAULTSUBDIRS of PROJECT) (SETQ SUBDIRS (OR (fetch DEFAULTSUBDIRS of PROJECT)
'ALL))) 'ALL)))
(SETQ SUBDIRS (L-CASE SUBDIRS)) (SETQ SUBDIRS (L-CASE SUBDIRS))
(LET ((SUBDIRSTRING (if (EQ SUBDIRS 'all) (LET ((SUBDIRSTRING (if (EQ SUBDIRS 'all)
then (SETQ SUBDIRS (ALLSUBDIRS PROJECT)) then (SETQ SUBDIRS (ALLSUBDIRS PROJECT))
"ALL subdirectories" "ALL subdirectories"
else SUBDIRS))) else SUBDIRS)))
(for SUBDIR TITLE CDVAL (WPROJ _ (CONCAT "Working " (L-CASE (fetch PROJECTNAME of PROJECT) (for SUBDIR TITLE CDVAL (WPROJ _ (CONCAT "Working " (L-CASE (fetch PROJECTNAME of PROJECT)
T))) T)))
(NENTRIES _ 0) (NENTRIES _ 0)
(BRANCH2 _ (GIT-WHICH-BRANCH PROJECT T)) (BRANCH2 _ (GIT-WHICH-BRANCH PROJECT T))
first (PRINTOUT T "Comparing " SUBDIRSTRING 6 " of " WPROJ " and Git " BRANCH2 T) first (PRINTOUT T "Comparing " SUBDIRSTRING 6 " of " WPROJ " and Git " BRANCH2 T)
(BKSYSBUF " ") inside SUBDIRS (BKSYSBUF " ") inside SUBDIRS
collect (TERPRI T) collect (TERPRI T)
(SETQ CDVAL (COMPAREDIRECTORIES (MYMEDLEYSUBDIR SUBDIR T PROJECT) (SETQ CDVAL (COMPAREDIRECTORIES (MYMEDLEYSUBDIR SUBDIR T PROJECT)
(GITSUBDIR SUBDIR T PROJECT) (GITSUBDIR SUBDIR T PROJECT)
(OR SELECT '(> < ~= -* *-)) (OR SELECT '(> < ~= -* *-))
NIL '(*.* *>*.* .* *>.*)
(for E DPOS in (GIT-GET-PROJECT PROJECT 'EXCLUSIONS) (for E DPOS in (GIT-GET-PROJECT PROJECT 'EXCLUSIONS)
collect (SETQ DPOS (STRPOS SUBDIR (FILENAMEFIELD E collect (SETQ DPOS (STRPOS SUBDIR (FILENAMEFIELD E
'DIRECTORY) 'DIRECTORY)
1 NIL T T FILEDIRCASEARRAY)) 1 NIL T T FILEDIRCASEARRAY))
(CL:IF DPOS (CL:IF DPOS
(SUBSTRING E (ADD1 DPOS)) (SUBSTRING E (ADD1 DPOS))
E)) E))
NIL NIL NIL FIXDIRECTORYDATES)) NIL NIL NIL FIXDIRECTORYDATES))
[for CDE in (fetch CDENTRIES of CDVAL) [for CDE in (fetch CDENTRIES of CDVAL)
do (CL:WHEN (fetch INFO1 of CDE) do (CL:WHEN (fetch INFO1 of CDE)
(change (fetch (CDINFO FULLNAME) of (fetch INFO1 of CDE)) (change (fetch (CDINFO FULLNAME) of (fetch INFO1 of CDE))
(UNSLASHIT DATUM T))) (UNSLASHIT DATUM T)))
(CL:WHEN (fetch INFO2 of CDE) (CL:WHEN (fetch INFO2 of CDE)
(change (fetch (CDINFO FULLNAME) of (fetch INFO2 of CDE)) (change (fetch (CDINFO FULLNAME) of (fetch INFO2 of CDE))
(SLASHIT DATUM T)))] (SLASHIT DATUM T)))]
CDVAL CDVAL
finally finally
(* ;; "Set up the browsers after everything has been done, otherwise if the user doesn't pay attention it might hang waiting for a region.") (* ;; "Set up the browsers after everything has been done, otherwise if the user doesn't pay attention it might hang waiting for a region.")
(CL:WHEN (AND (CDR $$VAL) (CL:WHEN (AND (CDR $$VAL)
GIT-MERGE-COMPARES) GIT-MERGE-COMPARES)
(SETQ $$VAL (CDMERGE $$VAL)) (SETQ $$VAL (CDMERGE $$VAL))
[SETQ SUBDIRS (CONCATLIST (for SUBDIR in SUBDIRS collect (CONCAT SUBDIR " "]) [SETQ SUBDIRS (CONCATLIST (for SUBDIR in SUBDIRS collect (CONCAT SUBDIR " "])
[for CDVAL TITLE in $$VAL as SUBDIR inside SUBDIRS [for CDVAL TITLE in $$VAL as SUBDIR inside SUBDIRS
do (SETQ TITLE (CONCAT WPROJ " vs. " BRANCH2 " " SUBDIR " " do (SETQ TITLE (CONCAT WPROJ " vs. " BRANCH2 " " SUBDIR " "
(LENGTH (fetch (CDVALUE CDENTRIES) of CDVAL)) (LENGTH (fetch (CDVALUE CDENTRIES) of CDVAL))
" files")) " files"))
[CDBROWSER CDVAL TITLE `(,WPROJ ,BRANCH2) [CDBROWSER CDVAL TITLE `(,WPROJ ,BRANCH2)
`(BRANCH1 ,WPROJ BRANCH2 ,BRANCH2 SUBDIR ,SUBDIR LABELFN `(BRANCH1 ,WPROJ BRANCH2 ,BRANCH2 SUBDIR ,SUBDIR LABELFN
GIT-CD-LABELFN PROJECT ,PROJECT) GIT-CD-LABELFN PROJECT ,PROJECT)
GIT-CDBROWSER-SEPARATE-DIRECTIONS GIT-CDBROWSER-SEPARATE-DIRECTIONS
`(Compare See "" Copy% <- (|Delete ALL <-| GIT-CD-MENUFN) `(Compare See "" Copy% <- (|Delete ALL <-| GIT-CD-MENUFN)
,@(CL:UNLESS (GIT-MAINBRANCH? BRANCH2 PROJECT T) ,@(CL:UNLESS (GIT-MAINBRANCH? BRANCH2 PROJECT T)
'("" Copy% -> (Delete% -> GIT-CD-MENUFN)))] '("" Copy% -> (Delete% -> GIT-CD-MENUFN)))]
(CONS (CONCAT SUBDIR "/") (CONS (CONCAT SUBDIR "/")
(for CDENTRY in (fetch CDENTRIES of CDVAL) (for CDENTRY in (fetch CDENTRIES of CDVAL)
collect (fetch MATCHNAME of CDENTRY))) collect (fetch MATCHNAME of CDENTRY)))
(add NENTRIES (LENGTH (fetch (CDVALUE CDENTRIES) of CDVAL] (add NENTRIES (LENGTH (fetch (CDVALUE CDENTRIES) of CDVAL]
(SETQ LAST-WMEDLEY-CDVALUES $$VAL) (SETQ LAST-WMEDLEY-CDVALUES $$VAL)
(TERPRI T) (TERPRI T)
(RETURN (LIST NENTRIES (CL:IF (EQ NENTRIES 1) (RETURN (LIST NENTRIES (CL:IF (EQ NENTRIES 1)
'difference 'difference
'differences)]) 'differences)])
@ -2270,16 +2273,16 @@
RB NIL PROJECT]) RB NIL PROJECT])
) )
(RPAQ? FROMGITN 0) (RPAQ? FROMGITN 0)
(* ;; "") (* ;; "")
(* ;; "Utilities") (* ;; "Utilities")
(DEFINEQ (DEFINEQ
@ -2427,35 +2430,35 @@
STRING]) STRING])
) )
(PUTPROPS GITFNS FILETYPE :TCOMPL) (PUTPROPS GITFNS FILETYPE :TCOMPL)
(DECLARE%: DONTCOPY (DECLARE%: DONTCOPY
(FILEMAP (NIL (4202 20781 (GIT-CLONEP 4212 . 5540) (GIT-INIT 5542 . 6172) (GIT-MAKE-PROJECT 6174 . (FILEMAP (NIL (4225 20804 (GIT-CLONEP 4235 . 5563) (GIT-INIT 5565 . 6195) (GIT-MAKE-PROJECT 6197 .
13839) (GIT-GET-PROJECT 13841 . 15766) (GIT-PUT-PROJECT-FIELD 15768 . 17409) (GIT-PROJECT-PATH 17411 13862) (GIT-GET-PROJECT 13864 . 15789) (GIT-PUT-PROJECT-FIELD 15791 . 17432) (GIT-PROJECT-PATH 17434
. 18455) (FIND-ANCESTOR-DIRECTORY 18457 . 18806) (GIT-FIND-CLONE 18808 . 19889) (GIT-MAINBRANCH 19891 . 18478) (FIND-ANCESTOR-DIRECTORY 18480 . 18829) (GIT-FIND-CLONE 18831 . 19912) (GIT-MAINBRANCH 19914
. 20286) (GIT-MAINBRANCH? 20288 . 20779)) (26244 31173 (PRC-COMMAND 26254 . 31171)) (31229 34017 ( . 20309) (GIT-MAINBRANCH? 20311 . 20802)) (26471 31400 (PRC-COMMAND 26481 . 31398)) (31448 34236 (
ALLSUBDIRS 31239 . 32525) (MEDLEYSUBDIRS 32527 . 33220) (GITSUBDIRS 33222 . 34015)) (34018 38808 ( ALLSUBDIRS 31458 . 32744) (MEDLEYSUBDIRS 32746 . 33439) (GITSUBDIRS 33441 . 34234)) (34237 39027 (
TOGIT 34028 . 35434) (FROMGIT 35436 . 36417) (GIT-DELETE-FILE 36419 . 37265) (MYMEDLEY-DELETE-FILES TOGIT 34247 . 35653) (FROMGIT 35655 . 36636) (GIT-DELETE-FILE 36638 . 37484) (MYMEDLEY-DELETE-FILES
37267 . 38806)) (38809 41812 (MYMEDLEYSUBDIR 38819 . 39275) (GITSUBDIR 39277 . 39720) (STRIPDIR 39722 37486 . 39025)) (39028 42031 (MYMEDLEYSUBDIR 39038 . 39494) (GITSUBDIR 39496 . 39939) (STRIPDIR 39941
. 40093) (STRIPHOST 40095 . 40335) (STRIPNAME 40337 . 41090) (STRIPWHERE 41092 . 41810)) (41813 43715 . 40312) (STRIPHOST 40314 . 40554) (STRIPNAME 40556 . 41309) (STRIPWHERE 41311 . 42029)) (42032 43934
(GFILE4MFILE 41823 . 42186) (MFILE4GFILE 42188 . 42757) (GIT-REPO-FILENAME 42759 . 43713)) (43764 (GFILE4MFILE 42042 . 42405) (MFILE4GFILE 42407 . 42976) (GIT-REPO-FILENAME 42978 . 43932)) (43975
54019 (GIT-COMMIT 43774 . 44600) (GIT-PUSH 44602 . 45362) (GIT-PULL 45364 . 46116) (GIT-APPROVAL 46118 54230 (GIT-COMMIT 43985 . 44811) (GIT-PUSH 44813 . 45573) (GIT-PULL 45575 . 46327) (GIT-APPROVAL 46329
. 46467) (GIT-GET-FILE 46469 . 48384) (GIT-FILE-EXISTS? 48386 . 48660) (GIT-REMOTE-UPDATE 48662 . . 46678) (GIT-GET-FILE 46680 . 48595) (GIT-FILE-EXISTS? 48597 . 48871) (GIT-REMOTE-UPDATE 48873 .
49497) (GIT-REMOTE-ADD 49499 . 49806) (GIT-FILE-DATE 49808 . 50855) (GIT-FILE-HISTORY 50857 . 52791) ( 49708) (GIT-REMOTE-ADD 49710 . 50017) (GIT-FILE-DATE 50019 . 51066) (GIT-FILE-HISTORY 51068 . 53002) (
GIT-PRINT-FILE-HISTORY 52793 . 53843) (GIT-FETCH 53845 . 54017)) (54049 65169 (GIT-BRANCH-DIFF 54059 GIT-PRINT-FILE-HISTORY 53004 . 54054) (GIT-FETCH 54056 . 54228)) (54256 65376 (GIT-BRANCH-DIFF 54266
. 60806) (GIT-COMMIT-DIFFS 60808 . 61481) (GIT-BRANCH-RELATIONS 61483 . 65167)) (65214 84600 ( . 61013) (GIT-COMMIT-DIFFS 61015 . 61688) (GIT-BRANCH-RELATIONS 61690 . 65374)) (65413 84799 (
GIT-BRANCH-NUM 65224 . 65797) (GIT-CHECKOUT 65799 . 67085) (GIT-WHICH-BRANCH 67087 . 67494) ( GIT-BRANCH-NUM 65423 . 65996) (GIT-CHECKOUT 65998 . 67284) (GIT-WHICH-BRANCH 67286 . 67693) (
GIT-MAKE-BRANCH 67496 . 70075) (GIT-BRANCHES 70077 . 72672) (GIT-BRANCH-EXISTS? 72674 . 73545) ( GIT-MAKE-BRANCH 67695 . 70274) (GIT-BRANCHES 70276 . 72871) (GIT-BRANCH-EXISTS? 72873 . 73744) (
GIT-PICK-BRANCH 73547 . 74037) (GIT-BRANCH-MENU 74039 . 74920) (GIT-BRANCH-WHENSELECTEDFN 74922 . GIT-PICK-BRANCH 73746 . 74236) (GIT-BRANCH-MENU 74238 . 75119) (GIT-BRANCH-WHENSELECTEDFN 75121 .
77461) (GIT-PULL-REQUESTS 77463 . 80981) (GIT-SHORT-BRANCH-NAME 80983 . 81274) (GIT-LONG-NAME 81276 . 77660) (GIT-PULL-REQUESTS 77662 . 81180) (GIT-SHORT-BRANCH-NAME 81182 . 81473) (GIT-LONG-NAME 81475 .
81593) (GIT-PRC-BRANCHES 81595 . 84598)) (84630 88078 (GIT-MY-CURRENT-BRANCH 84640 . 85010) ( 81792) (GIT-PRC-BRANCHES 81794 . 84797)) (84825 88273 (GIT-MY-CURRENT-BRANCH 84835 . 85205) (
GIT-MY-BRANCHP 85012 . 85630) (GIT-MY-NEXT-BRANCH 85632 . 86126) (GIT-MY-BRANCHES 86128 . 88076)) ( GIT-MY-BRANCHP 85207 . 85825) (GIT-MY-NEXT-BRANCH 85827 . 86321) (GIT-MY-BRANCHES 86323 . 88271)) (
88124 92199 (GIT-ADD-WORKTREE 88134 . 89741) (GIT-REMOVE-WORKTREE 89743 . 90673) (GIT-LIST-WORKTREES 88311 92386 (GIT-ADD-WORKTREE 88321 . 89928) (GIT-REMOVE-WORKTREE 89930 . 90860) (GIT-LIST-WORKTREES
90675 . 91479) (WORKTREEDIR 91481 . 92197)) (92247 125381 (GIT-GET-DIFFERENT-FILES 92257 . 98681) ( 90862 . 91666) (WORKTREEDIR 91668 . 92384)) (92426 125819 (GIT-GET-DIFFERENT-FILES 92436 . 98860) (
GIT-BRANCHES-COMPARE-DIRECTORIES 98683 . 105914) (GIT-WORKING-COMPARE-DIRECTORIES 105916 . 111364) ( GIT-BRANCHES-COMPARE-DIRECTORIES 98862 . 106093) (GIT-WORKING-COMPARE-DIRECTORIES 106095 . 111802) (
GIT-COMPARE-WORKTREE 111366 . 115344) (GITCDOBJBUTTONFN 115346 . 119836) (GIT-CD-LABELFN 119838 . GIT-COMPARE-WORKTREE 111804 . 115782) (GITCDOBJBUTTONFN 115784 . 120274) (GIT-CD-LABELFN 120276 .
120920) (GIT-CD-MENUFN 120922 . 123362) (GIT-WORKING-COMPARE-FILES 123364 . 123984) ( 121358) (GIT-CD-MENUFN 121360 . 123800) (GIT-WORKING-COMPARE-FILES 123802 . 124422) (
GIT-BRANCHES-COMPARE-FILES 123986 . 125150) (GIT-PR-COMPARE 125152 . 125379)) (125451 133774 (CDGITDIR GIT-BRANCHES-COMPARE-FILES 124424 . 125588) (GIT-PR-COMPARE 125590 . 125817)) (125881 134204 (CDGITDIR
125461 . 126148) (GIT-COMMAND 126150 . 127708) (GITORIGIN 127710 . 128407) (GIT-INITIALS 128409 . 125891 . 126578) (GIT-COMMAND 126580 . 128138) (GITORIGIN 128140 . 128837) (GIT-INITIALS 128839 .
128713) (GIT-COMMAND-TO-FILE 128715 . 132200) (GIT-RESULT-TO-LINES 132202 . 133107) (STRIPLOCAL 133109 129143) (GIT-COMMAND-TO-FILE 129145 . 132630) (GIT-RESULT-TO-LINES 132632 . 133537) (STRIPLOCAL 133539
. 133772))))) . 134202)))))
STOP STOP

BIN
lispusers/GITFNS.LCOM
View File

Binary file not shown.