From 9f0475936ff6f8024bda4da5f5ca278a846978b5 Mon Sep 17 00:00:00 2001 From: Matt Heffron Date: Thu, 2 May 2024 23:16:26 -0700 Subject: [PATCH] GITFNS quote branch names in git commands (#1693) * GITFNS gets prc information in JSON form prc uses the simple JSON parser in the new lispusers file JSON to convert the json string into a lisp data structure. Maybe the commonlisp package YASON that Matt looked at would be more general, but perhaps also requires more understanding. With this change, drafts should be marked with D, approves should be marked with A. * Quote branch names in git commands -- attempt to fix issue #1691 --------- Co-authored-by: rmkaplan --- lispusers/GITFNS | 359 +++++++++++++++++++++-------------------- lispusers/GITFNS.LCOM | Bin 49894 -> 50175 bytes lispusers/GITFNS.TEDIT | Bin 19602 -> 19674 bytes lispusers/JSON | 207 ++++++++++++++++++++++++ lispusers/JSON.LCOM | Bin 0 -> 3639 bytes 5 files changed, 392 insertions(+), 174 deletions(-) create mode 100644 lispusers/JSON create mode 100644 lispusers/JSON.LCOM diff --git a/lispusers/GITFNS b/lispusers/GITFNS index 29ea33db..be26529a 100644 --- a/lispusers/GITFNS +++ b/lispusers/GITFNS @@ -1,12 +1,14 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 1-Oct-2023 19:33:26" {WMEDLEY}GITFNS.;489 124166 +(FILECREATED " 2-May-2024 13:01:27" {LU}GITFNS.;6 125122 - :EDIT-BY rmk + :EDIT-BY "mth" - :CHANGES-TO (FNS GIT-MAKE-PROJECT) + :CHANGES-TO (FNS GIT-BRANCH-EXISTS? GIT-GET-FILE GIT-CHECKOUT GIT-FILE-DATE GIT-PULL GIT-PUSH + GIT-COMMIT-DIFFS GIT-MAKE-BRANCH GIT-ADD-WORKTREE GIT-BRANCHES GIT-BRANCH-DIFF + ) - :PREVIOUS-DATE " 1-Oct-2023 19:27:42" {WMEDLEY}GITFNS.;488) + :PREVIOUS-DATE "30-Apr-2024 14:30:11" {LU}GITFNS.;3) (PRETTYCOMPRINT GITFNSCOMS) @@ -16,7 +18,7 @@ (* ;; "Set up") (FILES (SYSLOAD FROM LISPUSERS) - COMPAREDIRECTORIES COMPARESOURCES COMPARETEXT PSEUDOHOSTS UNIXUTILS) + COMPAREDIRECTORIES COMPARESOURCES COMPARETEXT PSEUDOHOSTS JSON UNIXUTILS) (* ;; "") @@ -68,7 +70,7 @@ (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 GIT-PR-BRANCHES) + GIT-FETCH) (* ;; "Differences") @@ -119,7 +121,7 @@ (FILESLOAD (SYSLOAD FROM LISPUSERS) - COMPAREDIRECTORIES COMPARESOURCES COMPARETEXT PSEUDOHOSTS UNIXUTILS) + COMPAREDIRECTORIES COMPARESOURCES COMPARETEXT PSEUDOHOSTS JSON UNIXUTILS) @@ -531,7 +533,12 @@ (DEFINEQ (PRC-COMMAND - [LAMBDA (REMOTEBRANCH DRAFTS PROJECT) (* ; "Edited 28-Jul-2023 09:03 by rmk") + [LAMBDA (REMOTEBRANCH DRAFTS PROJECT) (* ; "Edited 30-Apr-2024 14:09 by rmk") + (* ; "Edited 1-Apr-2024 20:24 by rmk") + (* ; "Edited 28-Jul-2023 09:03 by rmk") + + (* ;; "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 PRMENU) (IF PROJECT THEN (SETQ PROJECT (GIT-GET-PROJECT PROJECT)) @@ -541,12 +548,20 @@ ELSEIF (GIT-GET-PROJECT DRAFTS NIL T) THEN (SETQ PROJECT DRAFTS) (SETQ DRAFTS NIL)) - (CL:WHEN (MEMB (U-CASE REMOTEBRANCH) - '(DRAFT DRAFTS)) - (SETQ REMOTEBRANCH NIL) - (SETQ DRAFTS T)) + (SELECTQ (U-CASE REMOTEBRANCH) + ((DRAFT DRAFTS) + (SETQ REMOTEBRANCH NIL) + (SETQ DRAFTS 'DRAFTS)) + ((NODRAFT NODRAFTS) + (SETQ REMOTEBRANCH NIL) + (SETQ DRAFTS 'NODRAFTS)) + NIL) (GIT-FETCH PROJECT) - (SETQ PRS (GIT-PULL-REQUESTS T DRAFTS PROJECT)) + + (* ;; "Always include drafts??") + + (SETQ PRS (GIT-PULL-REQUESTS (NEQ 'NODRAFTS DRAFTS) + PROJECT)) (CL:WHEN (AND REMOTEBRANCH (NEQ REMOTEBRANCH 'PinMenu)) (for PR in PRS when (OR (STRPOS REMOTEBRANCH (fetch PRDESCRIPTION of PR) NIL NIL NIL NIL FILEDIRCASEARRAY) @@ -845,23 +860,26 @@ (SETQ GFILES (FOR F GF INSIDE FILES COLLECT (SETQ GF (INFILEP (GFILE4MFILE F PROJECT]) (GIT-PUSH - [LAMBDA (BRANCH PROJECT) (* ; "Edited 9-May-2022 15:06 by rmk") + [LAMBDA (BRANCH PROJECT) (* ; "Edited 2-May-2024 11:23 by mth") + (* ; "Edited 9-May-2022 15:06 by rmk") (* ; "Edited 8-Dec-2021 22:32 by rmk") (* ; "Edited 16-Nov-2021 08:06 by rmk:") (* ; "Edited 2-Nov-2021 21:34 by rmk:") (CL:UNLESS BRANCH (SETQ BRANCH (GIT-WHICH-BRANCH PROJECT))) (GIT-MAINBRANCH? BRANCH PROJECT) - (GIT-COMMAND (CONCAT "git push " BRANCH) + (GIT-COMMAND (CONCAT "git push %"" BRANCH "%"") NIL NIL PROJECT]) (GIT-PULL - [LAMBDA (BRANCH PROJECT) (* ; "Edited 9-May-2022 15:07 by rmk") + [LAMBDA (BRANCH PROJECT) (* ; "Edited 2-May-2024 11:22 by mth") + (* ; "Edited 9-May-2022 15:07 by rmk") (* ; "Edited 8-Dec-2021 22:47 by rmk") (* ; "Edited 16-Nov-2021 08:06 by rmk:") (* ; "Edited 2-Nov-2021 21:34 by rmk:") (SETQ PROJECT (GIT-GET-PROJECT PROJECT)) - (GIT-COMMAND (CONCAT "git pull " (OR BRANCH (GIT-WHICH-BRANCH PROJECT))) + (GIT-COMMAND (CONCAT "git pull %"" (OR BRANCH (GIT-WHICH-BRANCH PROJECT)) + "%"") NIL NIL PROJECT]) (GIT-APPROVAL @@ -874,6 +892,8 @@ (GIT-GET-FILE [LAMBDA (BRANCH GITFILE LOCALFILE NOERROR PROJECT) + (* ;; "Edited 2-May-2024 12:08 by mth") + (* ;; "Edited 18-Jul-2022 09:18 by rmk") (* ;; "Edited 8-Jul-2022 10:36 by rmk") @@ -894,7 +914,7 @@ (CL:WHEN (AND BRANCH (STRPOS "local/" BRANCH 1 NIL T)) (SETQ BRANCH (SUBSTRING BRANCH 7))) - (LET ((RESULTFILE (GIT-COMMAND-TO-FILE (CONCAT "git show " BRANCH ":" GITFILE) + (LET ((RESULTFILE (GIT-COMMAND-TO-FILE (CONCAT "git show %"" BRANCH ":" GITFILE "%"") PROJECT T)) TYPE DATE) (CL:WHEN (LISTP RESULTFILE) (* ; "CADR is Unix error stream") @@ -903,15 +923,15 @@ (COPYCHARS ESTREAM T)) (DELFILE (CADR RESULTFILE)) (SETQ RESULTFILE (CAR RESULTFILE))) - (IF RESULTFILE - THEN (CL:MULTIPLE-VALUE-SETQ (TYPE DATE) + (if RESULTFILE + then (CL:MULTIPLE-VALUE-SETQ (TYPE DATE) (LISPFILETYPE RESULTFILE)) (CL:WHEN (OR DATE (SETQ DATE (GIT-FILE-DATE GITFILE BRANCH PROJECT NOERROR))) (SETFILEINFO RESULTFILE 'CREATIONDATE DATE)) (RENAMEFILE RESULTFILE LOCALFILE) - ELSEIF NOERROR - THEN NIL - ELSE (ERROR "GIT FILE NOT FOUND" GITFILE]) + elseif NOERROR + then NIL + else (ERROR "GIT FILE NOT FOUND" GITFILE]) (GIT-FILE-EXISTS? [LAMBDA (GFILE BRANCH PROJECT) (* ; "Edited 5-Jul-2022 10:27 by rmk") @@ -945,13 +965,14 @@ (CAR RESULT]) (GIT-FILE-DATE - [LAMBDA (GFILE BRANCH PROJECT NOERROR) (* ; "Edited 6-Jul-2022 19:39 by rmk") + [LAMBDA (GFILE BRANCH PROJECT NOERROR) (* ; "Edited 2-May-2024 11:22 by mth") + (* ; "Edited 6-Jul-2022 19:39 by rmk") (* ; "Edited 5-Jul-2022 10:30 by rmk") (CL:WHEN (AND NIL BRANCH (STRPOS "local/" BRANCH 1 NIL T)) (SETQ BRANCH (SUBSTRING BRANCH 7))) (LET [(DATE (CAR (GIT-COMMAND (CONCAT "git log -1 --pretty=%"format:%%cD%" " (CL:IF BRANCH - (CONCAT BRANCH " -- ") + (CONCAT "%"" BRANCH "%" -- ") "") (GIT-REPO-FILENAME GFILE PROJECT)) NIL T PROJECT] @@ -1019,35 +1040,6 @@ (GIT-FETCH [LAMBDA (PROJECT) (* ; "Edited 8-Jul-2022 10:32 by rmk") (GIT-COMMAND "git fetch" T NIL PROJECT]) - -(GIT-PR-BRANCHES - [LAMBDA (DRAFT PROJECT PRS) (* ; "Edited 8-Aug-2022 18:15 by rmk") - (* ; "Edited 4-Aug-2022 18:55 by rmk") - (* ; "Edited 9-Jul-2022 19:01 by rmk") - (* ; "Edited 16-May-2022 19:44 by rmk") - (CL:UNLESS PRS - (SETQ PRS (GIT-PULL-REQUESTS T DRAFT PROJECT))) - (CL:WHEN PRS - (LET ((RELATIONS (GIT-BRANCH-RELATIONS (FOR PR IN PRS COLLECT (GITORIGIN (CADDR PR))) - NIL T PROJECT))) - (SORT [FOR PR REL LABEL PRNAME (SUPERSETS _ (CAR RELATIONS)) - (EQUALS _ (CADR RELATIONS)) IN PRS - COLLECT (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))) - (LIST (CL:IF (EQ 'DRAFT (FETCH PRSTATUS OF PR)) - (CONCAT LABEL " (draft)") - LABEL) - (GITORIGIN PRNAME) - (CONCAT " " (FETCH PRDESCRIPTION OF PR) - " #" - (FETCH PRNUMBER OF PR] - T)))]) ) @@ -1059,6 +1051,8 @@ (GIT-BRANCH-DIFF [LAMBDA (BRANCH1 BRANCH2 PROJECT) + (* ;; "Edited 2-May-2024 11:28 by mth") + (* ;; "Edited 29-Sep-2022 10:52 by rmk") (* ;; "Edited 12-Sep-2022 14:13 by rmk") @@ -1088,9 +1082,9 @@ (* ;; "Nick previously suggested: %"git diff --name-status -C --find-copies-harder branch1%", but that brought in too many files. The merge-base seems to match the Git desktop.") (SETQ RESULTFILE (GIT-COMMAND-TO-FILE (CONCAT - "git diff -C --find-copies-harder $(git merge-base " - BRANCH1 " " BRANCH2 ") " BRANCH2 - " --name-status") + "git diff -C --find-copies-harder $(git merge-base %"" + BRANCH1 "%" %"" BRANCH2 "%") %"" BRANCH2 + "%" --name-status") PROJECT)) (SETQ ELINES NIL) (SETQ RLINES NIL) @@ -1102,26 +1096,26 @@ (SETQ RLINES (GIT-RESULT-TO-LINES RESULTFILE)) (DELFILE RESULTFILE) (CL:WHEN ELINES - (IF [AND (STRPOS "warning: inexact rename detection was skipped due to too many files." + (if [AND (STRPOS "warning: inexact rename detection was skipped due to too many files." (CAR ELINES) 1) (SETQ LIMIT (FIXP (SUBATOM (CADR ELINES) (STRPOS " at least " (CADR ELINES) 1 NIL NIL T) (SUB1 (STRPOS " and retry " (CADR ELINES] - THEN (PRINTOUT T 3 "** For accurate branch differences, " + then (PRINTOUT T 3 "** For accurate branch differences, " "diff.renameLimit must be increased") (SELECTQ (AND LIMIT (ASKUSER NIL 'N (CONCAT " Should I increase the global limit to " - (ADD LIMIT 1) + (add LIMIT 1) " and try again? "))) (Y (GIT-COMMAND (CONCAT "git config --global diff.renameLimit " LIMIT) NIL NIL PROJECT) (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 - COLLECT (SELCHARQ (CHCON1 L) + else (for L in ELINES do (PRINTOUT T L T)))) + (RETURN (SORT (for L in RLINES + collect (SELCHARQ (CHCON1 L) (A (CL:IF (EQ (CHARCODE TAB) (NTHCHARCODE L 2)) (LIST 'ADDED (SUBSTRING L 3)) @@ -1133,21 +1127,21 @@ (M (CL:IF (SETQ POS (STRPOS " " L)) (LIST 'CHANGED (SUBSTRING L (ADD1 POS))) (ERROR "CHANGED NOT RECOGNIZED" L))) - (C (IF (AND (EQ (CHARCODE TAB) + (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 (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) + 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 (SUBSTRING L 6 (SUB1 POS)) (SUBSTRING L (ADD1 POS)) (OR (FIXP (SUBATOM L 2 4)) (HELP "R without a number" L))) - ELSE (HELP "RENAME NOT RECOGNIZED" L))) + else (HELP "RENAME NOT RECOGNIZED" L))) (w (CL:UNLESS (STRPOS "warning: " L 1) (HELP "UNRECOGNZED GIT LINE" L)) (CL:UNLESS (EQ 'Y (ASKUSER NIL NIL (CONCAT L @@ -1158,13 +1152,14 @@ T]) (GIT-COMMIT-DIFFS - [LAMBDA (BRANCH1 BUTNOTBRANCH2 PROJECT) (* ; "Edited 26-Jun-2022 13:32 by rmk") + [LAMBDA (BRANCH1 BUTNOTBRANCH2 PROJECT) (* ; "Edited 2-May-2024 11:24 by mth") + (* ; "Edited 26-Jun-2022 13:32 by rmk") (* ; "Edited 7-May-2022 23:48 by rmk") (* ; "Edited 2-May-2022 13:45 by rmk") (* ;; "Returns the identifiers for commits in BRANCH1 but not in BUTNOTBRANCH2") - (GIT-COMMAND (CONCAT "git log --format=%"%%h%" " BRANCH1 " ^" BUTNOTBRANCH2) + (GIT-COMMAND (CONCAT "git log --format=%"%%h%" %"" BRANCH1 "%" %"^" BUTNOTBRANCH2 "%"") NIL NIL PROJECT]) (GIT-BRANCH-RELATIONS @@ -1255,7 +1250,8 @@ 0])]) (GIT-CHECKOUT - [LAMBDA (BRANCH PROJECT) (* ; "Edited 7-Jul-2022 20:21 by rmk") + [LAMBDA (BRANCH PROJECT) (* ; "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:") @@ -1265,7 +1261,7 @@ [SETQ CURRENTBRANCH (SUBSTRING CURRENTBRANCH (ADD1 (STRPOS "/" CURRENTBRANCH] (CL:UNLESS [STRING.EQUAL CURRENTBRANCH (SUBSTRING BRANCH (ADD1 (OR (STRPOS "/" BRANCH) 0] - (GIT-COMMAND (CONCAT "git checkout " BRANCH) + (GIT-COMMAND (CONCAT "git checkout %"" BRANCH "%"") NIL T PROJECT) (CAR (GIT-COMMAND (CONCAT "git pull") NIL T PROJECT))) @@ -1279,7 +1275,8 @@ (MKATOM (CONCAT "local/" (CAR (GIT-COMMAND "git rev-parse --abbrev-ref HEAD" NIL NIL PROJECT]) (GIT-MAKE-BRANCH - [LAMBDA (NAME TITLESTRING PROJECT) (* ; "Edited 18-Jul-2022 21:45 by rmk") + [LAMBDA (NAME TITLESTRING PROJECT) (* ; "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") @@ -1296,30 +1293,31 @@ (* ;; "Git branch names can't contain spaces or colons") - [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 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)) RESULT) - (IF (EQ 'Y (ASKUSER NIL 'N (CONCAT "Branch " NAME " will be created under " UNDER + (if (EQ 'Y (ASKUSER NIL 'N (CONCAT "Branch " NAME " will be created under " UNDER ". Is that OK? "))) - THEN (SETQ RESULT (GIT-COMMAND (CONCAT "git checkout -b " NAME) + then (SETQ RESULT (GIT-COMMAND (CONCAT "git checkout -b %"" NAME "%"") NIL NIL PROJECT)) - (IF (STREQUAL (CAR RESULT) + (if (STREQUAL (CAR RESULT) (CONCAT "Switched to a new branch '" NAME "'")) - THEN (CONCAT (CAR RESULT) + then (CONCAT (CAR RESULT) " under " UNDER) - ELSEIF (STREQUAL (CAR RESULT) + elseif (STREQUAL (CAR RESULT) (CONCAT "fatal: A branch named '" NAME "' already exists.")) - THEN (ERROR NAME "already exists") - ELSE (HELP "Unexpected git result" RESULT)) - ELSE (PRINTOUT T "New branch not created" T) + then (ERROR NAME "already exists") + else (HELP "Unexpected git result" RESULT)) + else (PRINTOUT T "New branch not created" T) NIL]) (GIT-BRANCHES - [LAMBDA (WHERE PROJECT EXCLUDEMERGED) (* ; "Edited 9-Aug-2022 10:45 by rmk") + [LAMBDA (WHERE PROJECT EXCLUDEMERGED) (* ; "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") (* ; "Edited 23-May-2022 14:25 by rmk") @@ -1332,37 +1330,41 @@ (LET ([LOCAL (CL:WHEN (MEMB (U-CASE WHERE) '(NIL ALL LOCAL)) - [FOR B IN (GIT-COMMAND "git branch" NIL NIL PROJECT) - COLLECT (SUBATOM B 3 (SUB1 (OR (STRPOS " -> " B) + [for B in (GIT-COMMAND "git branch" NIL 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) - COLLECT (SUBATOM B 3 (SUB1 (OR (STRPOS " -> " B) + [for B in (GIT-COMMAND "git branch -r" NIL NIL PROJECT) + collect (SUBATOM B 3 (SUB1 (OR (STRPOS " -> " B) 0])] BRANCHES) (SETQ BRANCHES (UNION LOCAL REMOTE)) - (CL:WHEN (THEREIS B IN BRANCHES SUCHTHAT (STRPOS "HEAD detached" B)) + (CL:WHEN (thereis B in BRANCHES suchthat (STRPOS "HEAD detached" B)) (PRINTOUT T "Execute %"git gc%" to eliminate a branch with a detached HEAD" T)) (CL:WHEN EXCLUDEMERGED - (SETQ BRANCHES (FOR B (MAINBRANCH _ (GIT-MAINBRANCH PROJECT 'LOCAL)) IN BRANCHES - WHEN (EQUAL (GIT-COMMAND (CONCAT "git merge-base " B " " MAINBRANCH)) - (GIT-COMMAND (CONCAT "git rev-parse " B))) COLLECT B))) + (SETQ BRANCHES (for B (MAINBRANCH _ (GIT-MAINBRANCH PROJECT 'LOCAL)) in BRANCHES + when (EQUAL (GIT-COMMAND (CONCAT "git merge-base %"" B "%" %"" + MAINBRANCH "%"")) + (GIT-COMMAND (CONCAT "git rev-parse %"" B "%""))) + collect B))) (SORT BRANCHES]) (GIT-BRANCH-EXISTS? - [LAMBDA (BRANCH NOERROR PROJECT EXCLUDEMERGED) (* ; "Edited 19-May-2022 10:10 by rmk") + [LAMBDA (BRANCH NOERROR PROJECT EXCLUDEMERGED) (* ; "Edited 2-May-2024 13:00 by mth") + (* ; "Edited 19-May-2022 10:10 by rmk") (* ;; "Returns the canonical name of the branch (xxx or origin/xxx) depending on whether BRANCH is local/xxx or origin/xxx") - (IF (CAR (MEMB (MKATOM BRANCH) - (GIT-BRANCHES (IF (STRPOS "origin/" BRANCH 1 NIL T) - THEN 'REMOTE - ELSEIF (STRPOS "local/" BRANCH 1 NIL T) - THEN 'LOCAL) - PROJECT EXCLUDEMERGED))) - ELSEIF (NOT NOERROR) - THEN (ERROR "Unknown branch" BRANCH]) + (LET [(WHERE (if (STRPOS "origin/" BRANCH 1 NIL T) + then 'REMOTE + elseif (STRPOS "local/" BRANCH 1 NIL T) + then [SETQ BRANCH (SUBSTRING BRANCH (ADD1 (STRPOS "/" BRANCH 1] + 'LOCAL] + (if (CAR (MEMB (MKATOM BRANCH) + (GIT-BRANCHES WHERE PROJECT EXCLUDEMERGED))) + elseif (NOT NOERROR) + then (ERROR "Unknown branch" BRANCH]) (GIT-PICK-BRANCH [LAMBDA (BRANCHES TITLE) (* ; "Edited 6-Jul-2023 22:31 by rmk") @@ -1385,35 +1387,40 @@ MENUFONT _ DEFAULTFONT))]) (GIT-PULL-REQUESTS - [LAMBDA (ALLINFO INCLUDEDRAFTS PROJECT) (* ; "Edited 8-Aug-2022 13:12 by rmk") + [LAMBDA (INCLUDEDRAFTS PROJECT) (* ; "Edited 30-Apr-2024 14:29 by rmk") + (* ; "Edited 8-Aug-2022 13:12 by rmk") (* ; "Edited 4-Aug-2022 19:01 by rmk") (* ; "Edited 17-Jul-2022 11:12 by rmk") (* ; "Edited 9-May-2022 16:54 by rmk") (* ; "Edited 25-Feb-2022 09:26 by rmk") - (CL:UNLESS (EQ 0 (PROCESS-COMMAND "command -v gh")) + (CL:UNLESS (EQ 0 (PROCESS-COMMAND "command -v gh")) (ERROR "gh must be installed in order to enumerate pull requests:")) - (FOR LINE PR TAB1 TAB2 TAB3 VAL IN (GIT-COMMAND "gh pr list" T NIL PROJECT) - WHEN [AND (SETQ TAB1 (STRPOS " " LINE)) - (SETQ TAB2 (STRPOS " " LINE (ADD1 TAB1))) - (SETQ TAB3 (STRPOS " " LINE (ADD1 TAB2))) - (OR INCLUDEDRAFTS (NEQ 'DRAFT (SUBATOM LINE (ADD1 TAB3] - COLLECT [SETQ PR (IF ALLINFO - THEN (CREATE PULLREQUEST - PRNUMBER _ (SUBATOM LINE 1 (SUB1 TAB1)) - PRDESCRIPTION _ (SUBSTRING LINE (ADD1 TAB1) - (SUB1 TAB2)) - PRNAME _ (SUBSTRING LINE (ADD1 TAB2) - (SUB1 TAB3)) - PRSTATUS _ (SUBATOM LINE (ADD1 TAB3))) - ELSE (CREATE PULLREQUEST - PRNAME _ (SUBSTRING LINE (ADD1 TAB2) - (SUB1 TAB3] - (CL:WHEN (STRPOS ":" (fetch (PULLREQUEST PRNAME) of PR)) - (PRINTOUT T "Ignoring PR for forked repo %%%"" (fetch (PULLREQUEST PRNAME) - of PR) - "%"" T) - (GO $$ITERATE)) - PR]) + (LET [(JPARSE (JSON-PARSE (CAR (GIT-COMMAND + "gh pr list --json number,headRefName,title,isDraft,reviewDecision" + T NIL PROJECT] + (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 + (NOT DRAFT)) + COLLECT [SETQ PR (CREATE PULLREQUEST + PRNUMBER _ (JSON-GET JSOBJ 'number) + PRNAME _ (JSON-GET JSOBJ 'headRefName) + PRDESCRIPTION _ (JSON-GET JSOBJ 'title) + PRSTATUS _ (CL:IF DRAFT + 'D + (CL:IF (STREQUAL "REVIEW_REQUIRED" + (JSON-GET JSOBJ 'reviewDecision)) + " " + 'A))] + (CL:WHEN (STRPOS ":" (fetch (PULLREQUEST PRNAME) of PR)) + (PRINTOUT T "Ignoring PR for forked repo %%%" #" (JSON-GET JSOBJ 'number) + " " + (fetch (PULLREQUEST PRNAME) of PR) + "%"" T) + (GO $$ITERATE)) + PR]) (GIT-SHORT-BRANCH-NAME [LAMBDA (BRANCH) (* ; "Edited 22-May-2022 22:36 by rmk") @@ -1431,18 +1438,20 @@ (FIND B IN (GIT-BRANCHES WHERE PROJECT EXCLUDEMERGED) SUCHTHAT (STRPOS BRANCH B]) (GIT-PRC-BRANCHES - [LAMBDA (DRAFT PROJECT PRS) (* ; "Edited 8-Aug-2022 18:15 by rmk") + [LAMBDA (DRAFT PROJECT PRS) (* ; "Edited 30-Apr-2024 14:20 by rmk") + (* ; "Edited 1-Apr-2024 17:09 by rmk") + (* ; "Edited 8-Aug-2022 18:15 by rmk") (* ; "Edited 4-Aug-2022 18:55 by rmk") (* ; "Edited 9-Jul-2022 19:01 by rmk") (* ; "Edited 16-May-2022 19:44 by rmk") (CL:UNLESS PRS - (SETQ PRS (GIT-PULL-REQUESTS T DRAFT PROJECT))) + (SETQ PRS (GIT-PULL-REQUESTS T PROJECT))) (CL:WHEN PRS (LET ((RELATIONS (GIT-BRANCH-RELATIONS (FOR PR IN PRS COLLECT (GITORIGIN (CADDR PR))) NIL T PROJECT))) - (SORT [FOR PR REL LABEL PRNAME (SUPERSETS _ (CAR RELATIONS)) + (SORT [FOR PR REL LABEL PRNAME STATUS (SUPERSETS _ (CAR RELATIONS)) (EQUALS _ (CADR RELATIONS)) IN PRS - COLLECT (SETQ PRNAME (fetch PRNAME of PR)) + EACHTIME (SETQ PRNAME (fetch PRNAME of PR)) (SETQ LABEL (CONCAT "#" (fetch (PULLREQUEST PRNUMBER) of PR) " " (IF [SETQ REL (CAR (CDR (SASSOC PRNAME SUPERSETS] @@ -1450,13 +1459,15 @@ ELSEIF [SETQ REL (CAR (CDR (SASSOC PRNAME EQUALS] THEN (CONCAT PRNAME " = " REL) ELSE PRNAME))) - (LIST (CL:IF (EQ 'DRAFT (FETCH PRSTATUS OF PR)) - (CONCAT LABEL " (draft)") - LABEL) - (GITORIGIN PRNAME) - (CONCAT " " (FETCH PRDESCRIPTION OF PR) - " #" - (FETCH PRNUMBER OF PR] + (SETQ STATUS (FETCH PRSTATUS OF PR)) + WHEN (SELECTQ DRAFT + (DRAFTS (EQ STATUS 'D)) + (NODRAFTS (NEQ STATUS 'D)) + T) COLLECT (LIST (CONCAT STATUS " " LABEL) + (GITORIGIN PRNAME) + (CONCAT " " STATUS " #" (FETCH PRNUMBER OF PR) + " " + (FETCH PRDESCRIPTION OF PR] T)))]) ) @@ -1538,7 +1549,8 @@ (DEFINEQ (GIT-ADD-WORKTREE - [LAMBDA (BRANCH REMOTEONLY PROJECT) (* ; "Edited 9-May-2022 14:17 by rmk") + [LAMBDA (BRANCH REMOTEONLY PROJECT) (* ; "Edited 2-May-2024 11:25 by mth") + (* ; "Edited 9-May-2022 14:17 by rmk") (SETQ BRANCH (GITORIGIN BRANCH (NOT REMOTEONLY))) (CL:UNLESS (OR (GIT-BRANCH-EXISTS? BRANCH T PROJECT) (GIT-BRANCH-EXISTS? BRANCH T PROJECT)) @@ -1546,15 +1558,15 @@ (CL:WHEN (STRING-EQUAL BRANCH (GIT-WHICH-BRANCH PROJECT)) (ERROR BRANCH "is the current branch")) (LET (LINES LOCALBRANCH) - (SETQ LINES (GIT-COMMAND (IF (EQ 1 (STRPOS "origin/" BRANCH)) - THEN [SETQ LOCALBRANCH (SUBSTRING BRANCH + (SETQ LINES (GIT-COMMAND (if (EQ 1 (STRPOS "origin/" BRANCH)) + then [SETQ LOCALBRANCH (SUBSTRING BRANCH (CONSTANT (ADD1 (NCHARS "origin/" ] (CONCAT "git worktree add --guess-remote " (WORKTREEDIR LOCALBRANCH PROJECT) - " " BRANCH) - ELSE (CONCAT "git worktree add " (WORKTREEDIR BRANCH) - " " BRANCH)) + " %"" BRANCH "%"") + else (CONCAT "git worktree add " (WORKTREEDIR BRANCH) + " %"" BRANCH "%"")) NIL NIL PROJECT)) (CL:UNLESS (STRPOS "Preparing worktree" (CAR LINES) 1 NIL T) @@ -2300,33 +2312,32 @@ (PUTPROPS GITFNS FILETYPE :TCOMPL) (DECLARE%: DONTCOPY - (FILEMAP (NIL (4081 20660 (GIT-CLONEP 4091 . 5419) (GIT-INIT 5421 . 6051) (GIT-MAKE-PROJECT 6053 . -13718) (GIT-GET-PROJECT 13720 . 15645) (GIT-PUT-PROJECT-FIELD 15647 . 17288) (GIT-PROJECT-PATH 17290 - . 18334) (FIND-ANCESTOR-DIRECTORY 18336 . 18685) (GIT-FIND-CLONE 18687 . 19768) (GIT-MAINBRANCH 19770 - . 20165) (GIT-MAINBRANCH? 20167 . 20658)) (26068 28195 (PRC-COMMAND 26078 . 28193)) (28251 31039 ( -ALLSUBDIRS 28261 . 29547) (MEDLEYSUBDIRS 29549 . 30242) (GITSUBDIRS 30244 . 31037)) (31040 35830 ( -TOGIT 31050 . 32456) (FROMGIT 32458 . 33439) (GIT-DELETE-FILE 33441 . 34287) (MYMEDLEY-DELETE-FILES -34289 . 35828)) (35831 38834 (MYMEDLEYSUBDIR 35841 . 36297) (GITSUBDIR 36299 . 36742) (STRIPDIR 36744 - . 37115) (STRIPHOST 37117 . 37357) (STRIPNAME 37359 . 38112) (STRIPWHERE 38114 . 38832)) (38835 40737 - (GFILE4MFILE 38845 . 39208) (MFILE4GFILE 39210 . 39779) (GIT-REPO-FILENAME 39781 . 40735)) (40786 -52616 (GIT-COMMIT 40796 . 41622) (GIT-PUSH 41624 . 42268) (GIT-PULL 42270 . 42882) (GIT-APPROVAL 42884 - . 43233) (GIT-GET-FILE 43235 . 45200) (GIT-FILE-EXISTS? 45202 . 45476) (GIT-REMOTE-UPDATE 45478 . -46202) (GIT-REMOTE-ADD 46204 . 46511) (GIT-FILE-DATE 46513 . 47444) (GIT-FILE-HISTORY 47446 . 49380) ( -GIT-PRINT-FILE-HISTORY 49382 . 50432) (GIT-FETCH 50434 . 50606) (GIT-PR-BRANCHES 50608 . 52614)) ( -52646 63239 (GIT-BRANCH-DIFF 52656 . 58996) (GIT-COMMIT-DIFFS 58998 . 59551) (GIT-BRANCH-RELATIONS -59553 . 63237)) (63284 76387 (GIT-BRANCH-NUM 63294 . 63867) (GIT-CHECKOUT 63869 . 64928) ( -GIT-WHICH-BRANCH 64930 . 65228) (GIT-MAKE-BRANCH 65230 . 67443) (GIT-BRANCHES 67445 . 69713) ( -GIT-BRANCH-EXISTS? 69715 . 70419) (GIT-PICK-BRANCH 70421 . 70911) (GIT-BRANCH-MENU 70913 . 71616) ( -GIT-PULL-REQUESTS 71618 . 73764) (GIT-SHORT-BRANCH-NAME 73766 . 74057) (GIT-LONG-NAME 74059 . 74376) ( -GIT-PRC-BRANCHES 74378 . 76385)) (76417 79752 (GIT-MY-CURRENT-BRANCH 76427 . 76797) (GIT-MY-BRANCHP -76799 . 77304) (GIT-MY-NEXT-BRANCH 77306 . 77800) (GIT-MY-BRANCHES 77802 . 79750)) (79798 83750 ( -GIT-ADD-WORKTREE 79808 . 81292) (GIT-REMOVE-WORKTREE 81294 . 82224) (GIT-LIST-WORKTREES 82226 . 83030) - (WORKTREEDIR 83032 . 83748)) (83798 116000 (GIT-GET-DIFFERENT-FILES 83808 . 90232) ( -GIT-BRANCHES-COMPARE-DIRECTORIES 90234 . 96585) (GIT-WORKING-COMPARE-DIRECTORIES 96587 . 101983) ( -GIT-COMPARE-WORKTREE 101985 . 105963) (GITCDOBJBUTTONFN 105965 . 110455) (GIT-CD-LABELFN 110457 . -111539) (GIT-CD-MENUFN 111541 . 113981) (GIT-WORKING-COMPARE-FILES 113983 . 114603) ( -GIT-BRANCHES-COMPARE-FILES 114605 . 115769) (GIT-PR-COMPARE 115771 . 115998)) (116070 124099 (CDGITDIR - 116080 . 116767) (GIT-COMMAND 116769 . 118327) (GITORIGIN 118329 . 119026) (GIT-INITIALS 119028 . -119332) (GIT-COMMAND-TO-FILE 119334 . 122823) (GIT-RESULT-TO-LINES 122825 . 123432) (STRIPLOCAL 123434 - . 124097))))) + (FILEMAP (NIL (4228 20807 (GIT-CLONEP 4238 . 5566) (GIT-INIT 5568 . 6198) (GIT-MAKE-PROJECT 6200 . +13865) (GIT-GET-PROJECT 13867 . 15792) (GIT-PUT-PROJECT-FIELD 15794 . 17435) (GIT-PROJECT-PATH 17437 + . 18481) (FIND-ANCESTOR-DIRECTORY 18483 . 18832) (GIT-FIND-CLONE 18834 . 19915) (GIT-MAINBRANCH 19917 + . 20312) (GIT-MAINBRANCH? 20314 . 20805)) (26215 28997 (PRC-COMMAND 26225 . 28995)) (29053 31841 ( +ALLSUBDIRS 29063 . 30349) (MEDLEYSUBDIRS 30351 . 31044) (GITSUBDIRS 31046 . 31839)) (31842 36632 ( +TOGIT 31852 . 33258) (FROMGIT 33260 . 34241) (GIT-DELETE-FILE 34243 . 35089) (MYMEDLEY-DELETE-FILES +35091 . 36630)) (36633 39636 (MYMEDLEYSUBDIR 36643 . 37099) (GITSUBDIR 37101 . 37544) (STRIPDIR 37546 + . 37917) (STRIPHOST 37919 . 38159) (STRIPNAME 38161 . 38914) (STRIPWHERE 38916 . 39634)) (39637 41539 + (GFILE4MFILE 39647 . 40010) (MFILE4GFILE 40012 . 40581) (GIT-REPO-FILENAME 40583 . 41537)) (41588 +51839 (GIT-COMMIT 41598 . 42424) (GIT-PUSH 42426 . 43186) (GIT-PULL 43188 . 43940) (GIT-APPROVAL 43942 + . 44291) (GIT-GET-FILE 44293 . 46315) (GIT-FILE-EXISTS? 46317 . 46591) (GIT-REMOTE-UPDATE 46593 . +47317) (GIT-REMOTE-ADD 47319 . 47626) (GIT-FILE-DATE 47628 . 48675) (GIT-FILE-HISTORY 48677 . 50611) ( +GIT-PRINT-FILE-HISTORY 50613 . 51663) (GIT-FETCH 51665 . 51837)) (51869 62642 (GIT-BRANCH-DIFF 51879 + . 58279) (GIT-COMMIT-DIFFS 58281 . 58954) (GIT-BRANCH-RELATIONS 58956 . 62640)) (62687 77220 ( +GIT-BRANCH-NUM 62697 . 63270) (GIT-CHECKOUT 63272 . 64447) (GIT-WHICH-BRANCH 64449 . 64747) ( +GIT-MAKE-BRANCH 64749 . 67078) (GIT-BRANCHES 67080 . 69570) (GIT-BRANCH-EXISTS? 69572 . 70443) ( +GIT-PICK-BRANCH 70445 . 70935) (GIT-BRANCH-MENU 70937 . 71640) (GIT-PULL-REQUESTS 71642 . 74194) ( +GIT-SHORT-BRANCH-NAME 74196 . 74487) (GIT-LONG-NAME 74489 . 74806) (GIT-PRC-BRANCHES 74808 . 77218)) ( +77250 80585 (GIT-MY-CURRENT-BRANCH 77260 . 77630) (GIT-MY-BRANCHP 77632 . 78137) (GIT-MY-NEXT-BRANCH +78139 . 78633) (GIT-MY-BRANCHES 78635 . 80583)) (80631 84706 (GIT-ADD-WORKTREE 80641 . 82248) ( +GIT-REMOVE-WORKTREE 82250 . 83180) (GIT-LIST-WORKTREES 83182 . 83986) (WORKTREEDIR 83988 . 84704)) ( +84754 116956 (GIT-GET-DIFFERENT-FILES 84764 . 91188) (GIT-BRANCHES-COMPARE-DIRECTORIES 91190 . 97541) +(GIT-WORKING-COMPARE-DIRECTORIES 97543 . 102939) (GIT-COMPARE-WORKTREE 102941 . 106919) ( +GITCDOBJBUTTONFN 106921 . 111411) (GIT-CD-LABELFN 111413 . 112495) (GIT-CD-MENUFN 112497 . 114937) ( +GIT-WORKING-COMPARE-FILES 114939 . 115559) (GIT-BRANCHES-COMPARE-FILES 115561 . 116725) ( +GIT-PR-COMPARE 116727 . 116954)) (117026 125055 (CDGITDIR 117036 . 117723) (GIT-COMMAND 117725 . +119283) (GITORIGIN 119285 . 119982) (GIT-INITIALS 119984 . 120288) (GIT-COMMAND-TO-FILE 120290 . +123779) (GIT-RESULT-TO-LINES 123781 . 124388) (STRIPLOCAL 124390 . 125053))))) STOP diff --git a/lispusers/GITFNS.LCOM b/lispusers/GITFNS.LCOM index 125b93aea79c050d47f0af79ee7a79de4710c9ce..690a76e4a1c212bfd1f2a2531eeff0016342626a 100644 GIT binary patch delta 4522 zcmZ`-Yls`y6<*19YAf08zPxtViG4jz9B*u`HKVuk(ny+J&8{?~j3lq^I^Jk^wJUXH z?N-v-c@RWNN+FbxXYpsl7- z-X+soELfUGsyOdl5xexCadviAB5S1}GvO}H!(?>Tjb#B!E)K{tze;dIIG^Qzko8wG)w-xrf* ziFo?M?(h80b$QB_qSDbP7S=X~@bB(B_Vew%%F56l*X`c_|HoF`dx=AAqAI3W?j}6+ z#iPG!`{kgp*7Cy6oN8%Ai3CZ$VCBp_Q9_}vsK^9%W;LTo6gk8v*=VtKGD(_7QY{e0 zCzFh3%oox`jsyrFmcx-ROp(LNqBBPhDcw0i=Saz(BW1s>M0mWG_Eb^J7xI9CkFPqX z6_RN>GCkK;lrYIv>)CRBhsaU6Co3Uhm?=x0W7A~0_Y#fv$z45(_=){>Sazh4tpj3- zAO4VxEwZ&;u9NMZS`9h)&7Je*W~&L9`$E8RS1XiqDEtLw=eN_R$6aUXopZ-dZ?X8? z%l@mZsrRwx=+K#fFpyzTHB#7>&UiypSm+@M+u#Tr)fP5tR>(sV-Sj@9K7x5}mB)I; z&6kYdJ}BP5bOV2sd$7BKOh5DnkHA}e2U&4;fPvUyV)hevFiQVByTKl>{v<@-K7W{r zx6WU4{h1Qq>{s|M!w0D8d#4RQYnEkN2t|-snxSSjmTiDVnB=trlXYXxBy!j<;@Bl4 zIT#{WvKKOXzCh$4@TBK+?DN8<9H!&YDJ>(G!cmi%STbYgF(3zevwYDkU)0Hb)#n2+ zaS$`786*-V`AhkNmi1~E3z}u9nK{$S0=>Zjhk!{qL6D$Ae=SSLBS1MLD%~_VX)*-H z)P!l_n7#mYDHH2}e9T$XYcCp(l9+Dfz?)%=rgTe7vLzUh6km`?APvIJF-!<%(MU-o zV8;LukYWirP^K446g& z-Hi2%e73Zlu$BdiD1JLRXFP_U!ASxCFFmLdB>$enV%PM^G2bG^=G31Y9=I&xAuHyQmh-EThSMF#&|> z#yrT;X%hfZyLUhsg#?mA<;$2!hE*TRK-Mg1jQM~!saW5vZ{4VKtQ=iM3l{*i&ZD#e z9JQ_0QVnvT^Ww$(+CKqo9~%mvUZWFOIuWTu$X zL?xdgt|wuwoBreSiMFV)E^htUm@DnFo2T#XrQN$zqDy)`{R($yS|F`-aADu={fncn zt9+O%#fQryd+{HeBX8Us+B14%ec}gwvTlyNxv|8syL*Z+-#5nB{65#d%onOmv}IJ)7=;FsDLEu16T4u(|4|T+X~u%`p&f#(20y3Q_)5Q(1l&EmT#oW ztJP)|7bqDtn&Mp3sjN09Og+7t6l^&PMq@-5LX~4pzqYi@+=Akd z>W-sIMFV|+IdABfaqr1lN!I0{{98ybWF6yE%-pDu?FOlVc~M)x(S%LH=5u{!oa4rw zs~#4|J~!xu&SOvCa2;Y5LoF2ZgzjFw?g@^fuqJ+5RXtQ*R^2asmEL@;esTHuUc7s; zFpmpxSMI(lgdaMZj&2?ofSl&6V&2cwNT}?QDVKPia=V7_p<~ZH&?e^O>E-dg-G2di z==YqW?7SMzx@iBR^mC`h)Jp^x#n-NxBh6ids{ zpFMMMm{)XruL%9@@xwI*$W5V>_VsQ7?EV7G;Pzni2J6yT^TPs-%ZbFJ%z785VBHV? zWYk-UJkBJ>UE~QSpqic=_L5aE=1x(YWW`U%HYO)M=%<~=3I5@Oo!JdfYClUv8h&@d?IE3)-tFwCbGzrp zovMkJN&H^mp)c>|xq2zB<5vay#>{>>$Z<8hYxgd5^tGpt(3P7p<|UNA&duBreuro4 z4&1Okboy56u$08_B&9|b8PSwxoa=t`R+Qd+pJ4tUZYAkhXPS;}P0@HKOf&Bu951%2 hwQ8$c?wjy>Cr;(mB>lKEj!B<(THLtK=6f%U{14pdSh4^B delta 4068 zcmeHKUu;`v6_1@pv~CiTEKQp<*-me^G%2%tzkBWLKWnqx*w=|0-+NvEN&nC;OJX-R zaqQG~nsw7;?P2QBDlzy3lK}C6geFEoNu4|(Hl;{=0K~&4CNYE%2&oLzmm$z3q@i-Y z@7hkPOyY${63O>`|IR(%IluEe=RUmE`j=N*-?&gElG7;Oa7v;igCqtdcR&;c7!?+a zE33JDCJn^`2=G!UG4t}7Y;h$so}Vw3ZjR^j<13kTK67(CpDVAfl{2OC_*5hrHWIF9 z$QU>TLU#3v-hk{4h;9KEnA-fwG~`fgI2DanVedwl%Oya1zJjm)JOzp{<`@k}qFOMn zsYxw_h7qT^Sh1`p{(vk8Bn7R#plhM1cIo9a`;Bw^{6Hi(Q4|Php-469oV*03m1PJ7 zr&VK0OE{Azj5_clfcJ6g>Wt=$#m#eCFgXT+SX`Tpn5l#_gzw+?ddVAbOaJZlzA*<= z9E_TV7E^1#uk7Z zpsB~yxCWA2ghVnPGZP?5q#+Wo0%|CvYeou)m+(WAan%S;JFPjqe$X_6Y7&S?fv9Fo zC8vSNez2BhdH)f~d%k&wc$;TP!=#|odV`h#e|-)E?2K#YQ(7XK0H4HlhP7mH8Wb%@f>uZ^ErHrwcr2UhM z1f!w28cqWLO^nrs21k0%j-VUu6Wb1zJ9ME%<$mTKpWtFPt+q2?ceRYl9&RXlSXYe@ z+CX1*DeY*$Qm%qFl(RrTaGkO}ML%;5oY;5R{pewZo;mI5AZV#|8gD>fJN>a;^3m(! z5_|mkhYIZ?N0@k$tk~YC-y|+uJN*@Tt15axi^t745JYWUGgMt;@W&xWT1zrHVuVc~ z=uQSIHeo@Nctp6O&qgB&jIi4SD8$%m@=^?sV|YVa)KVph5R3*8jtN{4eY>Ybd59~W z(k#WQD2fEo5HqG3;FD>Ge9R`(_qUGN-3mP`3stWNcxFaSgXae!ZV0H8W;_Xg-#%Ru zczu|I7n54tP@~SU8P^exUKs)rBbG{nf~%oO91{=qF)$Fn9|XK6aKjA~1v6!Y1i%y! z0s_#F<&N5?^0vJrWNT?Tz=Nx96Z%W#bagkkHh$eQs<<0S_DFRP%N9DDL2vFLer|bO zi<#WNEC^!`BN9c6JZKO&o%n;W{an*n;BmFK=KZX#8`HL#B7u<4F-n)`ZXE9TVoOWw zS6j|PPLaisq6Vdb%~+zlkb`XyQaTl4w!=+z>Ziw+1dDK%cz90uV=nQI5C*<$W+8Y@+XZ2fNHIO9RWvwe_=8hv>a<@1Zf= z;$~by?}vT#i79RPIQq7g`)-2&TDhN1Pc}F}a?=rIn7%XhMC}h#SK4ev8qgyLN3A0c z`iB1GDbdQg24WDLbwBwmtTz^XBK@OYe%!sw00MaHqs44yak;owf!d2kx6O8#-ZqDA zx9NtdAAG&>E=O#}mZY;W9UY3f5{pMbLe9pgL6H94Fs(&nAR&M)u8=UJu_7Sts!??1 zZlI7P8j(cUH@6V??mYUH7pFS)5k?MH@bP+7IKLJ^HyfFCSSZaG7PC+&R$#G|VHF$0 zCSxp8h0F`9nMGE@8R3;O<+XeT*N{a&INv*f$4|n19*?ANLgs}W61huoAo$$$;rXF+ zjOEt~=}ZZqgoW%RK4nBfVm((uXQiQ1gn20JTEI3S&2V;YdegZ8^m_a~+cH%We?ET8 zPTl8^xC|Lytj|Jl?3{E77~ZerURN`#_}2_6}c&a)>x1_29Akz>J~>Jkl684rezWOLOhbwQL$0 zec)Ygi*C2u_&e@C&Br-D*wN|jFAr9~s{icVcIQlX;PR!NY5T>^hkY|6mp48|y2ldL zBn{?6i!{WBB>5W>qj9T`B!1-a)Fh4~#uT=XUN&Ok=Y7VW6%Rs%@00jO)`>PYVuRR_ zvGms!GfmbjJU$xB9iz9e4ED1wj>nPL09Hqz!ip(LGWA>)oGb^tyt*T+3Wo&N6|e^q z7<;ffu#|<>5@4rasXe&5Zli^{^8afpHo*VenyO!N22=5xxbUx5+fV4JYZqNZ6ZwN2 zgFoeXj7;(Ym%qk;_fk|lefOG+eZJKDSuEuZw7DN8OxBz>%9JG0p`~rR;-()i4NqX5 z5@MwcvS+Ta1nb4pa;22XAh}4mzzPOy8yLqnmS8@OACfqa>;rD%?Et-Bdlq%xtM#_A1~@@CztcyPTV9-deXF1TV2jm>`&%Ql NeY;Y7b^FE6{{U7p1r-1Q diff --git a/lispusers/GITFNS.TEDIT b/lispusers/GITFNS.TEDIT index be64fa8441f4e00995d7417e0f1c141ea52922ae..36f132d8fc020d20f12a41b17fc9f7e4df99d55f 100644 GIT binary patch delta 4647 zcmZu#&re)c6n<}tP^OHul$KU&`yix0(n_LHEMOGOP>U&G024J$8k9kZ%?vVA(MEl` zHg0^YChlr-5XQ8zBT5YP9$cfOf7(lM028XYo#kGaS`PG%>#kr+mJoPB}UnLv# zVsbcpf)KNy5R{T|=1jlOj&#q4+%{nTeF*AH&d!YYb7%w%iG7CLo`jP}A%*8U0UDW) z5x|4vLl(8t=?Ybnxl6F$h5Q-BnG;q7J_@v_FoU2c>|sgTEj_RRkif59$Qefv-*1yw z09d}DEZD&GCmbRyhCVb&{&Yrjx)g^`S5qs#Ya4J03S5oYCEb(oR z7DAe~X!Jm51=xxR-|=v2`tHCo>=spvR`|ipmk>q+o`eZAE#^vE!DQ}@6N5Sdsao<; zc{nCLh$sk-)Mx{wjTK+Q5SC{!@FZc;rkr$(vQ??NSeOM^;G5i?FP7RVFDE~}elkW5 zqT(S2GH4GI5rPYZ2$RN(0}%4uaAu3Zgk=LDVjW^8fLFF4+f{18TjvjbNqUl!&6rVM zF~0~G%oHuHG&+f9Pv;kR79n8N;*L6^ShbW8G8Rw!gWVGXH+Cqg-C zamSrVHD+;W&l+RFU06tHz2u1RI)f2II=Bq*Kmbx@Yn@TboqYvgB{A>5idI)^F%#}{ z8Uu*38?)47&Lp8yk_XOL5d~)*BHpVxMBAogqhk2dDVJ$dG6F9zh9JfNOtI0|1N$c!)U zixBXsYn^7=ec=}8u24n0Lhu5d;ixNA72p<>AZ#koMUYX)dAtjRYjj>Bt-Z!T;M0IA$|~P)2Pj5$xIXbjK@` zxQrpp2+XZq!TgPbi>fSyyN^hFY&W4mo(#$pvJIF?rmeo{-bW!k_@GmxNmE(8Yvv#{ z{nqw#ClIE3i-;NEHEIvj)wZdtb=~NfMm$u_C6qO&=_{jjSHPbwRV^zXb`N-@uJQ`e zwWXY|gA!30aj3?!`ln69(!oVR63=Bra~2~ZN$ZD(2nwUSgz|_Uw};8FTrr>}hjb8C zFRgskeN<%~aryA~5<)~EzvxlE2nA*9wEAoRH~{{mM;*fe$k$!SoFmRmLWrvxvz;#a zs}TW3^k4hd1iEm*i;O_Y*DMBHS!yXf1VD4PA%8f)Zbz_|tM3J7hoJOmKwkwQ7t#{K zMd9_KJ=99WY%=MHCpzJPT-0W|r}Ym}_esBI$gEEWH96y<&V4|3B4QnK$je>w{9S~P z?gcIoi=!51=|3Q#K~*k1t!8+^z+8Ftaigk?wYvbl2!LiI!QZa}fRHaZNF3p{%>LJX zAz~$Z&Al0q^mLnh<9*{Uw17g}CqySh2&KZ{Ed=ulD5#`P{I?VH8x8>v9C4R_36$s7 U=BGb+c>fFgPl^5Tzq`Nv4`?~2r2qf` delta 4518 zcmZ{n&2JTD6vk(6Yrm8t+R|dt-jb#*sUctlYAe_pilDaDD+@Jj2vlRNEfLhj#Eg4` z3ui@i=fb5VUFpAI+_`e;&cKR4!1(^2d(Xq2J4!Oscb@Z{=X|_p-nsmFH~;Q#e(!#N zqdBtwu>Zip{o%3gzH)D3X6~ci>pP#_*lynV^x6lvn{Tz|Z#A#oYJRc3v%}xLo7=n1 zz1{8onaR27e02ZP*&p*fFCQ!|mOn2I?cZNIlpmhVMy_1mSbwLrwXwFD&1U-7C`XrX z507O78(SCFTbt#b<%#m!<*PFo8`)^O53tPBHN>Ki8@mMsk6n9QsoltzPOA0R$!cy@vdq6$y*{&{KeJ zUA3kd z_X#LOu>1dWT>|}$|tnAkx1r_W%6$*0lOwk|= zmG{n#7vyNA)9FDr)2;3E&Iyr6#oOHHkU`W1J{gEPooP(HFf<*cN(lC2H7wF0c~wXV z>G0%t)_UehkEf^8rNrFlLLE{AQaQxB92|8Mud{)~M0ii72gRM&E`jXzIyrTX91)Qz zRLOdf?d~_g)tm^<5f+5dq;{w75bmU8;4a}*>DPH7%%WT9ee*lzW<=>~Wp~UbGDN6Z zG%;A-gMyD`eY8yxzgmpl++}ap*O0q|*J94X_|I(gO~cpvsalPpN*)j+%>ijKRBi0J-dCq2Bk^eu#J=*6HPPi7V9jo0|%<-S@6RK?A( z;AudkMCM$AeAM_OVZi3J zZW|#TRoKggdaJbH_ER_=Vgd3^4Ot5$gr&!=>2|F4a@t2=dGh>t8kF{t?_&gjQ0fyp z@|ITH()goS?ymqe$dv2qv^U6kem(V|nKsE=B8ZqOf~Sum@np9%fkdJw0x-o><>S}? zJ2j^>t*L(h67T@apXlm4(JiD6tspPg!s~Mf$FIB!#8t7n-HX)I^iQ&BnI7_a064KV z{>>tgypCZE3V#;>)V(AD@CpD67hDFS(-tl#K_QZ)fSl;XV9THMI)^lPdt&Yc#ezxz yEhFtWp&L;s-6XS-HQdq=eh|X?X@=-;fdu8DfD3C^)|WqgVJSON.;31 9030 + + :EDIT-BY rmk + + :CHANGES-TO (FNS JSON-STRING JSON-GET JSON-VALUE JSON-ARRAY JSON-OBJECT JSON-AVPAIR JSON-NUMBER + JSON-ATOM JSSKIP JSON-SKIP JSON-PARSE) + (VARS JSONCOMS) + (MACROS JSBIN JSPEEK JSBINC JSPEEKC) + + :PREVIOUS-DATE "30-Apr-2024 00:54:21" {WMEDLEY}JSON.;9) + + +(PRETTYCOMPRINT JSONCOMS) + +(RPAQQ JSONCOMS ((FNS JSON-PARSE JSON-VALUE JSON-SKIP JSON-STRING JSON-ARRAY JSON-OBJECT JSON-AVPAIR + JSON-NUMBER JSON-ATOM JSON-GET) + (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS JSBIN JSPEEK JSBINC JSPEEKC)))) +(DEFINEQ + +(JSON-PARSE + [LAMBDA (JSONSTRING) (* ; "Edited 30-Apr-2024 08:45 by rmk") + + (* ;; "Parses a JSONSTRING into a list structure. Arrays are heading with the atom ARRAY, attribute-value lists are headed by OBJECT, each then followed by elements. ") + + (JSON-VALUE (CONCAT JSONSTRING]) + +(JSON-VALUE + [LAMBDA (STR) (* ; "Edited 30-Apr-2024 13:48 by rmk") + (SELCHARQ (JSON-SKIP STR) + (%[ (JSON-ARRAY STR)) + ({ (JSON-OBJECT STR)) + (%" (JSON-STRING STR)) + ((t f n) + (JSON-ATOM STR)) + (NIL NIL) + (JSON-NUMBER STR]) + +(JSON-SKIP + [LAMBDA (STR) (* ; "Edited 30-Apr-2024 08:56 by rmk") + (bind C while (MEMB (SETQ C (JSPEEK STR)) + (CHARCODE (SPACE CR LF TAB))) do (JSBIN STR) finally (RETURN C]) + +(JSON-STRING + [LAMBDA (STR) (* ; "Edited 30-Apr-2024 14:39 by rmk") + (CL:WHEN (EQ (CHARCODE %") + (JSON-SKIP STR)) + (JSBIN STR) + (CONCATCODES (bind C eachtime (SETQ C (JSBIN STR)) until (EQ C (CHARCODE %")) + collect (CL:WHEN (EQ C (CHARCODE \)) + (SETQ C (JSBIN STR)) + (CL:UNLESS + (MEMB C (CHARCODE (%" \ / BACKSPACE FORM LF CR TAB u))) + + (* ;; "Not checking for Hex digits after u.") + + (ERROR "UNEXPECTED \ ESCAPE IN JSON STRING" STR))) + C)))]) + +(JSON-ARRAY + [LAMBDA (STR) (* ; "Edited 30-Apr-2024 13:43 by rmk") + (CL:WHEN (EQ (CHARCODE %[) + (JSON-SKIP STR)) + (JSBIN STR) + [CONS 'ARRAY (if (EQ (CHARCODE %]) + (JSON-SKIP STR)) + then (JSBIN STR) (* ; "empty") + NIL + else (collect (JSON-VALUE STR) repeatuntil (SELCHARQ (JSON-SKIP STR) + (%, (JSBIN STR) + NIL) + (%] (JSBIN STR) + T) + (ERROR + "NOT A VALID JSON ARRAY" + STR])]) + +(JSON-OBJECT + [LAMBDA (STR) (* ; "Edited 30-Apr-2024 13:41 by rmk") + + (* ;; "Returns NIL if STR does not start with { and thus does not indicate a JSON object, a list of attribute value pairs enclosed in { }. The attributes are strings separated from the values by :. The pairs are separated by commas. We return atomic attributes.") + + (* ;; "The empty") + + (CL:WHEN (EQ (CHARCODE {) + (JSON-SKIP STR)) + (JSBIN STR) + [CONS 'OBJECT (if (EQ (CHARCODE }) + (JSON-SKIP STR)) + then (JSBIN STR) (* ; "empty") + NIL + else (collect (JSON-AVPAIR STR) repeatuntil (SELCHARQ (JSON-SKIP STR) + (%, (JSBIN STR) + NIL) + (} (JSBIN STR) + T) + (ERROR + "NOT A VALID JSON OBJECT" + STR])]) + +(JSON-AVPAIR + [LAMBDA (STR) (* ; "Edited 30-Apr-2024 13:31 by rmk") + (LET (A V) + (JSON-SKIP STR) + (SETQ A (MKATOM (JSON-STRING STR))) + (CL:UNLESS (EQ (CHARCODE %:) + (JSON-SKIP STR)) + (ERROR (ERROR "NOT A VALID JSON OBJECT" STR))) + (JSBIN STR) + (SETQ V (JSON-VALUE STR)) + (LIST A V]) + +(JSON-NUMBER + [LAMBDA (STR) (* ; "Edited 30-Apr-2024 13:31 by rmk") + + (* ;; "Collect the characters in reverse") + + (JSON-SKIP STR) + (LET ([SIGN (CAR (MEMB (JSPEEKC STR) + '(+ -] + VAL) + (CL:WHEN SIGN + (JSBIN STR) + (PUSH VAL SIGN)) + (CL:WHEN (FIXP (JSPEEKC STR)) + (bind C eachtime (SETQ C (JSPEEKC STR)) while (FIXP C) do (PUSH VAL C) + (JSBIN STR)) + (CL:WHEN (EQ (CHARCODE %.) + (JSPEEK STR)) + (JSBIN STR) + (PUSH VAL '%.) + (bind C eachtime (SETQ C (JSPEEK STR)) while (FIXP C) do (PUSH VAL C) + (JSBIN STR))) + (CL:WHEN (MEMB (JSPEEK STR) + (CHARCODE (E e))) + (JSBIN STR) + (PUSH VAL 'E) + (CL:WHEN [SETQ SIGN (MEMB (JSPEEK STR) + '(+ -] + (JSBIN STR) + (PUSH VAL SIGN)) + (bind C eachtime (SETQ C (JSPEEK STR)) while (FIXP C) do (PUSH VAL C) + (JSBIN STR))) + (PACK (DREVERSE VAL)))]) + +(JSON-ATOM + [LAMBDA (STR) (* ; "Edited 30-Apr-2024 13:31 by rmk") + (JSON-SKIP STR) + (SELCHARQ (JSPEEK STR) + (t (JSBIN STR) + (if (AND (EQ (CHARCODE r) + (JSBIN STR)) + (EQ (CHARCODE u) + (JSBIN STR)) + (EQ (CHARCODE e) + (JSBIN STR))) + then 'true + else (ERROR "INVALID JSON STRING" STR))) + (f (JSBIN STR) + (if (AND (EQ (CHARCODE a) + (JSBIN STR)) + (EQ (CHARCODE l) + (JSBIN STR)) + (EQ (CHARCODE s) + (JSBIN STR)) + (EQ (CHARCODE e) + (JSBIN STR))) + then 'false + else (ERROR "INVALID JSON STRING" STR))) + (n (JSBIN STR) + (if (AND (EQ (CHARCODE u) + (JSBIN STR)) + (EQ (CHARCODE l) + (JSBIN STR)) + (EQ (CHARCODE l) + (JSBIN STR))) + then 'null + else (ERROR "INVALID JSON STRING" STR))) + NIL]) + +(JSON-GET + [LAMBDA (OBJECT ATTRIBUTE) (* ; "Edited 30-Apr-2024 14:26 by rmk") + + (* ;; "Returns the value of ATTRIBUTE in OBJECT") + + (CADR (ASSOC ATTRIBUTE OBJECT]) +) +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(PUTPROPS JSBIN MACRO (= . GNCCODE)) + +(PUTPROPS JSPEEK MACRO (= . CHCON1)) + +(PUTPROPS JSBINC MACRO ((STR) + (CHARACTER (JSBIN STR)))) + +(PUTPROPS JSPEEKC MACRO ((STR) + (CHARACTER (JSPEEK STR)))) +) +) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (778 8671 (JSON-PARSE 788 . 1134) (JSON-VALUE 1136 . 1505) (JSON-SKIP 1507 . 1781) ( +JSON-STRING 1783 . 2581) (JSON-ARRAY 2583 . 3721) (JSON-OBJECT 3723 . 5180) (JSON-AVPAIR 5182 . 5624) +(JSON-NUMBER 5626 . 7140) (JSON-ATOM 7142 . 8449) (JSON-GET 8451 . 8669))))) +STOP diff --git a/lispusers/JSON.LCOM b/lispusers/JSON.LCOM new file mode 100644 index 0000000000000000000000000000000000000000..34793e69b9ee605475fd4642d82bce32e82d725b GIT binary patch literal 3639 zcmcInO>Y}z5Oz`|R7*%sD{+XR9aa?90!RDqu0Q!u*6TO%Cibqo-h`MGp%%L&>b8xX z1R+(uAjE+?q9CNI5*H3gsYxZ;13vKs_z{Tf{(~~_hj-V(jjBpq?DuotnP+C6nN=Hf z#c^q2#c9!kw50edj`ovc1nsyYMNFv3& z?X|l&Z(FwSv6Z^x;%|r2buqE!%+5ot#O#VWLEyABnwn+O|`FJTgbYUn@=%vPx8C5TdO`L;3j_O+K{zl2J3d{OAI zuzW@gw)?nxZ`?d5oYoJoM58w)-rM~|(_hDYyv)@euRn1fon6~m?EQZ9WbLiTM~@KR z3Q*tod?*!#>O~{A#;8i)GuyhL7vmjLiiiKj70Nm&8!p}IVCo;v)tquhq>YmHc zMW#@oq#-IMRCO@R2pK_uG=@o;{)*T}_Dl!2fuh7@7JQ*KL)!&>y)`Baeb zJsDBrM6c=WEV8)4Xy;Cnv}(oygTXK2$<*aQmn0{G136`#(;c#ih%8ZQD@mM9c*ZEr z2$5-osP4S2+szd0|ChD*^1qyV13C?vkY4)4l?$)lqWPMjChAhX&Sdigh2$!K4rXsU!|3 zSkri!AXv>rp#V}O@goH5n%Fn6DDXmpDb_LWDQn!Z9BPz>RB`@*lJ;6$U zAy-eORX;q4MzyKj35U_>H5n&|(S11@MBnj9$))lRdyMPRh)&_)iTT)thm|PCy%i%07Fj%ybOkz?=)yr~fTuMa(!Z`^oViqSiv2Bl6G3n#+wBsks zl~fs;Fi0wz%p|a|L7H5edSVh4smg`UB~=q{9fl#g)`06*!~FrP*aySI0rR}BY3v&% zRf;BMonYTEdk4dP=7tOt){Dz1!MYb9%hflq@nsE}q*R5qn5 z_R2xf!|u9+y@hDld8?gO{f>3{G7n<504o0w;5;h&;uI+hc8!~N*`M*%)4vHs`JM4m rfZs)E6*l}0YPT$(;>Qw2$d;L+_{9bd&kby^(|fKjf_xU6B4+Tvur5Jh literal 0 HcmV?d00001