github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-02-05 08:15:04 +00:00
Code Issues Projects Releases Wiki Activity

The same issue happens with .git in a branch name.

Browse Source 
Hoisted on its own petard!
This commit is contained in:
Matt Heffron
2024-06-12 23:06:21 -07:00
parent e7dccf76a9
commit 8d648f46b1
2 changed files with 157 additions and 142 deletions
Download Patch File Download Diff File Expand all files Collapse all files

299
lispusers/GITFNS
View File

@@ -1,12 +1,16 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "10-Jun-2024 18:43:43" {DSK}<home>matt>Interlisp>medley>LISPUSERS>GITFNS.;4 132087
(FILECREATED "12-Jun-2024 23:02:26" {DSK}<home>matt>Interlisp>medley>lispusers>GITFNS.;6 133403
:EDIT-BY "mth"
:CHANGES-TO (FNS GIT-GET-PROJECT GIT-COMMAND-TO-FILE GIT-BRANCHES-COMPARE-DIRECTORIES)
:CHANGES-TO (FNS PRC-COMMAND GIT-BRANCH-RELATIONS GIT-BRANCHES GIT-BRANCH-MENU
GIT-PULL-REQUESTS GIT-PRC-BRANCHES CDGITDIR GIT-COMMAND GITORIGIN
GIT-RESULT-TO-LINES STRIPLOCAL GIT-WHICH-BRANCH GIT-GET-DIFFERENT-FILES
GIT-REMOTE-UPDATE GIT-CHECKOUT GIT-MAKE-BRANCH GIT-MY-BRANCHP
GIT-BRANCHES-COMPARE-DIRECTORIES GIT-WORKING-COMPARE-DIRECTORIES)
:PREVIOUS-DATE "10-Jun-2024 16:48:20" {DSK}<home>matt>Interlisp>medley>LISPUSERS>GITFNS.;3)
:PREVIOUS-DATE "10-Jun-2024 18:43:43" {DSK}<home>matt>Interlisp>medley>lispusers>GITFNS.;5)
(PRETTYCOMPRINT GITFNSCOMS)
@@ -543,13 +547,13 @@
(* ;; "DRAFTS can be DRAFT(S), NODRAFTS, or NIL. If DRAFTS, then only draft PR's are shown, of NODRAFTS then only nondrafts are shown. Anything else, both drafts and nondrafts are shown in the menu.")
(LET (PRS MENUWINDOW OLDMENUWINDOW)
(IF PROJECT
THEN (SETQ PROJECT (GIT-GET-PROJECT PROJECT))
ELSEIF (GIT-GET-PROJECT REMOTEBRANCH NIL T)
THEN (SETQ PROJECT REMOTEBRANCH)
(if PROJECT
then (SETQ PROJECT (GIT-GET-PROJECT PROJECT))
elseif (GIT-GET-PROJECT REMOTEBRANCH NIL T)
then (SETQ PROJECT REMOTEBRANCH)
(SETQ REMOTEBRANCH NIL)
ELSEIF (GIT-GET-PROJECT DRAFTS NIL T)
THEN (SETQ PROJECT DRAFTS)
elseif (GIT-GET-PROJECT DRAFTS NIL T)
then (SETQ PROJECT DRAFTS)
(SETQ DRAFTS NIL))
(CL:UNLESS PROJECT (SETQ PROJECT GIT-DEFAULT-PROJECT))
(SELECTQ (U-CASE REMOTEBRANCH)
@@ -584,8 +588,8 @@
(fetch PRLOGIN of PR)
")" T)
NIL) collect PR))
(IF PRS
THEN (if (CDR PRS)
(if PRS
then (if (CDR PRS)
then (SETQ MENUWINDOW (ADDMENU (GIT-BRANCH-MENU (GIT-PRC-BRANCHES DRAFTS
PROJECT PRS)
(CONCAT (LENGTH PRS)
@@ -602,12 +606,12 @@
(CL:WHEN [OPENWP (CDR (SETQ OLDMENUWINDOW (ASSOC PROJECT GIT-PRC-MENUS]
(CLOSEW (CDR OLDMENUWINDOW)))
(OPENW MENUWINDOW)
(RPLACD [OR OLDMENUWINDOW (CAR (PUSH GIT-PRC-MENUS (CONS PROJECT]
(RPLACD [OR OLDMENUWINDOW (CAR (push GIT-PRC-MENUS (CONS PROJECT]
MENUWINDOW)
MENUWINDOW
else (GIT-PR-COMPARE (fetch PRNAME of (CAR PRS))
PROJECT))
ELSE (CONCAT "No open " (OR REMOTEBRANCH "")
else (CONCAT "No open " (OR REMOTEBRANCH "")
" pull requests"])
)
@@ -970,7 +974,8 @@
(GIT-REMOTE-UPDATE
[LAMBDA (DOIT PROJECT)
(DECLARE (USEDFREE LAST-REMOTE-UPDATE-IDATE)) (* ; "Edited 7-May-2022 22:41 by rmk")
(DECLARE (USEDFREE LAST-REMOTE-UPDATE-IDATE)) (* ; "Edited 12-Jun-2024 12:57 by mth")
(* ; "Edited 7-May-2022 22:41 by rmk")
(* ;; "Because git hangs on this (and other things), do this no more than once a day")
@@ -978,7 +983,7 @@
(IGREATERP (IDIFFERENCE (IDATE)
LAST-REMOTE-UPDATE-IDATE)
(CONSTANT (TIMES 24 60 60 1000]
(PRINTOUT T "Updating from remote, local branch is " (GIT-WHICH-BRANCH PROJECT)
(PRINTOUT T "Updating from remote, local branch is " (GIT-WHICH-BRANCH PROJECT T)
T)
(PROG1 (GIT-COMMAND "git remote update origin" NIL PROJECT)
(SETQ LAST-REMOTE-UPDATE-IDATE (IDATE))))])
@@ -1206,20 +1211,20 @@
((MAIN (GIT-MAINBRANCH PROJECT)))
(CL:WHEN STRIPWHERE
(SETQ MAIN (STRIPWHERE MAIN)))
(FOR DTAIL D1 MORE1 MORE2 SUPERSETS EQUALS
ON (FOR B IN BRANCHES COLLECT (CL:WHEN STRIPWHERE
(for DTAIL D1 MORE1 MORE2 SUPERSETS EQUALS
on (for B in BRANCHES collect (CL:WHEN STRIPWHERE
(SETQ B (STRIPWHERE B)))
(CONS B (GIT-COMMIT-DIFFS B MAIN PROJECT)))
DO
do
(* ;; "For each branch we now have the list of commit identifiers (hexstrings) that they do not share with the main branch.")
(SETQ D1 (CAR DTAIL))
[FOR D2 IN (CDR DTAIL)
DO (CL:WHEN (EQUAL (CDR D1)
[for D2 in (CDR DTAIL)
do (CL:WHEN (EQUAL (CDR D1)
(CDR D2)) (* ; "Unlikely")
(PUSH [CDR (OR (ASSOC (CAR D1)
(push [CDR (OR (ASSOC (CAR D1)
EQUALS)
(CAR (PUSH EQUALS (CONS (CAR D1]
(CAR (push EQUALS (CONS (CAR D1]
(CAR D2))
(GO $$ITERATE))
(SETQ MORE2 (MEMBER (CADR D1)
@@ -1227,33 +1232,33 @@
 "The most recent commit of D1 is in D2")
(SETQ MORE1 (MEMBER (CADR D2)
(CDR D1)))
(IF MORE2
THEN (CL:UNLESS MORE1
(PUSH [CDR (OR (ASSOC (CAR D2)
(if MORE2
then (CL:UNLESS MORE1
(push [CDR (OR (ASSOC (CAR D2)
SUPERSETS)
(CAR (PUSH SUPERSETS (CONS (CAR D2]
(CAR (push SUPERSETS (CONS (CAR D2]
(CAR D1)))
ELSEIF MORE1
THEN (PUSH [CDR (OR (ASSOC (CAR D1)
elseif MORE1
then (push [CDR (OR (ASSOC (CAR D1)
SUPERSETS)
(CAR (PUSH SUPERSETS (CONS (CAR D1]
(CAR (push SUPERSETS (CONS (CAR D1]
(CAR D2]
FINALLY
finally
(* ;; "Sort the supersets so that the larger ones come before the smaller ones")
(CL:WHEN STRIPWHERE
[SETQ SUPERSETS (FOR S IN SUPERSETS COLLECT (FOR SS IN S COLLECT (STRIPWHERE SS]
[SETQ EQUALS (FOR S IN EQUALS COLLECT (FOR SS IN S COLLECT (STRIPWHERE SS])
[FOR S IN SUPERSETS
DO (CHANGE (CDR S)
[SETQ SUPERSETS (for S in SUPERSETS collect (for SS in S collect (STRIPWHERE SS]
[SETQ EQUALS (for S in EQUALS collect (for SS in S collect (STRIPWHERE SS])
[for S in SUPERSETS
do (change (CDR S)
(SORT DATUM (FUNCTION (LAMBDA (B1 B2)
(OR (MEMB B2 (CDR (ASSOC B1 SUPERSETS)))
(NOT (MEMB B1 (CDR (ASSOC B2 SUPERSETS]
[FOR E IN EQUALS DO (CHANGE (CDR E)
(IF (MEMB MAIN (CDR E))
THEN (CONS MAIN (DREMOVE MAIN (SORT DATUM)))
ELSE (SORT DATUM]
[for E in EQUALS do (change (CDR E)
(if (MEMB MAIN (CDR E))
then (CONS MAIN (DREMOVE MAIN (SORT DATUM)))
else (SORT DATUM]
(RETURN (LIST SUPERSETS EQUALS])
)
@@ -1282,14 +1287,15 @@
0])])
(GIT-CHECKOUT
[LAMBDA (BRANCH PROJECT) (* ; "Edited 2-May-2024 11:17 by mth")
[LAMBDA (BRANCH PROJECT) (* ; "Edited 12-Jun-2024 22:44 by mth")
(* ; "Edited 2-May-2024 11:17 by mth")
(* ; "Edited 7-Jul-2022 20:21 by rmk")
(* ; "Edited 9-May-2022 15:12 by rmk")
(* ; "Edited 7-May-2022 23:51 by rmk")
(* ; "Edited 2-Nov-2021 22:40 by rmk:")
(CL:UNLESS BRANCH
(SETQ BRANCH (GIT-MAINBRANCH PROJECT)))
(LET ((CURRENTBRANCH (GIT-WHICH-BRANCH PROJECT)))
(LET ((CURRENTBRANCH (GIT-WHICH-BRANCH PROJECT T)))
[SETQ CURRENTBRANCH (SUBSTRING CURRENTBRANCH (ADD1 (STRPOS "/" CURRENTBRANCH]
(CL:UNLESS [STRING.EQUAL CURRENTBRANCH (SUBSTRING BRANCH (ADD1 (OR (STRPOS "/" BRANCH)
0]
@@ -1300,14 +1306,16 @@
BRANCH])
(GIT-WHICH-BRANCH
[LAMBDA (PROJECT) (* ; "Edited 7-May-2022 22:41 by rmk")
[LAMBDA (PROJECT ALL) (* ; "Edited 12-Jun-2024 12:57 by mth")
(* ; "Edited 7-May-2022 22:41 by rmk")
(* ;; "Returns the current (local) branch in PROJECT")
(MKATOM (CONCAT "local/" (CAR (GIT-COMMAND "git rev-parse --abbrev-ref HEAD" NIL NIL PROJECT])
(MKATOM (CONCAT "local/" (CAR (GIT-COMMAND "git rev-parse --abbrev-ref HEAD" ALL NIL PROJECT])
(GIT-MAKE-BRANCH
[LAMBDA (NAME TITLESTRING PROJECT) (* ; "Edited 2-May-2024 11:24 by mth")
[LAMBDA (NAME TITLESTRING PROJECT) (* ; "Edited 12-Jun-2024 22:47 by mth")
(* ; "Edited 2-May-2024 11:24 by mth")
(* ; "Edited 18-Jul-2022 21:45 by rmk")
(* ; "Edited 19-May-2022 17:57 by rmk")
(* ; "Edited 9-May-2022 15:13 by rmk")
@@ -1325,12 +1333,14 @@
(* ;; "Git branch names can't contain spaces or colons")
(* ;; "mth: Notice that this is only dealing with spaces. There are other %"troublesome%" characters beyond colon, as well.")
[SETQ TITLESTRING (CONCATCODES (for I C from 1 while (SETQ C (NTHCHARCODE TITLESTRING I))
collect (if (EQ C (CHARCODE SPACE))
then (CHARCODE -)
else C]
(SETQ NAME (CONCAT NAME "--" TITLESTRING)))
(LET ((UNDER (GIT-WHICH-BRANCH PROJECT))
(LET ((UNDER (GIT-WHICH-BRANCH PROJECT T))
RESULT)
(if (EQ 'Y (ASKUSER NIL 'N (CONCAT "Branch " NAME " will be created under " UNDER
". Is that OK? ")))
@@ -1348,7 +1358,8 @@
NIL])
(GIT-BRANCHES
[LAMBDA (WHERE PROJECT EXCLUDEMERGED) (* ; "Edited 2-May-2024 11:26 by mth")
[LAMBDA (WHERE PROJECT EXCLUDEMERGED) (* ; "Edited 12-Jun-2024 12:46 by mth")
(* ; "Edited 2-May-2024 11:26 by mth")
(* ; "Edited 9-Aug-2022 10:45 by rmk")
(* ; "Edited 18-Jul-2022 08:11 by rmk")
(* ; "Edited 8-Jul-2022 10:33 by rmk")
@@ -1362,12 +1373,12 @@
(LET ([LOCAL (CL:WHEN (MEMB (U-CASE WHERE)
'(NIL ALL LOCAL))
[for B in (GIT-COMMAND "git branch" NIL NIL PROJECT)
[for B in (GIT-COMMAND "git branch" T NIL PROJECT)
collect (SUBATOM B 3 (SUB1 (OR (STRPOS " -> " B)
0])]
[REMOTE (CL:WHEN (MEMB (U-CASE WHERE)
'(NIL ALL REMOTE T))
[for B in (GIT-COMMAND "git branch -r" NIL NIL PROJECT)
[for B in (GIT-COMMAND "git branch -r" T NIL PROJECT)
collect (SUBATOM B 3 (SUB1 (OR (STRPOS " -> " B)
0])]
BRANCHES)
@@ -1413,7 +1424,7 @@
(CL:WHEN (SETQ BRANCHES (MKLIST BRANCHES))
(CL:WHEN PIN?
[SETQ BRANCHES (APPEND BRANCHES '((" Pin menu" 'PinMenu])
(CREATE MENU
(create MENU
TITLE _ (OR TITLE (CONCAT (LENGTH BRANCHES)
" branches"))
ITEMS _ BRANCHES
@@ -1468,13 +1479,13 @@
(ERROR "gh must be installed in order to enumerate pull requests:"))
(LET [(JPARSE (JSON-PARSE (CAR (GIT-COMMAND "gh pr list --json number,headRefName,title,isDraft,reviewDecision,url,headRepository,headRepositoryOwner"
T NIL PROJECT]
(FOR JSOBJ DRAFT PR IN (SELECTQ (CAR JPARSE)
(for JSOBJ DRAFT PR in (SELECTQ (CAR JPARSE)
(ARRAY (CDR JPARSE))
(OBJECT JPARSE)
(ERROR "UNRECOGNIZED PRC LIST FROM GIT" JPARSE))
EACHTIME [SETQ DRAFT (EQ 'true (JSON-GET JSOBJ 'isDraft] WHEN (OR INCLUDEDRAFTS
eachtime [SETQ DRAFT (EQ 'true (JSON-GET JSOBJ 'isDraft] when (OR INCLUDEDRAFTS
(NOT DRAFT))
COLLECT [SETQ PR (CREATE PULLREQUEST
collect [SETQ PR (create PULLREQUEST
PRNUMBER _ (JSON-GET JSOBJ 'number)
PRNAME _ (JSON-GET JSOBJ 'headRefName)
PRDESCRIPTION _ (JSON-GET JSOBJ 'title)
@@ -1534,28 +1545,28 @@
(CL:UNLESS PRS
(SETQ PRS (GIT-PULL-REQUESTS T PROJECT)))
(CL:WHEN PRS
(LET ((RELATIONS (GIT-BRANCH-RELATIONS (FOR PR IN PRS
COLLECT (GITORIGIN (fetch PRNAME of PR)))
(LET ((RELATIONS (GIT-BRANCH-RELATIONS (for PR in PRS
collect (GITORIGIN (fetch PRNAME of PR)))
NIL T PROJECT)))
(SORT (FOR PR REL LABEL PRNAME STATUS (SUPERSETS _ (CAR RELATIONS))
(EQUALS _ (CADR RELATIONS)) IN PRS
EACHTIME (SETQ PRNAME (fetch PRNAME of PR))
(SORT (for PR REL LABEL PRNAME STATUS (SUPERSETS _ (CAR RELATIONS))
(EQUALS _ (CADR RELATIONS)) in PRS
eachtime (SETQ PRNAME (fetch PRNAME of PR))
(SETQ LABEL (CONCAT "#" (fetch (PULLREQUEST PRNUMBER) of PR)
" "
(IF [SETQ REL (CAR (CDR (SASSOC PRNAME SUPERSETS]
THEN (CONCAT PRNAME " > " REL)
ELSEIF [SETQ REL (CAR (CDR (SASSOC PRNAME EQUALS]
THEN (CONCAT PRNAME " = " REL)
ELSE PRNAME)))
(SETQ STATUS (FETCH PRSTATUS OF PR))
WHEN (SELECTQ DRAFT
(if [SETQ REL (CAR (CDR (SASSOC PRNAME SUPERSETS]
then (CONCAT PRNAME " > " REL)
elseif [SETQ REL (CAR (CDR (SASSOC PRNAME EQUALS]
then (CONCAT PRNAME " = " REL)
else PRNAME)))
(SETQ STATUS (fetch PRSTATUS of PR))
when (SELECTQ DRAFT
(DRAFTS (EQ STATUS 'D))
(NODRAFTS (NEQ STATUS 'D))
T) COLLECT (LIST (CONCAT " " STATUS " " LABEL)
T) collect (LIST (CONCAT " " STATUS " " LABEL)
(GITORIGIN PRNAME)
(CONCAT " " STATUS " #" (FETCH PRNUMBER OF PR)
(CONCAT " " STATUS " #" (fetch PRNUMBER of PR)
" "
(FETCH PRDESCRIPTION OF PR))
(fetch PRDESCRIPTION of PR))
NIL PR))
T)))])
)
@@ -1574,14 +1585,15 @@
0])
(GIT-MY-BRANCHP
[LAMBDA (BRANCH PROJECT) (* ; "Edited 19-May-2022 17:44 by rmk")
[LAMBDA (BRANCH PROJECT) (* ; "Edited 12-Jun-2024 22:48 by mth")
(* ; "Edited 19-May-2022 17:44 by rmk")
(* ; "Edited 19-Jan-2022 13:22 by rmk")
(* ;; "Returns n if BRANCH is INITIALSn (local or origin), possibly followed by a trailing comment after hyphen.")
(CL:UNLESS BRANCH
(SETQ BRANCH (GIT-WHICH-BRANCH PROJECT)))
(GIT-BRANCH-NUM (OR BRANCH (GIT-WHICH-BRANCH PROJECT])
(SETQ BRANCH (GIT-WHICH-BRANCH PROJECT T)))
(GIT-BRANCH-NUM (OR BRANCH (GIT-WHICH-BRANCH PROJECT T])
(GIT-MY-NEXT-BRANCH
[LAMBDA (PROJECT) (* ; "Edited 19-May-2022 14:08 by rmk")
@@ -1731,9 +1743,9 @@
(LET
(MAPPINGS FROMGIT (DIFFS (GIT-BRANCH-DIFF BRANCH1 BRANCH2 PROJECT)))
(CL:WHEN DIFFS
(SETQ FROMGIT (PACK* '{FROMGIT (ADD FROMGITN 1)
(SETQ FROMGIT (PACK* '{FROMGIT (add FROMGITN 1)
'}))
(PSEUDOHOST FROMGIT (CONCAT "{CORE}<" (FETCH PROJECTNAME OF PROJECT)
(PSEUDOHOST FROMGIT (CONCAT "{CORE}<" (fetch PROJECTNAME of PROJECT)
">"
(DATE)
">"))
@@ -1746,8 +1758,8 @@
(CL:UNLESS DIR2
(SETQ DIR2 (CONCAT FROMGIT "<" (UNSLASHIT BRANCH2)
">")))
(FOR D IN DIFFS
DO (SELECTQ (CAR D)
(for D in DIFFS
do (SELECTQ (CAR D)
(ADDED (* ;
 "Shouldn't exist in BRANCH2, should exist in BRANCH1, but maybe ADDED and DELETED are mixed up?")
(SETQ D (CADR D))
@@ -1794,14 +1806,14 @@
(* ;; "Let the directories figure it out")
(AND NIL (IF (EQ (CADDR GFILE)
(AND NIL (if (EQ (CADDR GFILE)
100)
THEN
then
(* ;; "A little tricky to figure out what corresponds to the real file in the mapping, which directory it belongs to. Maybe the first one should always be one that exists, the second may just be a useful name. But we have to know whether to match against INFO1 or INFO2")
(HELP GFILE 100)
(PUSH MAPPINGS
(push MAPPINGS
(LIST (LIST)
(FULLNAME F1)
(SLASHIT (U-CASE (CONCAT DIR2 (CAR GFILE))
@@ -1810,7 +1822,7 @@
(NTHCHAR (CAR D)
1)
100))
ELSE
else
(* ;;
 "If not a perfect match, then the directory should figure it out")
@@ -1821,7 +1833,8 @@
(LIST DIR1 DIR2 MAPPINGS))])
(GIT-BRANCHES-COMPARE-DIRECTORIES
[LAMBDA (BRANCH1 BRANCH2 LOCAL PROJECT) (* ; "Edited 10-Jun-2024 18:42 by mth")
[LAMBDA (BRANCH1 BRANCH2 LOCAL PROJECT) (* ; "Edited 12-Jun-2024 22:52 by mth")
(* ; "Edited 10-Jun-2024 18:42 by mth")
(* ; "Edited 1-May-2024 14:58 by rmk")
(* ; "Edited 26-Sep-2023 22:40 by rmk")
(* ; "Edited 10-Jun-2023 17:28 by rmk")
@@ -1833,7 +1846,7 @@
(SETQ PROJECT (GIT-GET-PROJECT PROJECT))
(SETQ BRANCH1 (if BRANCH1
then (GITORIGIN BRANCH1 LOCAL)
else (GIT-WHICH-BRANCH PROJECT)))
else (GIT-WHICH-BRANCH PROJECT T)))
(LET (CDVALUE DIRS NENTRIES MAPPINGS (SHORT1 (GIT-SHORT-BRANCH-NAME BRANCH1))
(SHORT2 (GIT-SHORT-BRANCH-NAME BRANCH2)))
(PRINTOUT T "Comparing all " (L-CASE (fetch PROJECTNAME of PROJECT)
@@ -1923,6 +1936,8 @@
(GIT-WORKING-COMPARE-DIRECTORIES
[LAMBDA (SUBDIRS SELECT EXCLUDEDFILES FIXDIRECTORYDATES UPDATE PROJECT)
(* ;; "Edited 12-Jun-2024 22:52 by mth")
(* ;; "Edited 26-Sep-2023 22:41 by rmk")
(* ;; "Edited 17-Jun-2023 22:54 by rmk")
@@ -1942,28 +1957,28 @@
(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)
(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: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))
(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))
FIRST (PRINTOUT T "Comparing " SUBDIRSTRING 6 " of " WPROJ " and Git " BRANCH2 T)
(BKSYSBUF " ") INSIDE SUBDIRS
COLLECT (TERPRI T)
(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 '(> < ~= -* *-))
@@ -1976,24 +1991,24 @@
(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))
[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))
(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.")
(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 " "
[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)
@@ -2004,9 +2019,9 @@
,@(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]
(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)
@@ -2273,7 +2288,7 @@
(* ; "Edited 7-Jul-2022 09:36 by rmk")
(* ; "Edited 7-May-2022 22:41 by rmk")
(* ; "Edited 2-Nov-2021 21:12 by rmk:")
(CONCAT "cd " (SLASHIT (TRUEFILENAME (FETCH GITHOST OF PROJECT))
(CONCAT "cd " (SLASHIT (TRUEFILENAME (fetch GITHOST of PROJECT))
NIL T)
" && "])
@@ -2289,8 +2304,8 @@
(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))
[bind LPOS while (SETQ LPOS (STRPOS "local/" CMD))
do (SETQ CMD (CONCAT (SUBSTRING CMD 1 (SUB1 LPOS))
(SUBSTRING CMD (IPLUS LPOS (NCHARS "local/"]
(LET (LINES (RESULTFILE (GIT-COMMAND-TO-FILE CMD PROJECT NOERROR)))
(CL:WHEN (LISTP RESULTFILE) (* ; "CADR is Unix error stream")
@@ -2312,10 +2327,10 @@
(* ;; "Insures origin/ unless LOCAL or local/ already")
(CL:UNLESS BRANCH (HELP "BRANCH MUST BE SPECIFIED"))
(IF (OR (STRPOS "origin/" BRANCH)
(if (OR (STRPOS "origin/" BRANCH)
(STRPOS "local/" BRANCH))
THEN BRANCH
ELSE (CONCAT (CL:IF LOCAL
then BRANCH
else (CONCAT (CL:IF LOCAL
"local/"
"origin/")
BRANCH])
@@ -2391,18 +2406,18 @@
(* ;; "Suppress .git lines unless ALL")
(CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT :EXTERNAL-FORMAT (SYSTEM-EXTERNALFORMAT))
(BIND LINE UNTIL (EOFP STREAM) WHEN [PROGN (SETQ LINE (CL:READ-LINE STREAM :EOF-ERROR-P
(bind LINE until (EOFP STREAM) when [PROGN (SETQ LINE (CL:READ-LINE STREAM :EOF-ERROR-P
NIL :EOF-VALUE NIL))
(OR ALL (NOT (STRPOS ".git" LINE 1]
COLLECT LINE])
collect LINE])
(STRIPLOCAL
[LAMBDA (STRING) (* ; "Edited 18-Jul-2022 09:52 by rmk")
(* ;; "Removes local/ substrings wherever they appear. To be used in coerecing from a lisp internal convention that local branches carry a local tag to the git convention that an unqualified name is local.")
[BIND POS WHILE (SETQ POS (STRPOS "local/" STRING))
DO (SETQ STRING (CONCAT (SUBSTRING STRING 1 (SUB1 POS))
[bind POS while (SETQ POS (STRPOS "local/" STRING))
do (SETQ STRING (CONCAT (SUBSTRING STRING 1 (SUB1 POS))
(OR (SUBSTRING STRING (IPLUS POS (CONSTANT (NCHARS "local/")))
-1)
""]
@@ -2411,33 +2426,33 @@
(PUTPROPS GITFNS FILETYPE :TCOMPL)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (4282 20861 (GIT-CLONEP 4292 . 5620) (GIT-INIT 5622 . 6252) (GIT-MAKE-PROJECT 6254 .
13919) (GIT-GET-PROJECT 13921 . 15846) (GIT-PUT-PROJECT-FIELD 15848 . 17489) (GIT-PROJECT-PATH 17491
. 18535) (FIND-ANCESTOR-DIRECTORY 18537 . 18886) (GIT-FIND-CLONE 18888 . 19969) (GIT-MAINBRANCH 19971
. 20366) (GIT-MAINBRANCH? 20368 . 20859)) (26324 30946 (PRC-COMMAND 26334 . 30944)) (31002 33790 (
ALLSUBDIRS 31012 . 32298) (MEDLEYSUBDIRS 32300 . 32993) (GITSUBDIRS 32995 . 33788)) (33791 38581 (
TOGIT 33801 . 35207) (FROMGIT 35209 . 36190) (GIT-DELETE-FILE 36192 . 37038) (MYMEDLEY-DELETE-FILES
37040 . 38579)) (38582 41585 (MYMEDLEYSUBDIR 38592 . 39048) (GITSUBDIR 39050 . 39493) (STRIPDIR 39495
. 39866) (STRIPHOST 39868 . 40108) (STRIPNAME 40110 . 40863) (STRIPWHERE 40865 . 41583)) (41586 43488
(GFILE4MFILE 41596 . 41959) (MFILE4GFILE 41961 . 42530) (GIT-REPO-FILENAME 42532 . 43486)) (43537
53788 (GIT-COMMIT 43547 . 44373) (GIT-PUSH 44375 . 45135) (GIT-PULL 45137 . 45889) (GIT-APPROVAL 45891
. 46240) (GIT-GET-FILE 46242 . 48264) (GIT-FILE-EXISTS? 48266 . 48540) (GIT-REMOTE-UPDATE 48542 .
49266) (GIT-REMOTE-ADD 49268 . 49575) (GIT-FILE-DATE 49577 . 50624) (GIT-FILE-HISTORY 50626 . 52560) (
GIT-PRINT-FILE-HISTORY 52562 . 53612) (GIT-FETCH 53614 . 53786)) (53818 64938 (GIT-BRANCH-DIFF 53828
. 60575) (GIT-COMMIT-DIFFS 60577 . 61250) (GIT-BRANCH-RELATIONS 61252 . 64936)) (64983 83420 (
GIT-BRANCH-NUM 64993 . 65566) (GIT-CHECKOUT 65568 . 66743) (GIT-WHICH-BRANCH 66745 . 67043) (
GIT-MAKE-BRANCH 67045 . 69374) (GIT-BRANCHES 69376 . 71866) (GIT-BRANCH-EXISTS? 71868 . 72739) (
GIT-PICK-BRANCH 72741 . 73231) (GIT-BRANCH-MENU 73233 . 74114) (GIT-BRANCH-WHENSELECTEDFN 74116 .
76281) (GIT-PULL-REQUESTS 76283 . 79801) (GIT-SHORT-BRANCH-NAME 79803 . 80094) (GIT-LONG-NAME 80096 .
80413) (GIT-PRC-BRANCHES 80415 . 83418)) (83450 86785 (GIT-MY-CURRENT-BRANCH 83460 . 83830) (
GIT-MY-BRANCHP 83832 . 84337) (GIT-MY-NEXT-BRANCH 84339 . 84833) (GIT-MY-BRANCHES 84835 . 86783)) (
86831 90906 (GIT-ADD-WORKTREE 86841 . 88448) (GIT-REMOVE-WORKTREE 88450 . 89380) (GIT-LIST-WORKTREES
89382 . 90186) (WORKTREEDIR 90188 . 90904)) (90954 123925 (GIT-GET-DIFFERENT-FILES 90964 . 97388) (
GIT-BRANCHES-COMPARE-DIRECTORIES 97390 . 104510) (GIT-WORKING-COMPARE-DIRECTORIES 104512 . 109908) (
GIT-COMPARE-WORKTREE 109910 . 113888) (GITCDOBJBUTTONFN 113890 . 118380) (GIT-CD-LABELFN 118382 .
119464) (GIT-CD-MENUFN 119466 . 121906) (GIT-WORKING-COMPARE-FILES 121908 . 122528) (
GIT-BRANCHES-COMPARE-FILES 122530 . 123694) (GIT-PR-COMPARE 123696 . 123923)) (123995 132020 (CDGITDIR
124005 . 124692) (GIT-COMMAND 124694 . 126252) (GITORIGIN 126254 . 126951) (GIT-INITIALS 126953 .
127257) (GIT-COMMAND-TO-FILE 127259 . 130744) (GIT-RESULT-TO-LINES 130746 . 131353) (STRIPLOCAL 131355
. 132018)))))
(FILEMAP (NIL (4636 21215 (GIT-CLONEP 4646 . 5974) (GIT-INIT 5976 . 6606) (GIT-MAKE-PROJECT 6608 .
14273) (GIT-GET-PROJECT 14275 . 16200) (GIT-PUT-PROJECT-FIELD 16202 . 17843) (GIT-PROJECT-PATH 17845
. 18889) (FIND-ANCESTOR-DIRECTORY 18891 . 19240) (GIT-FIND-CLONE 19242 . 20323) (GIT-MAINBRANCH 20325
. 20720) (GIT-MAINBRANCH? 20722 . 21213)) (26678 31300 (PRC-COMMAND 26688 . 31298)) (31356 34144 (
ALLSUBDIRS 31366 . 32652) (MEDLEYSUBDIRS 32654 . 33347) (GITSUBDIRS 33349 . 34142)) (34145 38935 (
TOGIT 34155 . 35561) (FROMGIT 35563 . 36544) (GIT-DELETE-FILE 36546 . 37392) (MYMEDLEY-DELETE-FILES
37394 . 38933)) (38936 41939 (MYMEDLEYSUBDIR 38946 . 39402) (GITSUBDIR 39404 . 39847) (STRIPDIR 39849
. 40220) (STRIPHOST 40222 . 40462) (STRIPNAME 40464 . 41217) (STRIPWHERE 41219 . 41937)) (41940 43842
(GFILE4MFILE 41950 . 42313) (MFILE4GFILE 42315 . 42884) (GIT-REPO-FILENAME 42886 . 43840)) (43891
54253 (GIT-COMMIT 43901 . 44727) (GIT-PUSH 44729 . 45489) (GIT-PULL 45491 . 46243) (GIT-APPROVAL 46245
. 46594) (GIT-GET-FILE 46596 . 48618) (GIT-FILE-EXISTS? 48620 . 48894) (GIT-REMOTE-UPDATE 48896 .
49731) (GIT-REMOTE-ADD 49733 . 50040) (GIT-FILE-DATE 50042 . 51089) (GIT-FILE-HISTORY 51091 . 53025) (
GIT-PRINT-FILE-HISTORY 53027 . 54077) (GIT-FETCH 54079 . 54251)) (54283 65403 (GIT-BRANCH-DIFF 54293
. 61040) (GIT-COMMIT-DIFFS 61042 . 61715) (GIT-BRANCH-RELATIONS 61717 . 65401)) (65448 84460 (
GIT-BRANCH-NUM 65458 . 66031) (GIT-CHECKOUT 66033 . 67319) (GIT-WHICH-BRANCH 67321 . 67728) (
GIT-MAKE-BRANCH 67730 . 70309) (GIT-BRANCHES 70311 . 72906) (GIT-BRANCH-EXISTS? 72908 . 73779) (
GIT-PICK-BRANCH 73781 . 74271) (GIT-BRANCH-MENU 74273 . 75154) (GIT-BRANCH-WHENSELECTEDFN 75156 .
77321) (GIT-PULL-REQUESTS 77323 . 80841) (GIT-SHORT-BRANCH-NAME 80843 . 81134) (GIT-LONG-NAME 81136 .
81453) (GIT-PRC-BRANCHES 81455 . 84458)) (84490 87938 (GIT-MY-CURRENT-BRANCH 84500 . 84870) (
GIT-MY-BRANCHP 84872 . 85490) (GIT-MY-NEXT-BRANCH 85492 . 85986) (GIT-MY-BRANCHES 85988 . 87936)) (
87984 92059 (GIT-ADD-WORKTREE 87994 . 89601) (GIT-REMOVE-WORKTREE 89603 . 90533) (GIT-LIST-WORKTREES
90535 . 91339) (WORKTREEDIR 91341 . 92057)) (92107 125241 (GIT-GET-DIFFERENT-FILES 92117 . 98541) (
GIT-BRANCHES-COMPARE-DIRECTORIES 98543 . 105774) (GIT-WORKING-COMPARE-DIRECTORIES 105776 . 111224) (
GIT-COMPARE-WORKTREE 111226 . 115204) (GITCDOBJBUTTONFN 115206 . 119696) (GIT-CD-LABELFN 119698 .
120780) (GIT-CD-MENUFN 120782 . 123222) (GIT-WORKING-COMPARE-FILES 123224 . 123844) (
GIT-BRANCHES-COMPARE-FILES 123846 . 125010) (GIT-PR-COMPARE 125012 . 125239)) (125311 133336 (CDGITDIR
125321 . 126008) (GIT-COMMAND 126010 . 127568) (GITORIGIN 127570 . 128267) (GIT-INITIALS 128269 .
128573) (GIT-COMMAND-TO-FILE 128575 . 132060) (GIT-RESULT-TO-LINES 132062 . 132669) (STRIPLOCAL 132671
. 133334)))))
STOP

BIN
lispusers/GITFNS.LCOM
View File

Binary file not shown.