github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-01-13 07:29:52 +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)
(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
: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)
(RPAQQ GITFNSCOMS
(RPAQQ GITFNSCOMS
(
(* ;; "Set up")
(* ;; "Set up")
(FILES (SYSLOAD FROM LISPUSERS)
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
GIT-PROJECT-PATH FIND-ANCESTOR-DIRECTORY GIT-FIND-CLONE GIT-MAINBRANCH
@ -43,94 +44,94 @@
(P (GIT-INIT))
(ADDVARS (AROUNDEXITFNS GIT-INIT))
(* ;; "")
(* ;; "")
(* ;; "Lisp exec commands")
(* ;; "Lisp exec commands")
(INITVARS (GIT-MERGE-COMPARES T)
(GIT-CDBROWSER-SEPARATE-DIRECTIONS T))
(COMMANDS gwc bbc prc cob b? cdg cdw)
(FNS PRC-COMMAND)
(* ;; "")
(* ;; "")
(* ;; "File correspondents")
(* ;; "File correspondents")
(FNS ALLSUBDIRS MEDLEYSUBDIRS GITSUBDIRS)
(FNS TOGIT FROMGIT GIT-DELETE-FILE MYMEDLEY-DELETE-FILES)
(FNS MYMEDLEYSUBDIR GITSUBDIR STRIPDIR STRIPHOST STRIPNAME STRIPWHERE)
(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?
GIT-REMOTE-UPDATE GIT-REMOTE-ADD GIT-FILE-DATE GIT-FILE-HISTORY GIT-PRINT-FILE-HISTORY
GIT-FETCH)
(* ;; "Differences")
(* ;; "Differences")
(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
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)
(* ;; "My branches")
(* ;; "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)
(* ;; "")
(* ;; "")
(* ;; "Comparisons")
(* ;; "Comparisons")
(FNS GIT-GET-DIFFERENT-FILES GIT-BRANCHES-COMPARE-DIRECTORIES GIT-WORKING-COMPARE-DIRECTORIES
GIT-COMPARE-WORKTREE GITCDOBJBUTTONFN GIT-CD-LABELFN GIT-CD-MENUFN
GIT-WORKING-COMPARE-FILES GIT-BRANCHES-COMPARE-FILES GIT-PR-COMPARE)
(INITVARS (FROMGITN 0))
(* ;; "")
(* ;; "")
(* ;; "Utilities")
(* ;; "Utilities")
(FNS CDGITDIR GIT-COMMAND GITORIGIN GIT-INITIALS GIT-COMMAND-TO-FILE GIT-RESULT-TO-LINES
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)
(* ;; "")
(* ;; "")
(* ;; "GIT projects")
(* ;; "GIT projects")
(DEFINEQ
@ -401,15 +402,15 @@
(DECLARE%: EVAL@COMPILE DONTCOPY
(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/)
(greetfiles scripts sources library lispusers internal doctools rooms))
(NOTECARDS)
@ -417,120 +418,120 @@
(TEST)
(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)
(* ;; "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)
(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)
THEN (SETQ PROJECT (CAR STAIL))
(GO $$OUT))
(CAR STAIL)))
(GIT-WORKING-COMPARE-DIRECTORIES SUBDIRS NIL NIL NIL T PROJECT)))
THEN (SETQ PROJECT (CAR STAIL))
(GO $$OUT))
(CAR STAIL)))
(GIT-WORKING-COMPARE-DIRECTORIES SUBDIRS NIL NIL NIL T 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))
(GIT-FETCH PROJECT)
(SETQ BRANCH1 (SELECTQ (U-CASE BRANCH1)
(SETQ PROJECT (GIT-GET-PROJECT PROJECT))
(GIT-FETCH PROJECT)
(SETQ BRANCH1 (SELECTQ (U-CASE BRANCH1)
((NIL T)
(GIT-MY-CURRENT-BRANCH PROJECT))
(GIT-MY-CURRENT-BRANCH PROJECT))
((LOCAL REMOTE ORIGIN)
(GIT-PICK-BRANCH (GIT-BRANCHES BRANCH1 PROJECT T)))
(OR (GIT-LONG-NAME BRANCH1 NIL PROJECT)
(GIT-PICK-BRANCH (GIT-BRANCHES BRANCH1 PROJECT T)))
(OR (GIT-LONG-NAME BRANCH1 NIL PROJECT)
BRANCH1)))
(SETQ BRANCH2 (SELECTQ (U-CASE BRANCH2)
(SETQ BRANCH2 (SELECTQ (U-CASE BRANCH2)
((NIL T)
(GIT-MAINBRANCH PROJECT LOCAL))
(GIT-MAINBRANCH PROJECT LOCAL))
((LOCAL REMOTE ORIGIN)
(GIT-PICK-BRANCH (GIT-BRANCHES BRANCH2 PROJECT T)))
(OR (GIT-LONG-NAME BRANCH2 NIL PROJECT)
(GIT-PICK-BRANCH (GIT-BRANCHES BRANCH2 PROJECT T)))
(OR (GIT-LONG-NAME BRANCH2 NIL PROJECT)
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))
(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)
(* ;; "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)
(SETQ PROJECT NEXTTITLESTRING))
(CL:UNLESS (STRINGP NEXTTITLESTRING)
(SETQ PROJECT NEXTTITLESTRING))
(CL:UNLESS PROJECT
(CL:WHEN (GIT-GET-PROJECT BRANCH NIL T)
(SETQ PROJECT BRANCH)
(SETQ BRANCH NIL)))
(SETQ PROJECT (GIT-GET-PROJECT PROJECT))
(GIT-FETCH PROJECT)
(SELECTQ (U-CASE BRANCH)
(T (GIT-CHECKOUT (GIT-MY-CURRENT-BRANCH PROJECT)
(CL:WHEN (GIT-GET-PROJECT BRANCH NIL T)
(SETQ PROJECT BRANCH)
(SETQ BRANCH NIL)))
(SETQ PROJECT (GIT-GET-PROJECT PROJECT))
(GIT-FETCH PROJECT)
(SELECTQ (U-CASE BRANCH)
(T (GIT-CHECKOUT (GIT-MY-CURRENT-BRANCH PROJECT)
PROJECT))
((NEW NEXT)
(GIT-MAKE-BRANCH NIL NEXTTITLESTRING PROJECT))
(CL:WHEN [SETQ BRANCH (IF BRANCH
THEN (GIT-LONG-NAME BRANCH NIL PROJECT)
ELSE (GIT-PICK-BRANCH (GIT-BRANCHES 'LOCAL PROJECT T)
(CONCAT (L-CASE (GIT-GET-PROJECT PROJECT 'PROJECTNAME)
(GIT-MAKE-BRANCH NIL NEXTTITLESTRING PROJECT))
(CL:WHEN [SETQ BRANCH (IF BRANCH
THEN (GIT-LONG-NAME BRANCH NIL PROJECT)
ELSE (GIT-PICK-BRANCH (GIT-BRANCHES 'LOCAL PROJECT T)
(CONCAT (L-CASE (GIT-GET-PROJECT PROJECT 'PROJECTNAME)
T)
" branches"]
(GIT-CHECKOUT BRANCH PROJECT))))
(GIT-CHECKOUT BRANCH PROJECT))))
(DEFCOMMAND b? (PROJECT) (SETQ PROJECT (GIT-GET-PROJECT PROJECT))
(GIT-FETCH PROJECT)
(CONCAT (L-CASE (GIT-GET-PROJECT PROJECT 'PROJECTNAME)
(DEFCOMMAND b? (PROJECT) (SETQ PROJECT (GIT-GET-PROJECT PROJECT))
(GIT-FETCH PROJECT)
(CONCAT (L-CASE (GIT-GET-PROJECT PROJECT 'PROJECTNAME)
T)
" "
(GIT-WHICH-BRANCH PROJECT)))
(GIT-WHICH-BRANCH PROJECT)))
(DEFCOMMAND cdg (PROJECT SUBDIR) (CL:UNLESS (GIT-GET-PROJECT PROJECT NIL T)
(SETQ SUBDIR PROJECT)
(SETQ PROJECT GIT-DEFAULT-PROJECT))
(CL:WHEN [AND SUBDIR (NOT (MEMB (CHCON1 SUBDIR))
(CHARCODE (> /]
(SETQ SUBDIR (CONCAT SUBDIR "/")))
(SLASHIT (/CNDIR (CONCAT (GIT-GET-PROJECT PROJECT 'GITHOST)
(OR SUBDIR "")))
(DEFCOMMAND cdg (PROJECT SUBDIR) (CL:UNLESS (GIT-GET-PROJECT PROJECT NIL T)
(SETQ SUBDIR PROJECT)
(SETQ PROJECT GIT-DEFAULT-PROJECT))
(CL:WHEN [AND SUBDIR (NOT (MEMB (CHCON1 SUBDIR))
(CHARCODE (> /]
(SETQ SUBDIR (CONCAT SUBDIR "/")))
(SLASHIT (/CNDIR (CONCAT (GIT-GET-PROJECT PROJECT 'GITHOST)
(OR SUBDIR "")))
T))
(DEFCOMMAND cdw (PROJECT SUBDIR) (CL:UNLESS (GIT-GET-PROJECT PROJECT NIL T)
(SETQ SUBDIR PROJECT)
(SETQ PROJECT GIT-DEFAULT-PROJECT))
(CL:WHEN [AND SUBDIR (NOT (MEMB (CHCON1 SUBDIR))
(CHARCODE (> /]
(SETQ SUBDIR (CONCAT SUBDIR "/")))
(SLASHIT (/CNDIR (CONCAT (GIT-GET-PROJECT PROJECT 'WHOST)
(OR SUBDIR "")))
(DEFCOMMAND cdw (PROJECT SUBDIR) (CL:UNLESS (GIT-GET-PROJECT PROJECT NIL T)
(SETQ SUBDIR PROJECT)
(SETQ PROJECT GIT-DEFAULT-PROJECT))
(CL:WHEN [AND SUBDIR (NOT (MEMB (CHCON1 SUBDIR))
(CHARCODE (> /]
(SETQ SUBDIR (CONCAT SUBDIR "/")))
(SLASHIT (/CNDIR (CONCAT (GIT-GET-PROJECT PROJECT 'WHOST)
(OR SUBDIR "")))
T))
(DEFINEQ
@ -616,12 +617,12 @@
(* ;; "")
(* ;; "")
(* ;; "File correspondents")
(* ;; "File correspondents")
(DEFINEQ
@ -864,12 +865,12 @@
(* ;; "")
(* ;; "")
(* ;; "Git commands")
(* ;; "Git commands")
(DEFINEQ
@ -1073,7 +1074,7 @@
(* ;; "Differences")
(* ;; "Differences")
(DEFINEQ
@ -1261,12 +1262,12 @@
(* ;; "")
(* ;; "")
(* ;; "Branches")
(* ;; "Branches")
(DEFINEQ
@ -1574,7 +1575,7 @@
(* ;; "My branches")
(* ;; "My branches")
(DEFINEQ
@ -1641,12 +1642,12 @@
(* ;; "")
(* ;; "")
(* ;; "Worktrees")
(* ;; "Worktrees")
(DEFINEQ
@ -1717,12 +1718,12 @@
(* ;; "")
(* ;; "")
(* ;; "Comparisons")
(* ;; "Comparisons")
(DEFINEQ
@ -1934,98 +1935,100 @@
else '(0 differences))
else '(0 differences])
(GIT-WORKING-COMPARE-DIRECTORIES
(GIT-WORKING-COMPARE-DIRECTORIES
[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))
(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)
(fetch WHOST of PROJECT))
(ERROR (fetch PROJECTNAME of 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:UNLESS (AND (fetch GITHOST of PROJECT)
(fetch WHOST of PROJECT))
(ERROR (fetch PROJECTNAME of PROJECT)
" does not have both git and working directories"))
(CL:WHEN (AND (LISTP SUBDIRS)
(NULL (CDR SUBDIRS)))
(SETQ SUBDIRS (CAR SUBDIRS)))
(CL:WHEN (AND (LISTP SUBDIRS)
(NULL (CDR SUBDIRS)))
(SETQ SUBDIRS (CAR SUBDIRS)))
(CL:UNLESS SUBDIRS
(SETQ SUBDIRS (OR (fetch DEFAULTSUBDIRS of PROJECT)
(SETQ SUBDIRS (OR (fetch DEFAULTSUBDIRS of PROJECT)
'ALL)))
(SETQ SUBDIRS (L-CASE SUBDIRS))
(LET ((SUBDIRSTRING (if (EQ SUBDIRS 'all)
then (SETQ SUBDIRS (ALLSUBDIRS PROJECT))
(SETQ SUBDIRS (L-CASE SUBDIRS))
(LET ((SUBDIRSTRING (if (EQ SUBDIRS 'all)
then (SETQ SUBDIRS (ALLSUBDIRS PROJECT))
"ALL subdirectories"
else SUBDIRS)))
(for SUBDIR TITLE CDVAL (WPROJ _ (CONCAT "Working " (L-CASE (fetch PROJECTNAME of PROJECT)
else SUBDIRS)))
(for SUBDIR TITLE CDVAL (WPROJ _ (CONCAT "Working " (L-CASE (fetch PROJECTNAME of PROJECT)
T)))
(NENTRIES _ 0)
(BRANCH2 _ (GIT-WHICH-BRANCH PROJECT T))
first (PRINTOUT T "Comparing " SUBDIRSTRING 6 " of " WPROJ " and Git " BRANCH2 T)
(BKSYSBUF " ") inside SUBDIRS
collect (TERPRI T)
(SETQ CDVAL (COMPAREDIRECTORIES (MYMEDLEYSUBDIR SUBDIR T PROJECT)
(GITSUBDIR SUBDIR T PROJECT)
(OR SELECT '(> < ~= -* *-))
NIL
(for E DPOS in (GIT-GET-PROJECT PROJECT 'EXCLUSIONS)
collect (SETQ DPOS (STRPOS SUBDIR (FILENAMEFIELD E
(BRANCH2 _ (GIT-WHICH-BRANCH PROJECT T))
first (PRINTOUT T "Comparing " SUBDIRSTRING 6 " of " WPROJ " and Git " BRANCH2 T)
(BKSYSBUF " ") inside SUBDIRS
collect (TERPRI T)
(SETQ CDVAL (COMPAREDIRECTORIES (MYMEDLEYSUBDIR SUBDIR T PROJECT)
(GITSUBDIR SUBDIR T PROJECT)
(OR SELECT '(> < ~= -* *-))
'(*.* *>*.* .* *>.*)
(for E DPOS in (GIT-GET-PROJECT PROJECT 'EXCLUSIONS)
collect (SETQ DPOS (STRPOS SUBDIR (FILENAMEFIELD E
'DIRECTORY)
1 NIL T T FILEDIRCASEARRAY))
(CL:IF DPOS
(SUBSTRING E (ADD1 DPOS))
(SUBSTRING E (ADD1 DPOS))
E))
NIL NIL NIL FIXDIRECTORYDATES))
[for CDE in (fetch CDENTRIES of CDVAL)
do (CL:WHEN (fetch INFO1 of CDE)
(change (fetch (CDINFO FULLNAME) of (fetch INFO1 of CDE))
(UNSLASHIT DATUM T)))
(CL:WHEN (fetch INFO2 of CDE)
(change (fetch (CDINFO FULLNAME) of (fetch INFO2 of CDE))
(SLASHIT DATUM T)))]
[for CDE in (fetch CDENTRIES of CDVAL)
do (CL:WHEN (fetch INFO1 of CDE)
(change (fetch (CDINFO FULLNAME) of (fetch INFO1 of CDE))
(UNSLASHIT DATUM T)))
(CL:WHEN (fetch INFO2 of CDE)
(change (fetch (CDINFO FULLNAME) of (fetch INFO2 of CDE))
(SLASHIT DATUM T)))]
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)
(SETQ $$VAL (CDMERGE $$VAL))
[SETQ SUBDIRS (CONCATLIST (for SUBDIR in SUBDIRS collect (CONCAT SUBDIR " "])
[for CDVAL TITLE in $$VAL as SUBDIR inside SUBDIRS
do (SETQ TITLE (CONCAT WPROJ " vs. " BRANCH2 " " SUBDIR " "
(LENGTH (fetch (CDVALUE CDENTRIES) of CDVAL))
(SETQ $$VAL (CDMERGE $$VAL))
[SETQ SUBDIRS (CONCATLIST (for SUBDIR in SUBDIRS collect (CONCAT SUBDIR " "])
[for CDVAL TITLE in $$VAL as SUBDIR inside SUBDIRS
do (SETQ TITLE (CONCAT WPROJ " vs. " BRANCH2 " " SUBDIR " "
(LENGTH (fetch (CDVALUE CDENTRIES) of CDVAL))
" files"))
[CDBROWSER CDVAL TITLE `(,WPROJ ,BRANCH2)
[CDBROWSER CDVAL TITLE `(,WPROJ ,BRANCH2)
`(BRANCH1 ,WPROJ BRANCH2 ,BRANCH2 SUBDIR ,SUBDIR LABELFN
GIT-CD-LABELFN PROJECT ,PROJECT)
GIT-CDBROWSER-SEPARATE-DIRECTIONS
`(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)))]
(CONS (CONCAT SUBDIR "/")
(for CDENTRY in (fetch CDENTRIES of CDVAL)
collect (fetch MATCHNAME of CDENTRY)))
(add NENTRIES (LENGTH (fetch (CDVALUE CDENTRIES) of CDVAL]
(SETQ LAST-WMEDLEY-CDVALUES $$VAL)
(TERPRI T)
(RETURN (LIST NENTRIES (CL:IF (EQ NENTRIES 1)
(CONS (CONCAT SUBDIR "/")
(for CDENTRY in (fetch CDENTRIES of CDVAL)
collect (fetch MATCHNAME of CDENTRY)))
(add NENTRIES (LENGTH (fetch (CDVALUE CDENTRIES) of CDVAL]
(SETQ LAST-WMEDLEY-CDVALUES $$VAL)
(TERPRI T)
(RETURN (LIST NENTRIES (CL:IF (EQ NENTRIES 1)
'difference
'differences)])
@ -2270,16 +2273,16 @@
RB NIL PROJECT])
)
(RPAQ? FROMGITN 0)
(RPAQ? FROMGITN 0)
(* ;; "")
(* ;; "")
(* ;; "Utilities")
(* ;; "Utilities")
(DEFINEQ
@ -2427,35 +2430,35 @@
STRING])
)
(PUTPROPS GITFNS FILETYPE :TCOMPL)
(PUTPROPS GITFNS FILETYPE :TCOMPL)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (4202 20781 (GIT-CLONEP 4212 . 5540) (GIT-INIT 5542 . 6172) (GIT-MAKE-PROJECT 6174 .
13839) (GIT-GET-PROJECT 13841 . 15766) (GIT-PUT-PROJECT-FIELD 15768 . 17409) (GIT-PROJECT-PATH 17411
. 18455) (FIND-ANCESTOR-DIRECTORY 18457 . 18806) (GIT-FIND-CLONE 18808 . 19889) (GIT-MAINBRANCH 19891
. 20286) (GIT-MAINBRANCH? 20288 . 20779)) (26244 31173 (PRC-COMMAND 26254 . 31171)) (31229 34017 (
ALLSUBDIRS 31239 . 32525) (MEDLEYSUBDIRS 32527 . 33220) (GITSUBDIRS 33222 . 34015)) (34018 38808 (
TOGIT 34028 . 35434) (FROMGIT 35436 . 36417) (GIT-DELETE-FILE 36419 . 37265) (MYMEDLEY-DELETE-FILES
37267 . 38806)) (38809 41812 (MYMEDLEYSUBDIR 38819 . 39275) (GITSUBDIR 39277 . 39720) (STRIPDIR 39722
. 40093) (STRIPHOST 40095 . 40335) (STRIPNAME 40337 . 41090) (STRIPWHERE 41092 . 41810)) (41813 43715
(GFILE4MFILE 41823 . 42186) (MFILE4GFILE 42188 . 42757) (GIT-REPO-FILENAME 42759 . 43713)) (43764
54019 (GIT-COMMIT 43774 . 44600) (GIT-PUSH 44602 . 45362) (GIT-PULL 45364 . 46116) (GIT-APPROVAL 46118
. 46467) (GIT-GET-FILE 46469 . 48384) (GIT-FILE-EXISTS? 48386 . 48660) (GIT-REMOTE-UPDATE 48662 .
49497) (GIT-REMOTE-ADD 49499 . 49806) (GIT-FILE-DATE 49808 . 50855) (GIT-FILE-HISTORY 50857 . 52791) (
GIT-PRINT-FILE-HISTORY 52793 . 53843) (GIT-FETCH 53845 . 54017)) (54049 65169 (GIT-BRANCH-DIFF 54059
. 60806) (GIT-COMMIT-DIFFS 60808 . 61481) (GIT-BRANCH-RELATIONS 61483 . 65167)) (65214 84600 (
GIT-BRANCH-NUM 65224 . 65797) (GIT-CHECKOUT 65799 . 67085) (GIT-WHICH-BRANCH 67087 . 67494) (
GIT-MAKE-BRANCH 67496 . 70075) (GIT-BRANCHES 70077 . 72672) (GIT-BRANCH-EXISTS? 72674 . 73545) (
GIT-PICK-BRANCH 73547 . 74037) (GIT-BRANCH-MENU 74039 . 74920) (GIT-BRANCH-WHENSELECTEDFN 74922 .
77461) (GIT-PULL-REQUESTS 77463 . 80981) (GIT-SHORT-BRANCH-NAME 80983 . 81274) (GIT-LONG-NAME 81276 .
81593) (GIT-PRC-BRANCHES 81595 . 84598)) (84630 88078 (GIT-MY-CURRENT-BRANCH 84640 . 85010) (
GIT-MY-BRANCHP 85012 . 85630) (GIT-MY-NEXT-BRANCH 85632 . 86126) (GIT-MY-BRANCHES 86128 . 88076)) (
88124 92199 (GIT-ADD-WORKTREE 88134 . 89741) (GIT-REMOVE-WORKTREE 89743 . 90673) (GIT-LIST-WORKTREES
90675 . 91479) (WORKTREEDIR 91481 . 92197)) (92247 125381 (GIT-GET-DIFFERENT-FILES 92257 . 98681) (
GIT-BRANCHES-COMPARE-DIRECTORIES 98683 . 105914) (GIT-WORKING-COMPARE-DIRECTORIES 105916 . 111364) (
GIT-COMPARE-WORKTREE 111366 . 115344) (GITCDOBJBUTTONFN 115346 . 119836) (GIT-CD-LABELFN 119838 .
120920) (GIT-CD-MENUFN 120922 . 123362) (GIT-WORKING-COMPARE-FILES 123364 . 123984) (
GIT-BRANCHES-COMPARE-FILES 123986 . 125150) (GIT-PR-COMPARE 125152 . 125379)) (125451 133774 (CDGITDIR
125461 . 126148) (GIT-COMMAND 126150 . 127708) (GITORIGIN 127710 . 128407) (GIT-INITIALS 128409 .
128713) (GIT-COMMAND-TO-FILE 128715 . 132200) (GIT-RESULT-TO-LINES 132202 . 133107) (STRIPLOCAL 133109
. 133772)))))
(FILEMAP (NIL (4225 20804 (GIT-CLONEP 4235 . 5563) (GIT-INIT 5565 . 6195) (GIT-MAKE-PROJECT 6197 .
13862) (GIT-GET-PROJECT 13864 . 15789) (GIT-PUT-PROJECT-FIELD 15791 . 17432) (GIT-PROJECT-PATH 17434
. 18478) (FIND-ANCESTOR-DIRECTORY 18480 . 18829) (GIT-FIND-CLONE 18831 . 19912) (GIT-MAINBRANCH 19914
. 20309) (GIT-MAINBRANCH? 20311 . 20802)) (26471 31400 (PRC-COMMAND 26481 . 31398)) (31448 34236 (
ALLSUBDIRS 31458 . 32744) (MEDLEYSUBDIRS 32746 . 33439) (GITSUBDIRS 33441 . 34234)) (34237 39027 (
TOGIT 34247 . 35653) (FROMGIT 35655 . 36636) (GIT-DELETE-FILE 36638 . 37484) (MYMEDLEY-DELETE-FILES
37486 . 39025)) (39028 42031 (MYMEDLEYSUBDIR 39038 . 39494) (GITSUBDIR 39496 . 39939) (STRIPDIR 39941
. 40312) (STRIPHOST 40314 . 40554) (STRIPNAME 40556 . 41309) (STRIPWHERE 41311 . 42029)) (42032 43934
(GFILE4MFILE 42042 . 42405) (MFILE4GFILE 42407 . 42976) (GIT-REPO-FILENAME 42978 . 43932)) (43975
54230 (GIT-COMMIT 43985 . 44811) (GIT-PUSH 44813 . 45573) (GIT-PULL 45575 . 46327) (GIT-APPROVAL 46329
. 46678) (GIT-GET-FILE 46680 . 48595) (GIT-FILE-EXISTS? 48597 . 48871) (GIT-REMOTE-UPDATE 48873 .
49708) (GIT-REMOTE-ADD 49710 . 50017) (GIT-FILE-DATE 50019 . 51066) (GIT-FILE-HISTORY 51068 . 53002) (
GIT-PRINT-FILE-HISTORY 53004 . 54054) (GIT-FETCH 54056 . 54228)) (54256 65376 (GIT-BRANCH-DIFF 54266
. 61013) (GIT-COMMIT-DIFFS 61015 . 61688) (GIT-BRANCH-RELATIONS 61690 . 65374)) (65413 84799 (
GIT-BRANCH-NUM 65423 . 65996) (GIT-CHECKOUT 65998 . 67284) (GIT-WHICH-BRANCH 67286 . 67693) (
GIT-MAKE-BRANCH 67695 . 70274) (GIT-BRANCHES 70276 . 72871) (GIT-BRANCH-EXISTS? 72873 . 73744) (
GIT-PICK-BRANCH 73746 . 74236) (GIT-BRANCH-MENU 74238 . 75119) (GIT-BRANCH-WHENSELECTEDFN 75121 .
77660) (GIT-PULL-REQUESTS 77662 . 81180) (GIT-SHORT-BRANCH-NAME 81182 . 81473) (GIT-LONG-NAME 81475 .
81792) (GIT-PRC-BRANCHES 81794 . 84797)) (84825 88273 (GIT-MY-CURRENT-BRANCH 84835 . 85205) (
GIT-MY-BRANCHP 85207 . 85825) (GIT-MY-NEXT-BRANCH 85827 . 86321) (GIT-MY-BRANCHES 86323 . 88271)) (
88311 92386 (GIT-ADD-WORKTREE 88321 . 89928) (GIT-REMOVE-WORKTREE 89930 . 90860) (GIT-LIST-WORKTREES
90862 . 91666) (WORKTREEDIR 91668 . 92384)) (92426 125819 (GIT-GET-DIFFERENT-FILES 92436 . 98860) (
GIT-BRANCHES-COMPARE-DIRECTORIES 98862 . 106093) (GIT-WORKING-COMPARE-DIRECTORIES 106095 . 111802) (
GIT-COMPARE-WORKTREE 111804 . 115782) (GITCDOBJBUTTONFN 115784 . 120274) (GIT-CD-LABELFN 120276 .
121358) (GIT-CD-MENUFN 121360 . 123800) (GIT-WORKING-COMPARE-FILES 123802 . 124422) (
GIT-BRANCHES-COMPARE-FILES 124424 . 125588) (GIT-PR-COMPARE 125590 . 125817)) (125881 134204 (CDGITDIR
125891 . 126578) (GIT-COMMAND 126580 . 128138) (GITORIGIN 128140 . 128837) (GIT-INITIALS 128839 .
129143) (GIT-COMMAND-TO-FILE 129145 . 132630) (GIT-RESULT-TO-LINES 132632 . 133537) (STRIPLOCAL 133539
. 134202)))))
STOP

BIN
lispusers/GITFNS.LCOM
View File

Binary file not shown.