This fixes GITFNS prc not showing any changed files with certain filename/path patterns. (#1757)
This fixes GITFNS `prc` not showing any changed files if they included `.git` in the full name. It now is specific, and excludes only those in the `.git/` top-level directory. GITFNS also ignored changed files at the top-level of the repo. This is fixed also. This can be tested with PR #1756
This commit is contained in:
Matt Heffron
GitHub
commit
3e77f627a0
420
lispusers/GITFNS
420
lispusers/GITFNS
@ -1,12 +1,16 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "20-May-2024 22:13:04" {WMEDLEY}<lispusers>GITFNS.;530 131382
|
||||
(FILECREATED "12-Jun-2024 23:02:26" {DSK}<home>matt>Interlisp>medley>lispusers>GITFNS.;6 133403
|
||||
|
||||
:EDIT-BY rmk
|
||||
:EDIT-BY "mth"
|
||||
|
||||
:CHANGES-TO (FNS GIT-PULL-REQUESTS)
|
||||
: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 "13-May-2024 19:31:18" {WMEDLEY}<lispusers>GITFNS.;529)
|
||||
:PREVIOUS-DATE "10-Jun-2024 18:43:43" {DSK}<home>matt>Interlisp>medley>lispusers>GITFNS.;5)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT GITFNSCOMS)
|
||||
@ -294,24 +298,24 @@
|
||||
(* ; "Edited 13-May-2022 10:40 by rmk")
|
||||
(* ; "Edited 9-May-2022 20:02 by rmk")
|
||||
(* ; "Edited 8-May-2022 11:38 by rmk")
|
||||
(CL:WHEN (SETQ PROJECT (IF (TYPE? GIT-PROJECT PROJECT)
|
||||
THEN PROJECT
|
||||
ELSEIF (CDR (ASSOC (OR (U-CASE PROJECT)
|
||||
(CL:WHEN (SETQ PROJECT (if (type? GIT-PROJECT PROJECT)
|
||||
then PROJECT
|
||||
elseif (CDR (ASSOC (OR (U-CASE PROJECT)
|
||||
GIT-DEFAULT-PROJECT)
|
||||
GIT-PROJECTS))
|
||||
ELSEIF NOERROR
|
||||
THEN NIL
|
||||
ELSE (ERROR "NOT A GIT-PROJECT" PROJECT)))
|
||||
elseif NOERROR
|
||||
then NIL
|
||||
else (ERROR "NOT A GIT-PROJECT" PROJECT)))
|
||||
(SELECTQ FIELD
|
||||
(PROJECTNAME (FETCH PROJECTNAME OF PROJECT))
|
||||
(WHOST (FETCH WHOST OF PROJECT))
|
||||
(GITHOST (FETCH GITHOST OF PROJECT))
|
||||
(EXCLUSIONS (FETCH EXCLUSIONS OF PROJECT))
|
||||
(PROJECTNAME (fetch PROJECTNAME of PROJECT))
|
||||
(WHOST (fetch WHOST of PROJECT))
|
||||
(GITHOST (fetch GITHOST of PROJECT))
|
||||
(EXCLUSIONS (fetch EXCLUSIONS of PROJECT))
|
||||
(DEFAULTSUBDIRS
|
||||
(FETCH DEFAULTSUBDIRS OF PROJECT))
|
||||
(CLONEPATH (FETCH CLONEPATH OF PROJECT))
|
||||
(MAINBRANCH [OR (FETCH MAINBRANCH OF PROJECT)
|
||||
(REPLACE MAINBRANCH OF PROJECT WITH (OR (GIT-BRANCH-EXISTS? 'origin/main
|
||||
(fetch DEFAULTSUBDIRS of PROJECT))
|
||||
(CLONEPATH (fetch CLONEPATH of PROJECT))
|
||||
(MAINBRANCH [OR (fetch MAINBRANCH of PROJECT)
|
||||
(replace MAINBRANCH of PROJECT with (OR (GIT-BRANCH-EXISTS? 'origin/main
|
||||
T PROJECT)
|
||||
(GIT-BRANCH-EXISTS?
|
||||
'origin/master NIL PROJECT
|
||||
@ -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))))])
|
||||
@ -1078,6 +1083,8 @@
|
||||
(GIT-BRANCH-DIFF
|
||||
[LAMBDA (BRANCH1 BRANCH2 PROJECT)
|
||||
|
||||
(* ;; "Edited 10-Jun-2024 16:43 by mth")
|
||||
|
||||
(* ;; "Edited 2-May-2024 11:28 by mth")
|
||||
|
||||
(* ;; "Edited 29-Sep-2022 10:52 by rmk")
|
||||
@ -1117,10 +1124,10 @@
|
||||
(SETQ RLINES NIL)
|
||||
(CL:WHEN (LISTP RESULTFILE)
|
||||
(SETQ ERRORFILE (CADR RESULTFILE))
|
||||
(SETQ ELINES (GIT-RESULT-TO-LINES ERRORFILE))
|
||||
(SETQ ELINES (GIT-RESULT-TO-LINES ERRORFILE T))
|
||||
(DELFILE ERRORFILE)
|
||||
(SETQ RESULTFILE (CAR RESULTFILE)))
|
||||
(SETQ RLINES (GIT-RESULT-TO-LINES RESULTFILE))
|
||||
(SETQ RLINES (GIT-RESULT-TO-LINES RESULTFILE T))
|
||||
(DELFILE RESULTFILE)
|
||||
(CL:WHEN ELINES
|
||||
(if [AND (STRPOS "warning: inexact rename detection was skipped due to too many files."
|
||||
@ -1141,30 +1148,32 @@
|
||||
(GO RETRY))
|
||||
(ERROR "Incomplete branch differences" (LIST BRANCH1 BRANCH2)))
|
||||
else (for L in ELINES do (PRINTOUT T L T))))
|
||||
(RETURN (SORT (for L in RLINES
|
||||
(RETURN (SORT (for (L FN) in RLINES
|
||||
collect (SELCHARQ (CHCON1 L)
|
||||
(A (CL:IF (EQ (CHARCODE TAB)
|
||||
(NTHCHARCODE L 2))
|
||||
(LIST 'ADDED (SUBSTRING L 3))
|
||||
(LIST 'ADDED (SETQ FN (SUBSTRING L 3)))
|
||||
(ERROR "ADDED NOT RECOGNIZED" L)))
|
||||
(D (CL:IF (EQ (CHARCODE TAB)
|
||||
(NTHCHARCODE L 2))
|
||||
(LIST 'DELETED (SUBSTRING L 3))
|
||||
(LIST 'DELETED (SETQ FN (SUBSTRING L 3)))
|
||||
(ERROR "DELETED NOT RECOGNIZED" L)))
|
||||
(M (CL:IF (SETQ POS (STRPOS " " L))
|
||||
(LIST 'CHANGED (SUBSTRING L (ADD1 POS)))
|
||||
[LIST 'CHANGED (SETQ FN (SUBSTRING L (ADD1 POS]
|
||||
(ERROR "CHANGED NOT RECOGNIZED" L)))
|
||||
(C (if (AND (EQ (CHARCODE TAB)
|
||||
(NTHCHARCODE L 5))
|
||||
(SETQ POS (STRPOS " " L 7)))
|
||||
then (LIST 'COPIED (SUBSTRING L 6 (SUB1 POS))
|
||||
then (LIST 'COPIED (SETQ FN (SUBSTRING L 6
|
||||
(SUB1 POS)))
|
||||
(OR (FIXP (SUBATOM L 2 4))
|
||||
(HELP "C without a number" L)))
|
||||
else (HELP "COPY NOT RECOGNIZED" L)))
|
||||
(R (if (AND (EQ (CHARCODE TAB)
|
||||
(NTHCHARCODE L 5))
|
||||
(SETQ POS (STRPOS " " L 7)))
|
||||
then (LIST 'RENAMED (SUBSTRING L 6 (SUB1 POS))
|
||||
then (LIST 'RENAMED (SETQ FN (SUBSTRING L 6
|
||||
(SUB1 POS)))
|
||||
(SUBSTRING L (ADD1 POS))
|
||||
(OR (FIXP (SUBATOM L 2 4))
|
||||
(HELP "R without a number" L)))
|
||||
@ -1175,7 +1184,8 @@
|
||||
" Ignore remaining files? "
|
||||
)))
|
||||
(ERROR!)))
|
||||
(HELP "Unrecognized git-diff code " L)))
|
||||
(HELP "Unrecognized git-diff code " L))
|
||||
unless (STREQUAL ".git/" (SUBSTRING FN 1 5)))
|
||||
T])
|
||||
|
||||
(GIT-COMMIT-DIFFS
|
||||
@ -1201,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)
|
||||
@ -1222,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])
|
||||
)
|
||||
|
||||
@ -1277,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]
|
||||
@ -1295,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")
|
||||
@ -1320,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? ")))
|
||||
@ -1343,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")
|
||||
@ -1357,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)
|
||||
@ -1408,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
|
||||
@ -1463,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)
|
||||
@ -1529,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)))])
|
||||
)
|
||||
@ -1569,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")
|
||||
@ -1726,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)
|
||||
">"))
|
||||
@ -1741,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))
|
||||
@ -1789,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))
|
||||
@ -1805,7 +1822,7 @@
|
||||
(NTHCHAR (CAR D)
|
||||
1)
|
||||
100))
|
||||
ELSE
|
||||
else
|
||||
(* ;;
|
||||
"If not a perfect match, then the directory should figure it out")
|
||||
|
||||
@ -1816,7 +1833,9 @@
|
||||
(LIST DIR1 DIR2 MAPPINGS))])
|
||||
|
||||
(GIT-BRANCHES-COMPARE-DIRECTORIES
|
||||
[LAMBDA (BRANCH1 BRANCH2 LOCAL PROJECT) (* ; "Edited 1-May-2024 14:58 by rmk")
|
||||
[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")
|
||||
(* ; "Edited 12-Sep-2022 14:41 by rmk")
|
||||
@ -1825,23 +1844,26 @@
|
||||
(* ; "Edited 9-May-2022 15:14 by rmk")
|
||||
(* ; "Edited 3-May-2022 23:04 by rmk")
|
||||
(SETQ PROJECT (GIT-GET-PROJECT PROJECT))
|
||||
(SETQ BRANCH1 (IF BRANCH1
|
||||
THEN (GITORIGIN BRANCH1 LOCAL)
|
||||
ELSE (GIT-WHICH-BRANCH PROJECT)))
|
||||
(SETQ BRANCH1 (if BRANCH1
|
||||
then (GITORIGIN BRANCH1 LOCAL)
|
||||
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)
|
||||
(PRINTOUT T "Comparing all " (L-CASE (fetch PROJECTNAME of PROJECT)
|
||||
T)
|
||||
" subdirectories of " SHORT1 " and " SHORT2 T)
|
||||
(PRINTOUT T "Fetching differences" T)
|
||||
(SETQ DIRS (GIT-GET-DIFFERENT-FILES BRANCH1 BRANCH2 NIL NIL PROJECT))
|
||||
(SETQ MAPPINGS (CADDR DIRS))
|
||||
(IF DIRS
|
||||
THEN (TERPRI T)
|
||||
(if DIRS
|
||||
then (TERPRI T)
|
||||
|
||||
(* ;; "INCLUDEDFILES parameter to COMPAREDIRECTORIES needs to allow both top-level files, and leading dot filenames.")
|
||||
|
||||
[SETQ CDVALUE (COMPAREDIRECTORIES (CAR DIRS)
|
||||
(CADR DIRS)
|
||||
'(> < ~= -* *-)
|
||||
'*>*.*
|
||||
'(*.* *>*.* .* *>.*)
|
||||
(GIT-GET-PROJECT PROJECT 'EXCLUSIONS)
|
||||
NIL NIL NIL NIL (LIST (PACKFILENAME 'HOST NIL 'BODY
|
||||
(CAR DIRS))
|
||||
@ -1857,30 +1879,30 @@
|
||||
(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)
|
||||
(find M in MAPPINGS
|
||||
suchthat (STRING.EQUAL (CAR M)
|
||||
(fetch (CDINFO FULLNAME)
|
||||
of INFO1)
|
||||
FILEDIRCASEARRAY)))]
|
||||
(CL:WHEN MAP
|
||||
(HELP 'MAP MAP))
|
||||
(CL:WHEN INFO1
|
||||
(CHANGE (FETCH (CDINFO FULLNAME) OF INFO1)
|
||||
(change (fetch (CDINFO FULLNAME) of INFO1)
|
||||
(SLASHIT (PACKFILENAME.STRING 'VERSION NIL
|
||||
'BODY DATUM)
|
||||
T)))
|
||||
(CL:WHEN INFO2
|
||||
(CHANGE (FETCH (CDINFO FULLNAME) OF INFO2)
|
||||
(change (fetch (CDINFO FULLNAME) of INFO2)
|
||||
(SLASHIT (PACKFILENAME.STRING 'VERSION NIL
|
||||
'BODY DATUM)
|
||||
T)))
|
||||
(IF MAP
|
||||
THEN
|
||||
(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
|
||||
(replace (CDENTRY INFO2) of CDE
|
||||
with (create CDINFO
|
||||
FULLNAME _ (CADR MAP)
|
||||
DATE _ (CL:IF (EQ 'R (CADDR MAP))
|
||||
" <-"
|
||||
@ -1889,31 +1911,33 @@
|
||||
AUTHOR _ ""
|
||||
TYPE _ ""
|
||||
EOL _ ""))
|
||||
(REPLACE (CDENTRY DATEREL) OF CDE
|
||||
WITH (CADDR MAP]
|
||||
(replace (CDENTRY DATEREL) of CDE
|
||||
with (CADDR MAP]
|
||||
(TERPRI T)
|
||||
(IF (FETCH (CDVALUE CDENTRIES) OF CDVALUE)
|
||||
THEN (SETQ LAST-BRANCH-CDVALUE CDVALUE)
|
||||
(CDBROWSER CDVALUE (CONCAT (L-CASE (FETCH PROJECTNAME OF PROJECT)
|
||||
(if (fetch (CDVALUE CDENTRIES) of CDVALUE)
|
||||
then (SETQ LAST-BRANCH-CDVALUE CDVALUE)
|
||||
(CDBROWSER CDVALUE (CONCAT (L-CASE (fetch PROJECTNAME of PROJECT)
|
||||
T)
|
||||
" " SHORT1 " vs " SHORT2 " "
|
||||
(LENGTH (FETCH (CDVALUE CDENTRIES) OF CDVALUE))
|
||||
(LENGTH (fetch (CDVALUE CDENTRIES) of CDVALUE))
|
||||
" files")
|
||||
(LIST SHORT1 SHORT2)
|
||||
`(LABELFN GIT-CD-LABELFN BRANCH1 ,BRANCH1 BRANCH2 ,BRANCH2 PROJECT
|
||||
,PROJECT)
|
||||
GIT-CDBROWSER-SEPARATE-DIRECTIONS
|
||||
`(Compare See))
|
||||
(SETQ NENTRIES (LENGTH (FETCH (CDVALUE CDENTRIES) OF CDVALUE)))
|
||||
(SETQ NENTRIES (LENGTH (fetch (CDVALUE CDENTRIES) of CDVALUE)))
|
||||
(LIST NENTRIES (CL:IF (EQ NENTRIES 1)
|
||||
'difference
|
||||
'differences))
|
||||
ELSE '(0 differences))
|
||||
ELSE '(0 differences])
|
||||
else '(0 differences))
|
||||
else '(0 differences])
|
||||
|
||||
(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")
|
||||
@ -1933,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 '(> < ~= -* *-))
|
||||
@ -1967,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)
|
||||
@ -1995,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)
|
||||
@ -2264,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)
|
||||
" && "])
|
||||
|
||||
@ -2280,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")
|
||||
@ -2303,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])
|
||||
@ -2338,7 +2362,7 @@
|
||||
(RESULTFILE (CONCAT "{UNIX}/tmp/" PROJECTNAME "-" DATE "-" RAND "-result"))
|
||||
(ERRORFILE (CONCAT "{UNIX}/tmp/" PROJECTNAME "-" DATE "-" RAND "-error"))
|
||||
COMPLETIONCODE)
|
||||
[SETQ COMPLETIONCODE (PROCESS-COMMAND (CONCAT (CDGITDIR PROJECT)
|
||||
[SETQ COMPLETIONCODE (PROCESS-COMMAND (CONCAT (CDGITDIR PROJECT)
|
||||
CMD " > " (STRIPHOST RESULTFILE)
|
||||
" 2> "
|
||||
(STRIPHOST ERRORFILE]
|
||||
@ -2365,12 +2389,12 @@
|
||||
(FILEPOS "unknown command %"" ESTREAM 0 1)))
|
||||
(FILEPOS "' is not a git command." ESTREAM (NCHARS CMD)))
|
||||
(SETQ COMPLETIONCODE 1))))
|
||||
(IF (EQ 0 COMPLETIONCODE)
|
||||
THEN (IF (AND RESULTFILE ERRORFILE)
|
||||
THEN (LIST RESULTFILE ERRORFILE)
|
||||
ELSEIF RESULTFILE
|
||||
ELSE ERRORFILE)
|
||||
ELSE (DELFILE RESULTFILE)
|
||||
(if (EQ 0 COMPLETIONCODE)
|
||||
then (if (AND RESULTFILE ERRORFILE)
|
||||
then (LIST RESULTFILE ERRORFILE)
|
||||
elseif RESULTFILE
|
||||
else ERRORFILE)
|
||||
else (DELFILE RESULTFILE)
|
||||
(DELFILE ERRORFILE)
|
||||
(CL:UNLESS NOERROR
|
||||
(ERROR (CONCAT "Command failed: " CMD)))
|
||||
@ -2382,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)
|
||||
""]
|
||||
@ -2402,33 +2426,33 @@
|
||||
|
||||
(PUTPROPS GITFNS FILETYPE :TCOMPL)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (4187 20766 (GIT-CLONEP 4197 . 5525) (GIT-INIT 5527 . 6157) (GIT-MAKE-PROJECT 6159 .
|
||||
13824) (GIT-GET-PROJECT 13826 . 15751) (GIT-PUT-PROJECT-FIELD 15753 . 17394) (GIT-PROJECT-PATH 17396
|
||||
. 18440) (FIND-ANCESTOR-DIRECTORY 18442 . 18791) (GIT-FIND-CLONE 18793 . 19874) (GIT-MAINBRANCH 19876
|
||||
. 20271) (GIT-MAINBRANCH? 20273 . 20764)) (26229 30851 (PRC-COMMAND 26239 . 30849)) (30907 33695 (
|
||||
ALLSUBDIRS 30917 . 32203) (MEDLEYSUBDIRS 32205 . 32898) (GITSUBDIRS 32900 . 33693)) (33696 38486 (
|
||||
TOGIT 33706 . 35112) (FROMGIT 35114 . 36095) (GIT-DELETE-FILE 36097 . 36943) (MYMEDLEY-DELETE-FILES
|
||||
36945 . 38484)) (38487 41490 (MYMEDLEYSUBDIR 38497 . 38953) (GITSUBDIR 38955 . 39398) (STRIPDIR 39400
|
||||
. 39771) (STRIPHOST 39773 . 40013) (STRIPNAME 40015 . 40768) (STRIPWHERE 40770 . 41488)) (41491 43393
|
||||
(GFILE4MFILE 41501 . 41864) (MFILE4GFILE 41866 . 42435) (GIT-REPO-FILENAME 42437 . 43391)) (43442
|
||||
53693 (GIT-COMMIT 43452 . 44278) (GIT-PUSH 44280 . 45040) (GIT-PULL 45042 . 45794) (GIT-APPROVAL 45796
|
||||
. 46145) (GIT-GET-FILE 46147 . 48169) (GIT-FILE-EXISTS? 48171 . 48445) (GIT-REMOTE-UPDATE 48447 .
|
||||
49171) (GIT-REMOTE-ADD 49173 . 49480) (GIT-FILE-DATE 49482 . 50529) (GIT-FILE-HISTORY 50531 . 52465) (
|
||||
GIT-PRINT-FILE-HISTORY 52467 . 53517) (GIT-FETCH 53519 . 53691)) (53723 64496 (GIT-BRANCH-DIFF 53733
|
||||
. 60133) (GIT-COMMIT-DIFFS 60135 . 60808) (GIT-BRANCH-RELATIONS 60810 . 64494)) (64541 82978 (
|
||||
GIT-BRANCH-NUM 64551 . 65124) (GIT-CHECKOUT 65126 . 66301) (GIT-WHICH-BRANCH 66303 . 66601) (
|
||||
GIT-MAKE-BRANCH 66603 . 68932) (GIT-BRANCHES 68934 . 71424) (GIT-BRANCH-EXISTS? 71426 . 72297) (
|
||||
GIT-PICK-BRANCH 72299 . 72789) (GIT-BRANCH-MENU 72791 . 73672) (GIT-BRANCH-WHENSELECTEDFN 73674 .
|
||||
75839) (GIT-PULL-REQUESTS 75841 . 79359) (GIT-SHORT-BRANCH-NAME 79361 . 79652) (GIT-LONG-NAME 79654 .
|
||||
79971) (GIT-PRC-BRANCHES 79973 . 82976)) (83008 86343 (GIT-MY-CURRENT-BRANCH 83018 . 83388) (
|
||||
GIT-MY-BRANCHP 83390 . 83895) (GIT-MY-NEXT-BRANCH 83897 . 84391) (GIT-MY-BRANCHES 84393 . 86341)) (
|
||||
86389 90464 (GIT-ADD-WORKTREE 86399 . 88006) (GIT-REMOVE-WORKTREE 88008 . 88938) (GIT-LIST-WORKTREES
|
||||
88940 . 89744) (WORKTREEDIR 89746 . 90462)) (90512 123216 (GIT-GET-DIFFERENT-FILES 90522 . 96946) (
|
||||
GIT-BRANCHES-COMPARE-DIRECTORIES 96948 . 103801) (GIT-WORKING-COMPARE-DIRECTORIES 103803 . 109199) (
|
||||
GIT-COMPARE-WORKTREE 109201 . 113179) (GITCDOBJBUTTONFN 113181 . 117671) (GIT-CD-LABELFN 117673 .
|
||||
118755) (GIT-CD-MENUFN 118757 . 121197) (GIT-WORKING-COMPARE-FILES 121199 . 121819) (
|
||||
GIT-BRANCHES-COMPARE-FILES 121821 . 122985) (GIT-PR-COMPARE 122987 . 123214)) (123286 131315 (CDGITDIR
|
||||
123296 . 123983) (GIT-COMMAND 123985 . 125543) (GITORIGIN 125545 . 126242) (GIT-INITIALS 126244 .
|
||||
126548) (GIT-COMMAND-TO-FILE 126550 . 130039) (GIT-RESULT-TO-LINES 130041 . 130648) (STRIPLOCAL 130650
|
||||
. 131313)))))
|
||||
(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
|
||||
|
||||
Binary file not shown.
Loading…
x
Reference in New Issue
Block a user