(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)


(FILECREATED "19-May-2022 19:19:14" 
{DSK}<users>kaplan>local>medley3.5>working-medley>lispusers>GITFNS.;296
 97537  

      :CHANGES-TO (FNS GIT-MY-CURRENT-BRANCH GIT-MAKE-BRANCH GIT-NEXT-WORKING-BRANCH GIT-BRANCH-NUM 
                       GIT-MY-BRANCHP GIT-MY-BRANCHES)
                  (VARS GITFNSCOMS)
                  (COMMANDS cob)

      :PREVIOUS-DATE "19-May-2022 14:08:39" 
{DSK}<users>kaplan>local>medley3.5>working-medley>lispusers>GITFNS.;295)


(PRETTYCOMPRINT GITFNSCOMS)

(RPAQQ GITFNSCOMS

       (
        (* ;; "Set up")


        (FILES (SYSLOAD FROM LISPUSERS)
               COMPAREDIRECTORIES COMPARESOURCES COMPARETEXT PSEUDOHOSTS)
        
        (* ;; "")


        
        (* ;; "GIT projects")


        (COMS (FNS GIT-CLONEP GIT-MAKE-PROJECT GIT-GET-PROJECT GIT-PROJECT-PATH 
                   FIND-ANCESTOR-DIRECTORY GIT-FIND-CLONE GIT-MAINBRANCH GIT-MAINBRANCH?)
              (RECORDS GIT-PROJECT)
              (INITVARS (GIT-DEFAULT-PROJECT 'MEDLEY)
                     (GIT-PROJECTS NIL)))
        (P (GIT-MAKE-PROJECT 'MEDLEY T T '(EXPORTS.ALL RDSYS RDSYS.LCOM loadups/ patches/ tmp/ 
                                                 fontsold/ clos/ cltl2/)
                  '(greetfiles scripts sources library lispusers))
           (GIT-MAKE-PROJECT 'NOTECARDS T T '(online/))
           (GIT-MAKE-PROJECT 'LOOPS T T))
        
        (* ;; "")


        
        (* ;; "Lisp exec commands")


        (INITVARS (GIT-MERGE-COMPARES T))
        (COMMANDS gwc bbc prc cob b? cdg cdw)
        
        (* ;; "")


        
        (* ;; "File correspondents")


        (FNS ALLSUBDIRS MEDLEYSUBDIRS GITSUBDIRS)
        (FNS TOGIT FROMGIT GIT-DELETE-FILE MYMEDLEY-DELETE-FILES)
        (FNS MYMEDLEYSUBDIR GITSUBDIR STRIPDIR STRIPHOST STRIPNAME STRIPWHERE)
        (FNS GFILE4MFILE MFILE4GFILE GIT-REPO-FILENAME)
        
        (* ;; "")


        
        (* ;; "Git commands")


        (FNS GIT-COMMIT GIT-PUSH GIT-PULL GIT-APPROVAL GIT-GET-FILE GIT-FILE-EXISTS? 
             GIT-REMOTE-UPDATE GIT-REMOTE-ADD GIT-FILE-DATE)
        
        (* ;; "Differences")


        (FNS GIT-BRANCH-DIFF GIT-COMMIT-DIFFS GIT-BRANCH-RELATIONS)
        
        (* ;; "")


        
        (* ;; "Branches")


        (FNS GIT-BRANCH-NUM GIT-CHECKOUT GIT-WHICH-BRANCH GIT-MAKE-BRANCH GIT-BRANCHES 
             GIT-BRANCH-EXISTS? GIT-PICK-BRANCH GIT-PRC-MENU GIT-PULL-REQUESTS)
        
        (* ;; "My branches")


        (FNS GIT-MY-CURRENT-BRANCH GIT-MY-BRANCHP GIT-MY-NEXT-BRANCH GIT-MY-BRANCHES)
        
        (* ;; "")


        
        (* ;; "Worktrees")


        (FNS GIT-ADD-WORKTREE GIT-REMOVE-WORKTREE GIT-LIST-WORKTREES WORKTREEDIR)
        
        (* ;; "")


        
        (* ;; "Comparisons")


        (FNS GIT-GET-DIFFERENT-FILES GIT-COMPARE-BRANCHES GIT-COMPARE-WITH-WORKINGMEDLEY 
             GIT-COMPARE-WORKTREE GITCDOBJBUTTONFN GIT-CD-LABELFN GIT-CD-MENUFN)
        (INITVARS (FROMGITN 0))
        
        (* ;; "")


        
        (* ;; "Utilities")


        (FNS CDGITDIR GIT-COMMAND GITORIGIN GIT-INITIALS)
        (PROPS (GITFNS FILETYPE))))



(* ;; "Set up")



(FILESLOAD (SYSLOAD FROM LISPUSERS)
       COMPAREDIRECTORIES COMPARESOURCES COMPARETEXT PSEUDOHOSTS)



(* ;; "")





(* ;; "GIT projects")


(DEFINEQ

(GIT-CLONEP

  [LAMBDA (HOST/DIR NOERROR CHECKANCESTORS)
                  (* ; "Edited 12-May-2022 11:44 by rmk")


                                                             (* ; "Edited  8-May-2022 16:24 by rmk")


    (* ;; "If CHECKANCESTORS, looks back up the directory chain to see if perhaps the .git is somewhere higher up.")


    (IF
 [AND HOST/DIR (LET ((D (SLASHIT (TRUEFILENAME (PACKFILENAME.STRING 'BODY HOST/DIR
                                                             'HOST
                                                             'DSK))
                                      T)))
                           (IF
 (DIRECTORYNAMEP (CONCAT D "/.git/"))
                               THEN
 D
                             ELSEIF
 (AND CHECKANCESTORS (FIND-ANCESTOR-DIRECTORY

                                                         D
                                                         (FUNCTION (LAMBDA (A)
                                                                     (DIRECTORYNAMEP (CONCAT A 
                                                                                            ".git/"]
      ELSEIF
 NOERROR
        THEN
 NIL
      ELSE
 (ERROR "NOT A GIT CLONE" HOST/DIR])

(GIT-MAKE-PROJECT

  [LAMBDA (PROJECTNAME PROJECTPATH WORKINGPATH EXCLUSIONS DEFAULTSUBDIRS)

                                                             (* ; "Edited 17-May-2022 17:08 by rmk")


                                                             (* ; "Edited 13-May-2022 10:40 by rmk")


                                                             (* ; "Edited 12-May-2022 00:26 by rmk")


                                                             (* ; "Edited  9-May-2022 16:20 by rmk")


    (* ;; "PROJECTPATH must resolve to a git clone.")


    (* ;; "Search sequence for PROJECTPATH, if T or NIL")


    (* ;; "    (UNIX-GETENV PROJECTNAME)")


    (* ;; "    (UNIX-GETENV (CONCAT PROJECTNAME DIR)")


    (* ;; "    git-PROJECTNAME sister of MEDLEYDIR ")


    (* ;; "If not found, error if NIL, return NIL if T  ")


    (* ;; "")


    (* ;; "WORKINGPATH T or NIL means try to find a parallel to the projectpath, T means don't cause an error if not found. ")


    (SETQ PROJECTNAME (U-CASE PROJECTNAME))
    (CL:WHEN (MEMB PROJECTPATH '(NIL T))
        [SETQ PROJECTPATH (OR (GIT-CLONEP
 (UNIX-GETENV PROJECTNAME)
                                     T)
                              (GIT-CLONEP
 (UNIX-GETENV (PACK* PROJECTNAME 'DIR))
                                     T)
                              (GIT-CLONEP
 (DIRECTORYNAME (CONCAT MEDLEYDIR "../git-" (L-CASE 
                                                                                          PROJECTNAME
                                                                                            )
                                                                "/"))
                                     T)
                              (AND (NULL PROJECTPATH)
                                   (ERROR (CONCAT "Can't a find clone directory for " PROJECTNAME])
    (CL:WHEN PROJECTPATH
        (LET (CLONEPATH GITIGNORE PROJECT GITPATH WP)
             (SETQ PROJECTPATH (SLASHIT (PACKFILENAME 'HOST 'UNIX 'DIRECTORY (UNPACKFILENAME.STRING
                                                                              (TRUEFILENAME 
                                                                                     PROJECTPATH)
                                                                              'DIRECTORY
                                                                              'RETURN))
                                      T))
             (SETQ CLONEPATH (IF
 (GIT-CLONEP
 PROJECTPATH T T)
                               ELSEIF
 (SETQ GITPATH (GIT-PROJECT-PATH
 PROJECTNAME PROJECTPATH))
                                 THEN
 (SETQ PROJECTPATH GITPATH)
                                      (GIT-CLONEP
 PROJECTPATH NIL T)
                               ELSE
 (ERROR "Can't find GIT clone for" PROJECTPATH)))
             (CL:WHEN (SETQ GITIGNORE (INFILEP (PACKFILENAME.STRING 'NAME ".gitignore" 'BODY 
                                                      CLONEPATH)))
                 (SETQ GITIGNORE (CL:WITH-OPEN-FILE (STREAM GITIGNORE)
                                        (BIND
 L UNTIL
 (EOFP STREAM)
                                           WHILE
 (SETQ L (CL:READ-LINE STREAM :EOF-ERROR-P NIL 
                                                                :EOF-VALUE NIL))
                                           UNLESS
 (OR (EQ 0 (NCHARS L))
                                                      (STRPOS "#" L)) COLLECT
 L))))
             (SETQ EXCLUSIONS (CL:REMOVE-DUPLICATES (APPEND (FOR
 E INSIDE
 EXCLUSIONS
                                                               COLLECT
 (MKSTRING E))
                                                           GITIGNORE
                                                           `("deleted/" "*.sysout"))
                                     :TEST
                                     (FUNCTION STRING.EQUAL)))

             (* ;; "The %"my-%" case is for backward compatibility, eventually deprecated.")


             (SETQ WP
              (SELECTQ WORKINGPATH
                  ((T NIL) 
                       (OR (DIRECTORYNAME (PACKFILENAME.STRING
                                           'HOST
                                           'DSK
                                           'BODY
                                           (CONCAT (SUBSTRING CLONEPATH 1
                                                          (STRPOS "/" CLONEPATH -2 NIL NIL NIL 
                                                                 FILEDIRCASEARRAY T))
                                                  "working-"
                                                  (OR (SUBSTRING PROJECTPATH
                                                             (OR (STRPOS CLONEPATH PROJECTPATH 1 NIL
                                                                        NIL T FILEDIRCASEARRAY)
                                                                 -2))
                                                      (L-CASE PROJECTNAME))
                                                  ">"))
                                  T)
                           (DIRECTORYNAME (PACKFILENAME.STRING
                                           'HOST
                                           'DSK
                                           'BODY
                                           (CONCAT (SUBSTRING CLONEPATH 1
                                                          (STRPOS "/" CLONEPATH -2 NIL NIL NIL 
                                                                 FILEDIRCASEARRAY T))
                                                  "my-"
                                                  (OR (SUBSTRING PROJECTPATH
                                                             (OR (STRPOS CLONEPATH PROJECTPATH 1 NIL
                                                                        NIL T FILEDIRCASEARRAY)
                                                                 -2))
                                                      (L-CASE PROJECTNAME))
                                                  ">"))
                                  T)))
                  (DIRECTORYNAME (TRUEFILENAME WORKINGPATH)
                         T)))
             [SETQ WORKINGPATH (IF
 WP
                                   THEN
 (UNSLASHIT WP T)
                                 ELSEIF
 (EQ WORKINGPATH T)
                                   THEN
 NIL
                                 ELSE
 (ERROR (CONCAT "Can't find the working directory "
                                                    (OR WORKINGPATH "")
                                                    " for " PROJECTNAME]
             (SETQ PROJECT (CREATE
 GIT-PROJECT
                                  PROJECTNAME _ PROJECTNAME
                                  GITHOST _ (PACK* "{" (PSEUDOHOST (CONCAT "G" PROJECTNAME)
                                                              PROJECTPATH)
                                                   "}")
                                  WHOST _ (AND WORKINGPATH (PACK* "{" (PSEUDOHOST (CONCAT "W" 
                                                                                         PROJECTNAME)
                                                                             WP)
                                                                  "}"))
                                  EXCLUSIONS _ EXCLUSIONS
                                  DEFAULTSUBDIRS _ (MKLIST DEFAULTSUBDIRS)
                                  CLONEPATH _ CLONEPATH))
             (REPLACE
 MAINBRANCH OF
 PROJECT WITH
 (OR (GIT-BRANCH-EXISTS?
 'origin/main T PROJECT)
                                                     (GIT-BRANCH-EXISTS?
 'origin/master NIL PROJECT))
                    )
             (/RPLACD [OR (ASSOC PROJECTNAME GIT-PROJECTS)
                          (CAR (PUSH
 GIT-PROJECTS (CONS PROJECTNAME]
                    PROJECT)
             PROJECTNAME))])

(GIT-GET-PROJECT

  [LAMBDA (PROJECT NOERROR FIELD)
                            (* ; "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)
                                                    GIT-DEFAULT-PROJECT)
                                                GIT-PROJECTS))
                             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))
            (DEFAULTSUBDIRS 
                 (FETCH
 DEFAULTSUBDIRS OF
 PROJECT))
            (CLONEPATH (FETCH
 CLONEPATH OF
 PROJECT))
            (MAINBRANCH (FETCH
 MAINBRANCH OF
 PROJECT))
            PROJECT))])

(GIT-PROJECT-PATH

  [LAMBDA (PROJECTNAME PROJECTPATH)
                          (* ; "Edited  8-May-2022 15:10 by rmk")


    (* ;; "A project path must identify a clone.  But it may be that a working path (with the convention %"my-%" is given instead of a %"git-%".  So, this does a my- to git- string substitution, so that we can try again.  Essentially a string-subst of /git-xxx/ for /my-xxx/ ")


    (SETQ PROJECTPATH (TRUEFILENAME PROJECTPATH))
    (CL:UNLESS (MEMB (NTHCHARCODE PROJECTPATH -1)
                     (CHARCODE (> /)))
        (SETQ PROJECTPATH (CONCAT PROJECTPATH "/")))
    (LET (MY-POS (MYSUBDIR (CONCAT "/my-" PROJECTNAME "/")))
         (CL:WHEN (SETQ MY-POS (STRPOS MYSUBDIR PROJECTPATH 1 NIL NIL NIL FILEDIRCASEARRAY))
             (SLASHIT [CONCAT (SUBSTRING PROJECTPATH 1 MY-POS)
                             "git-" PROJECTNAME (SUBSTRING PROJECTPATH (IPLUS -1 MY-POS (NCHARS
                                                                                         MYSUBDIR]
                    T))])

(FIND-ANCESTOR-DIRECTORY

  [LAMBDA (STARTDIR PREDFN)
                                  (* ; "Edited  8-May-2022 12:17 by rmk")

    (BIND
 POS (A _ STARTDIR) WHILE
 (SETQ POS (STRPOS "/" A -2 NIL NIL NIL FILEDIRCASEARRAY T))
       DO
 (SETQ A (SUBSTRING A 1 POS))
          (CL:WHEN (APPLY* PREDFN A)
                 (RETURN A])

(GIT-FIND-CLONE

  [LAMBDA (PROJECTNAME PROJECTPATH)
                          (* ; "Edited  8-May-2022 15:00 by rmk")


    (* ;; "Maybe the PROJECTPATH was actually a MY path, in which case our best guess is that the git-clone is a sister somewhere above. ")


    (OR (GIT-CLONEP
 PROJECTPATH T T)
        (GIT-CLONEP
 (GIT-PROJECT-PATH
 PROJECTNAME PROJECTPATH)
               T T)
        [FIND-ANCESTOR-DIRECTORY
 PROJECTPATH (FUNCTION (LAMBDA (A)
                                                         (BIND
 D (GEN _ (\GENERATEFILES A NIL NIL 1))
                                                            WHILE
 (SETQ D (\GENERATENEXTFILE GEN))
                                                            WHEN
 (GIT-CLONEP
 D T)
                                                            DO
 (RETFROM (FUNCTION 
                                                                         FIND-ANCESTOR-DIRECTORY)
                                                                      D]
        (ERROR "NOT A GIT CLONE" PROJECTPATH])

(GIT-MAINBRANCH

  [LAMBDA (PROJECT LOCAL NOERROR)
                            (* ; "Edited  9-May-2022 16:34 by rmk")

    (LET [(MB (GIT-GET-PROJECT
 PROJECT NOERROR 'MAINBRANCH]
         (CL:IF LOCAL
             (CONCAT "local/" (STRIPWHERE
 MB))
             MB)])

(GIT-MAINBRANCH?

  [LAMBDA (BRANCH PROJECT NOERROR)
                           (* ; "Edited  9-May-2022 15:06 by rmk")

    (IF
 (STRING.EQUAL (STRIPWHERE
 (GIT-MAINBRANCH
 PROJECT NIL T))
               (STRIPWHERE
 BRANCH))
      ELSEIF
 NOERROR
        THEN
 NIL
      ELSE
 (ERROR "Can't modify main branch" BRANCH])
)
(DECLARE%: EVAL@COMPILE

(TYPERECORD GIT-PROJECT
 (PROJECTNAME GITHOST WHOST EXCLUSIONS DEFAULTSUBDIRS CLONEPATH MAINBRANCH))
)

(RPAQ? GIT-DEFAULT-PROJECT
 'MEDLEY)

(RPAQ? GIT-PROJECTS
 NIL)

(GIT-MAKE-PROJECT
 'MEDLEY T T '(EXPORTS.ALL RDSYS RDSYS.LCOM loadups/ patches/ tmp/ fontsold/ clos/ 
                                      cltl2/)
       '(greetfiles scripts sources library lispusers))

(GIT-MAKE-PROJECT
 'NOTECARDS T T '(online/))

(GIT-MAKE-PROJECT
 'LOOPS T T)



(* ;; "")





(* ;; "Lisp exec commands")



(RPAQ? GIT-MERGE-COMPARES
 T)

(DEFCOMMAND gwc (SUBDIR . OTHERS)

   (* ;; "Compares the specified local git-medley subdirectories against my working Medley.  The SUBDIRS are the arguments up to one that looks like a project")


    (LET ((SUBDIRS (AND SUBDIR (CONS SUBDIR OTHERS)))
          PROJECT)
         (SETQ SUBDIRS (FOR
 STAIL ON
 SUBDIRS COLLECT
 (IF
 (GIT-GET-PROJECT
 (CAR STAIL)
                                                                T)
                                                         THEN
 (SETQ PROJECT (CAR STAIL))
                                                              (GO $$OUT))
                                                   (CAR STAIL)))
         (GIT-COMPARE-WITH-WORKINGMEDLEY
 SUBDIRS NIL NIL NIL T PROJECT)))

(DEFCOMMAND bbc (BRANCH1 BRANCH2 LOCAL PROJECT)

   (* ;; "Compares 2 git branches.  Defaults to local/ if LOCAL, otherwise defaults to origin/.  BRANCH2 defaults to the main branch (origin/ or local/ depending on LOCAL)")


    (SETQ PROJECT (GIT-GET-PROJECT
 PROJECT))
   (GIT-COMPARE-BRANCHES
 BRANCH1 (OR BRANCH2 (GIT-MAINBRANCH
 PROJECT LOCAL))
          LOCAL PROJECT))

(DEFCOMMAND prc (REMOTEBRANCH DRAFTS PROJECT)

   (* ;; "Compares REMOTEBRANCH against the main orign branch, for pull-request assessment")


    (LET ((RB REMOTEBRANCH)
          (DR DRAFTS))
         (IF
 PROJECT
             THEN
 (SETQ PROJECT (GIT-GET-PROJECT
 PROJECT))
           ELSEIF
 (GIT-GET-PROJECT
 RB T)
             THEN
 (SETQ PROJECT RB)
                  (SETQ RB NIL)
           ELSEIF
 (GIT-GET-PROJECT
 DRAFTS T)
             THEN
 (SETQ PROJECT DRAFTS)
                  (SETQ DRAFTS NIL))
         (CL:WHEN (MEMB (U-CASE RB)
                        '(DRAFT DRAFTS))
             (SETQ RB NIL)
             (SETQ DR T))
         (CL:WHEN (OR RB (GIT-PICK-BRANCH
 (GIT-PRC-MENU
 DR PROJECT)
                                "Pull requests"))
             (GIT-COMPARE-BRANCHES
 RB (GIT-MAINBRANCH
 PROJECT)
                    NIL PROJECT))))

(DEFCOMMAND cob (BRANCH TITLESTRING PROJECT)

   (* ;; "Switches to BRANCH. T means my current branch, NEW/NEXT means my next branch (under wherever we are now), and STRING if given will be attached to the branch-name.  Default is to bring up a menu of locally available branches.")


    (CL:UNLESS (STRINGP TITLESTRING)
           (SETQ PROJECT TITLESTRING))
   (CL:UNLESS PROJECT
       (CL:WHEN (GIT-GET-PROJECT
 BRANCH T)
           (SETQ PROJECT BRANCH)
           (SETQ BRANCH NIL)))
   (SETQ PROJECT (GIT-GET-PROJECT
 PROJECT))
   (SELECTQ (U-CASE BRANCH)
       (T (GIT-CHECKOUT
 (GIT-MY-CURRENT-BRANCH
 PROJECT)
                 PROJECT))
       ((NEW NEXT) 
            (GIT-MAKE-BRANCH
 NIL TITLESTRING PROJECT))
       (GIT-CHECKOUT
 (OR BRANCH (GIT-PICK-BRANCH
 (GIT-BRANCHES
 'LOCAL PROJECT T)
                                       (CONCAT (L-CASE (FETCH
 PROJECTNAME OF
 PROJECT)
                                                      T)
                                              " branches")))
              PROJECT)))

(DEFCOMMAND b? (PROJECT) (SETQ PROJECT (GIT-GET-PROJECT
 PROJECT))
   (CONCAT (L-CASE (FETCH
 PROJECTNAME OF
 PROJECT)
                  T)
          " "
          (GIT-WHICH-BRANCH
 PROJECT)))

(DEFCOMMAND cdg (PROJECT SUBDIR) (CL:UNLESS (GIT-GET-PROJECT
 PROJECT T 'GHOST)
                                     (SETQ SUBDIR PROJECT)
                                     (SETQ PROJECT GIT-DEFAULT-PROJECT))
   (CL:WHEN [AND SUBDIR (NOT (MEMB (CHCON1 SUBDIR))
                             (CHARCODE (> /]
       (SETQ SUBDIR (CONCAT SUBDIR "/")))
   (SLASHIT (/CNDIR (CONCAT (TRUEFILENAME (GIT-GET-PROJECT
 PROJECT NIL 'GITHOST))
                           (OR SUBDIR "")))
          T))

(DEFCOMMAND cdw (PROJECT SUBDIR) (CL:UNLESS (GIT-GET-PROJECT
 PROJECT T)
                                     (SETQ SUBDIR PROJECT)
                                     (SETQ PROJECT GIT-DEFAULT-PROJECT))
   (CL:WHEN [AND SUBDIR (NOT (MEMB (CHCON1 SUBDIR))
                             (CHARCODE (> /]
       (SETQ SUBDIR (CONCAT SUBDIR "/")))
   (SLASHIT (/CNDIR (CONCAT (TRUEFILENAME (GIT-GET-PROJECT
 PROJECT NIL 'WHOST))
                           (OR SUBDIR "")))
          T))



(* ;; "")





(* ;; "File correspondents")


(DEFINEQ

(ALLSUBDIRS

  [LAMBDA (PROJECT)

    (* ;; "Edited 13-May-2022 10:40 by rmk")


    (* ;; "Edited 10-May-2022 00:16 by rmk")


    (* ;; 

    "Edited  7-May-2022 16:58 by rmk: the union of the subdirectories that exist in the project")


    (LET ((HOSTS (MKLIST (FETCH
 GITHOST OF
 PROJECT)))
          VAL)
         (CL:WHEN (FETCH
 WHOST OF
 PROJECT)
             (PUSHNEW
 HOSTS (FETCH
 WHOST OF
 PROJECT)))
         (SORT (FOR
 H VAL IN
 HOSTS
                  JOIN
 (FOR
 F D IN
 (FILDIR (PACKFILENAME 'HOST H 'BODY '*)
                                          1) WHEN
 (DIRECTORYNAMEP F)
                          UNLESS
 (OR [EQ (CHARCODE %.)
                                         (CHCON1 (SETQ D (FILENAMEFIELD F 'DIRECTORY]
                                     (THEREIS
 SKIP IN
 (FETCH
 EXCLUSIONS OF
 PROJECT)
                                        FIRST
 (SETQ D (CONCAT D "/"))
                                        SUCHTHAT
 (STRPOS SKIP D 1 NIL T NIL FILEDIRCASEARRAY)))
                          DO
 [SETQ D (UNSLASHIT (L-CASE (SUBSTRING D 1 -2]
                             (CL:UNLESS (MEMBER D VAL)
                                    (PUSH
 VAL D))) FINALLY
 (RETURN VAL])

(MEDLEYSUBDIRS

  [LAMBDA (PROJECT ALLSUBDIRS)
                               (* ; "Edited 13-May-2022 10:40 by rmk")


                                                             (* ; "Edited  7-May-2022 23:15 by rmk")

    (FOR
 D IN
 (OR ALLSUBDIRS (ALLSUBDIRS
 PROJECT)) COLLECT
 (UNSLASHIT (PACKFILENAME 'HOST
                                                                             (FETCH
 WHOST
                                                                                OF
 PROJECT)
                                                                             'DIRECTORY D)
                                                                  T])

(GITSUBDIRS

  [LAMBDA (PROJECT ALLSUBDIRS)
                               (* ; "Edited 10-May-2022 00:23 by rmk")


                                                             (* ; "Edited  7-May-2022 23:14 by rmk")


                                                             (* ; "Edited  4-Feb-2022 18:06 by rmk")

    (FOR
 D IN
 (OR ALLSUBDIRS (ALLSUBDIRS
 PROJECT)) COLLECT
 (SLASHIT (PACKFILENAME 'HOST
                                                                           (FETCH
 GITHOST
                                                                              OF
 PROJECT)
                                                                           'DIRECTORY D)
                                                                  T])
)
(DEFINEQ

(TOGIT

  [LAMBDA (MFILES PROJECT)
                                   (* ; "Edited 10-May-2022 10:45 by rmk")


                                                             (* ; "Edited  7-May-2022 23:15 by rmk")


    (* ;; "Does anybody call this?")


    (SETQ PROJECT (GIT-GET-PROJECT
 PROJECT))

    (* ;; "Copies MFILES to {GIT}. We do a sanity check to make sure particular MFILE is the latest version--we may have created another one without revising the directory browser.")


    (GIT-MAINBRANCH?
 (GIT-WHICH-BRANCH
 PROJECT)
           PROJECT)
    (FOR
 MF GF DEST (MEDLEYSUBDIRS
 _ (MEDLEYSUBDIRS
 PROJECT)) INSIDE
 MFILES
       COLLECT
 (SETQ MF (OR (FINDFILE MF NIL MEDLEYSUBDIRS)
                            (ERROR "FILE NOT FOUND" MF)))
             (CL:UNLESS (STRING.EQUAL MF (INFILEP (PACKFILENAME 'VERSION NIL 'BODY MF))
                               FILEDIRCASEARRAY)
                 (FLASHWINDOW T)
                 (PRIN3 (CONCAT MF " is not the latest version!")
                        T)
                 (ERROR!))
             (SETQ GF (GFILE4MFILE
 MF PROJECT))
             (PRIN3 (IF
 (SETQ DEST (COPYFILE MF GF))
                        THEN
 (CONCAT "Copied to " GF)
                      ELSE
 (FLASHWINDOW T)
                           (CONCAT MF " cannot be copied"))
                    T)
             DEST])

(FROMGIT

  [LAMBDA (GFILES PROJECT)
                                   (* ; "Edited 10-May-2022 10:45 by rmk")


                                                             (* ; "Edited  4-Feb-2022 18:08 by rmk")


                                                             (* ; "Edited 18-Jan-2022 16:31 by rmk")


    (* ;; "Does anybody call this?")


    (SETQ PROJECT (GIT-GET-PROJECT
 PROJECT))
    (FOR
 GF MF DEST (GITSUBDIRS
 _ (GITSUBDIRS
 PROJECT)) INSIDE
 GFILES
       COLLECT
 (SETQ GF (OR (FINDFILE GF NIL GITSUBDIRS)
                            (ERROR "FILE NOT FOUND" GF)))
             (SETQ MF (MFILE4GFILE
 GF))
             (PRIN3 (IF
 (SETQ DEST (COPYFILE GF MF))
                        THEN
 (CONCAT "Copied to " DEST)
                             DEST
                      ELSE
 (FLASHWINDOW T)
                           (CONCAT GF " cannot be copied"))
                    T)
             DEST])

(GIT-DELETE-FILE

  [LAMBDA (FILE PROJECT)
                                     (* ; "Edited  8-May-2022 09:27 by rmk")


                                                             (* ; "Edited 18-Jan-2022 23:07 by rmk")


                                                             (* ; "Edited 19-Dec-2021 16:11 by rmk")


                                                             (* ; "Edited 16-Dec-2021 13:00 by rmk")


    (* ;; "This deletes a file in the local checkout git directory {UNIX}...  FILE has to already be a full file name, for safety.")


    (* ;; "Since git files are on UNIX, we don't have to worry about older version numbers. ")


    (* ;; "We could make this undoable by copying it to deleted/, but git also can restore.")


    (GIT-CLONEP
 FILE NIL T)
    (DELFILE FILE])

(MYMEDLEY-DELETE-FILES

  [LAMBDA (FILE PROJECT)
                                     (* ; "Edited 13-May-2022 10:40 by rmk")


                                                             (* ; "Edited  8-May-2022 23:31 by rmk")


    (* ;; "FILE is presumably the latest version of a file in the MyMedley directory, and we are presumably removing all versions of that file.  If we left older versions, we would really trash ourselves.")


    (* ;; "But to guard against mistakes, %"deletion%" consists of moving all versions of the file from its current location to a deleted/ subdirectory of MEDLEYDIR, one that does not correspond to a git subdirectory.")


    (SETQ FILE (CONTRACT.PH FILE (FETCH
 WHOST OF
 PROJECT)))
    (CL:WHEN (EQ (FILENAMEFIELD (FETCH
 WHOST OF
 PROJECT)
                        'HOST)
                 (FILENAMEFIELD FILE 'HOST))
        (FOR
 F IN
 (DREVERSE (FILDIR (PACKFILENAME 'VERSION '* 'BODY FILE)))
           COLLECT
 

                 (* ;; 

                 "Delete the earlier ones first, if it goes bad, you don't want them to persist")


                 (CL:UNLESS (RENAMEFILE F (PACKFILENAME 'DIRECTORY (CONCAT "deleted>"
                                                                          (FILENAMEFIELD F
                                                                                 'DIRECTORY))
                                                 'BODY F))
                        (ERROR "Could not delete " F))
                 F))])
)
(DEFINEQ

(MYMEDLEYSUBDIR

  [LAMBDA (SUBDIR STAR PROJECT)
                              (* ; "Edited 13-May-2022 10:40 by rmk")


                                                             (* ; "Edited  7-May-2022 23:15 by rmk")

    (UNSLASHIT (PACK* (PACKFILENAME 'HOST (FETCH
 WHOST OF
 PROJECT)
                             'DIRECTORY SUBDIR)
                      (CL:IF STAR
                          "*"
                          "")])

(GITSUBDIR

  [LAMBDA (SUBDIR STAR PROJECT)
                              (* ; "Edited  7-May-2022 20:39 by rmk")


                                                             (* ; "Edited 26-Feb-2022 11:56 by rmk")

    (SLASHIT (PACK* (PACKFILENAME 'HOST (FETCH
 GITHOST OF
 PROJECT)
                           'DIRECTORY SUBDIR)
                    (CL:IF STAR
                        "*"
                        "")])

(STRIPDIR

  [LAMBDA (FILE DIRECTORY)                                   (* ; "Edited 18-Jan-2022 16:09 by rmk")

                                                             (* ; "Edited  8-Nov-2021 11:50 by rmk:")

    (IF
 (STRPOS DIRECTORY FILE 1 NIL T NIL FILEDIRCASEARRAY)
        THEN
 (SUBSTRING FILE (ADD1 (NCHARS DIRECTORY)))
      ELSE
 FILE])

(STRIPHOST

  [LAMBDA (NAME)
                                             (* ; "Edited 18-Jan-2022 15:37 by rmk")

    (LET ((POS (STRPOS "}" NAME)))
         (CL:IF POS
             (SUBSTRING NAME (ADD1 POS))
             NAME)])

(STRIPNAME

  [LAMBDA (FILE)

    (* ;; "Edited  5-Feb-2022 08:38 by rmk: the name/ext/version of FILE without disturbing host or directory.  Strips everything after last / >")


    (* ;; "Removes the name/ext/version of FILE without disturbing host or directory.  Strips everything after last / >")


    (FOR
 I LASTDIRPOS FROM
 1 DO
 (SELCHARQ (NTHCHARCODE FILE I)
                                     ((> < /) 
                                          (SETQ LASTDIRPOS I))
                                     (NIL (RETURN (CL:IF LASTDIRPOS
                                                      (SUBSTRING FILE 1 LASTDIRPOS)
                                                      FILE)))
                                     NIL])

(STRIPWHERE

  [LAMBDA (BRANCH)
                                           (* ; "Edited  9-May-2022 14:31 by rmk")

    (LET ((POS (STRPOS "/" BRANCH)))
         (CL:IF POS
             (SUBSTRING BRANCH (ADD1 POS))
             BRANCH)])
)
(DEFINEQ

(GFILE4MFILE

  [LAMBDA (MFILE PROJECT)
                                    (* ; "Edited  7-May-2022 23:19 by rmk")


                                                             (* ; "Edited  4-Feb-2022 18:04 by rmk")

    (SLASHIT (PACKFILENAME 'HOST (FETCH
 GITHOST OF
 PROJECT)
                    'VERSION NIL 'BODY MFILE)
           T])

(MFILE4GFILE

  [LAMBDA (GFILE PROJECT)
                                    (* ; "Edited 13-May-2022 10:40 by rmk")


                                                             (* ; "Edited  7-May-2022 23:20 by rmk")


                                                             (* ; "Edited  4-Feb-2022 18:04 by rmk")


                                                             (* ; "Edited 18-Jan-2022 15:24 by rmk")

    (UNSLASHIT (PACKFILENAME 'HOST (FETCH
 WHOST OF
 PROJECT)
                      'VERSION NIL 'BODY GFILE])

(GIT-REPO-FILENAME

  [LAMBDA (GFILE PROJECT)
                                    (* ; "Edited  8-May-2022 23:35 by rmk")


    (* ;; "Returns the string that the repo expects for a file name.  The prefix is stripped, brackets go to slashes, subdirectories are lower cased, an initial / and a final period is remove.")


    (SETQ GFILE (SLASHIT [IF
 (EQ (FILENAMEFIELD (FETCH
 GITHOST OF
 PROJECT)
                                        'HOST)
                                 (FILENAMEFIELD GFILE 'HOST))
                             THEN
 (STRIPHOST
 GFILE)
                           ELSE
 (STRIPDIR
 GFILE (TRUEFILENAME (FETCH
 GITHOST OF
 PROJECT]
                       T))
    (CL:WHEN (EQ (CHARCODE /)
                 (CHCON1 GFILE))
        (SETQ GFILE (SUBSTRING GFILE 2)))
    (CL:WHEN (EQ (CHARCODE %.)
                 (NTHCHARCODE GFILE -1))
        (SETQ GFILE (SUBSTRING GFILE 1 -2)))
    GFILE])
)



(* ;; "")





(* ;; "Git commands")


(DEFINEQ

(GIT-COMMIT

  [LAMBDA (FILES TITLE MESSAGE PROJECT)
                      (* ; "Edited  9-May-2022 16:11 by rmk")


                                                            (* ; "Edited 16-Nov-2021 08:06 by rmk:")


                                                            (* ; "Edited  2-Nov-2021 21:26 by rmk:")


    (* ;; "Commits files that are already in the (non-main) current git branch.")


    (CL:WHEN (STRING.EQUAL (GIT-MAINBRANCH
 PROJECT)
                    (GIT-WHICH-BRANCH
 PROJECT))
           (ERROR "Cannot commit to the main branch"))
    (HELP "UNIMPLEMENTED")
    (GIT-MAINBRANCH?
 (GIT-WHICH-BRANCH
 PROJECT)
           PROJECT)
    (LET (GFILES)
         (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")


                                                             (* ; "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)
           NIL NIL PROJECT])

(GIT-PULL

  [LAMBDA (BRANCH PROJECT)
                                   (* ; "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)))
           NIL NIL PROJECT])

(GIT-APPROVAL

  [LAMBDA (BRANCH PROJECT)
                                   (* ; "Edited  9-May-2022 15:08 by rmk")


                                                            (* ; "Edited 19-Nov-2021 15:08 by rmk:")

    (GIT-ADD-WORKTREE
 BRANCH T PROJECT)
    (GIT-ADD-WORKTREE
 (GIT-MAINBRANCH
 PROJECT)
           T])

(GIT-GET-FILE

  [LAMBDA (BRANCH GITFILE LOCALFILE NOERROR PROJECT)

    (* ;; "Edited  8-May-2022 16:54 by rmk: the stream, not the name because of the NODIRCORE case.")


    (* ;; "Edited  6-Mar-2022 17:45 by rmk: the stream, not the name because of the NODIRCORE case.")


    (* ;; "Returns the stream, not the name because of the NODIRCORE case.")


    (* ;; "If  GITFILE in (remote) BRANCH exists, it is copied to LOCALFILE and LOCALFILE is returned.  If it doesn't exist, return value is NIL if NOERROR, otherwise an ERROR.")


    (CL:WHEN (AND BRANCH (STRPOS "local/" BRANCH 1 NIL T))
        (SETQ BRANCH (SUBSTRING BRANCH 7)))
    (CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM (CONCAT (CDGITDIR
 PROJECT)
                                                          "git show " BRANCH ":" GITFILE)))
           (SETFILEINFO s 'ENDOFSTREAMOP (FUNCTION NILL))
           (LET (BYTES)
                (IF
 (FOR
 I B C FROM
 1 WHILE
 (SETQ C (NTHCHARCODE "fatal: " I))
                       DO
 
                          (* ;; 

                          "Returns NIL if we run off the fatal string with a match, otherwise T")


                          (CL:UNLESS (SETQ B (\BIN s))
                                 (RETURN T))
                          (PUSH
 BYTES B)
                          (CL:UNLESS (EQ B C)
                                 (RETURN T)))
                    THEN
 
                         (* ;; "Don't open STREAM until we know the file is real")


                         (CL:WITH-OPEN-FILE (STREAM (OR LOCALFILE '{NODIRCORE)
                                                   :IF-EXISTS :NEW-VERSION :DIRECTION :IO)
                                (FOR
 B IN
 (DREVERSE BYTES) DO
 (\BOUT STREAM B))
                                [DO
 (\BOUT STREAM (OR (\BIN s)
                                                      (RETURN]
                                (SETFILEINFO STREAM 'CREATIONDATE (OR (FILEDATE STREAM T)
                                                                      (FILEDATE STREAM)
                                                                      (GIT-FILE-DATE
 GITFILE BRANCH 
                                                                             PROJECT)))
                                STREAM)
                  ELSEIF
 NOERROR
                    THEN
 NIL
                  ELSE
 (ERROR "GIT FILE NOT FOUND" GITFILE])

(GIT-FILE-EXISTS?

  [LAMBDA (BRANCH GITFILE PROJECT)
                           (* ; "Edited  8-May-2022 00:02 by rmk")


                                                             (* ; "Edited  6-Mar-2022 19:04 by rmk")


                                                             (* ; "Edited 10-Feb-2022 20:55 by rmk")


                                                             (* ; "Edited 10-Dec-2021 21:30 by rmk")


    (* ;; "T if GITFILE exists on BRANCH.  If s is EOFP, the file exists but is empty")


    (CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM (CONCAT (CDGITDIR
 PROJECT)
                                                          "git show " BRANCH ":" GITFILE)))
           (SETFILEINFO s 'ENDOFSTREAMOP (FUNCTION NILL))
           (NOT (FOR
 I C FROM
 1 WHILE
 (SETQ C (NTHCHARCODE "fatal: " I))
                   ALWAYS
 (EQ (BIN s)
                              C])

(GIT-REMOTE-UPDATE

  [LAMBDA (DOIT PROJECT)
    (DECLARE
 (USEDFREE LAST-REMOTE-UPDATE-IDATE))
            (* ; "Edited  7-May-2022 22:41 by rmk")


    (* ;; "Because git hangs on this (and other things), do this no more than once a day")


    (CL:WHEN [OR DOIT (NOT (BOUNDP 'LAST-REMOTE-UPDATE-IDATE))
                 (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)
               T)
        (PROG1 (GIT-COMMAND
 "git remote update origin" NIL PROJECT)
            (SETQ LAST-REMOTE-UPDATE-IDATE (IDATE))))])

(GIT-REMOTE-ADD

  [LAMBDA (NAME URL)
                                         (* ; "Edited 31-Jan-2022 13:53 by rmk")

    (LET [(RESULT (GIT-COMMAND
 (CONCAT "git remote add " NAME " " URL]

         (* ;; "Does it return an error line?  What if URL is not good? ")


         (CAR RESULT])

(GIT-FILE-DATE

  [LAMBDA (GFILE BRANCH PROJECT)
                             (* ; "Edited  8-May-2022 16:56 by rmk")


                                                             (* ; "Edited  6-Mar-2022 17:41 by rmk")


                                                             (* ; "Edited  3-Jan-2022 19:43 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 " -- ")
                                             "")
                                         (GIT-REPO-FILENAME
 GFILE PROJECT))
                            NIL T PROJECT]
         DATE])
)



(* ;; "Differences")


(DEFINEQ

(GIT-BRANCH-DIFF

  [LAMBDA (BRANCH1 BRANCH2 PROJECT)

    (* ;; "Edited  9-May-2022 16:21 by rmk: returns an ALIST that classifies how the files in BRANCH1 and BRANCH2 differ (changed, renamed, added, deleted, copied).")


    (* ;; "Edited  6-May-2022 14:04 by rmk: returns an ALIST that classifies how the files in BRANCH1 and BRANCH2 differ (changed, renamed, added, deleted, copied).")


    (* ;; "This returns an ALIST that classifies how the files in BRANCH1 and BRANCH2 differ (changed, renamed, added, deleted, copied).")


    (CL:UNLESS BRANCH1
        (SETQ BRANCH1 (GIT-MAINBRANCH
 PROJECT)))
    (CL:UNLESS BRANCH2
        (SETQ BRANCH2 (GIT-MAINBRANCH
 PROJECT)))
    (GIT-REMOTE-UPDATE
 NIL PROJECT)                          (* (* ;; "Returns the status (M, R, D, A, C), but not sure what comparison is used for the letters.  With --name-only, you just get the list of files in the commit.  (GIT-COMMIT-DIFFS gives the commits that differ between 2 branches.  But what if a given file shows up in 2 different commits in a sequence?  E.g. it was changed and then deleted?  For each files we can calculate the sequence of changes and figure out what the net effect is?  e.g (file D (R file2) (C file3) A) would say that that file didn't exist at the beginning and doesn't exist at the end, so don't report it?")

                                                             (GIT-COMMAND (CONCAT 

                                                     "git diff-tree --no-commit-id --name-STATUS -r "

    COMMIT) NIL NIL PROJECT))

    (LET (POS (LINES (GIT-COMMAND
 (CONCAT "git diff --name-status -C --find-copies-harder " BRANCH1 
                                         " " BRANCH2)
                            NIL NIL PROJECT)))
         (CL:WHEN (SETQ POS (STRPOS "fatal: ambiguous argument '" (CAR LINES)
                                   1 NIL T T))
             (ERROR "Unknown branch " (IF
 (STRPOS BRANCH1 (CAR LINES)
                                                 POS NIL T)
                                          THEN
 BRANCH1
                                        ELSE
 BRANCH2)))
         (SORT [FOR
 L IN
 LINES
                  COLLECT
 (SELCHARQ (CHCON1 L)
                               (A (CL:IF (EQ (CHARCODE TAB)
                                             (NTHCHARCODE L 2))
                                      (LIST 'ADDED (SUBSTRING L 3))
                                      (ERROR "ADDED NOT RECOGNIZED" L)))
                               (D (CL:IF (EQ (CHARCODE TAB)
                                             (NTHCHARCODE L 2))
                                      (LIST 'DELETED (SUBSTRING L 3))
                                      (ERROR "DELETED NOT RECOGNIZED" L)))
                               (M (CL:IF (SETQ POS (STRPOS "	" L))
                                      (LIST 'CHANGED (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))
                                                 (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))
                                                 (SUBSTRING L (ADD1 POS))
                                                 (OR (FIXP (SUBATOM L 2 4))
                                                     (HELP "R without a number" 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 
                                                                          " Ignore remaining files? "
                                                                            )))
                                         (ERROR!)))
                               (HELP "Unrecognized git-diff code" (NTHCHAR L 1]
               T])

(GIT-COMMIT-DIFFS

  [LAMBDA (BRANCH1 BUTNOTBRANCH2 PROJECT)
                    (* ; "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)
           NIL NIL PROJECT])

(GIT-BRANCH-RELATIONS

  [LAMBDA (BRANCHES BRANCH2 STRIPWHERE PROJECT)
              (* ; "Edited  9-May-2022 16:12 by rmk")


    (* ;; "Returns a pair (SUPERSETS EQUALS), where each item in SUPERSETS is a list of the form (B0 B1 B2...) where each Bi is a superset of Bj for i < j and EQUALS is a list of branch equivalence classes. ")


    (CL:WHEN BRANCH2
        (SETQ BRANCHES (LIST BRANCHES BRANCH2)))
    (FOR
 DTAIL D1 MORE1 MORE2 SUPERSETS EQUALS
 ON
 (FOR
 B IN
 BRANCHES
                                                     COLLECT
 (CONS B (GIT-COMMIT-DIFFS
 B (

                                                                                       GIT-MAINBRANCH

                                                                                          PROJECT)
                                                                            PROJECT)))
       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)
                                (CDR D2))                    (* ; "Unlikely")

                    (PUSH
 [CDR (OR (ASSOC (CAR D1)
                                          EQUALS
)
                                   (CAR (PUSH
 EQUALS
 (CONS (CAR D1]
                          (CAR D2))
                    (GO $$ITERATE))
                (SETQ MORE2 (MEMBER (CADR D1)
                                   (CDR D2)))                (* ; 

                                                             "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)
                                                   SUPERSETS)
                                            (CAR (PUSH
 SUPERSETS (CONS (CAR D2]
                                   (CAR D1)))
                  ELSEIF
 MORE1
                    THEN
 (PUSH
 [CDR (OR (ASSOC (CAR D1)
                                               SUPERSETS)
                                        (CAR (PUSH
 SUPERSETS (CONS (CAR D1]
                               (CAR D2]
       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)
                          (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 (GIT-MAINBRANCH
 PROJECT)
                                                  (CDR E))
                                            THEN
 (CONS (GIT-MAINBRANCH
 PROJECT)
                                                       (DREMOVE (GIT-MAINBRANCH
 PROJECT)
                                                              (SORT DATUM)))
                                          ELSE
 (SORT DATUM]
             (RETURN (LIST SUPERSETS EQUALS
])
)



(* ;; "")





(* ;; "Branches")


(DEFINEQ

(GIT-BRANCH-NUM

  [LAMBDA (BRANCH INITS)
                                     (* ; "Edited 19-May-2022 19:11 by rmk")


    (* ;; "Returns nnn if BRANCH is ({local|origin}/)INITSnnn(-xxxx)")


    (CL:UNLESS INITS
        (SETQ INITS (GIT-INITIALS
)))
    (LET (NPOS (SPOS (OR (STRPOS "/" BRANCH 1 NIL NIL T)
                         1)))
         (CL:WHEN (SETQ NPOS (STRPOS INITS BRANCH SPOS NIL NIL T UPPERCASEARRAY))
             [NUMBERP (SUBATOM BRANCH NPOS (SUB1 (OR (STRPOS "-" BRANCH NPOS)
                                                     0])])

(GIT-CHECKOUT

  [LAMBDA (BRANCH PROJECT)
                                   (* ; "Edited  9-May-2022 15:12 by rmk")


                                                             (* ; "Edited  7-May-2022 23:51 by rmk")


                                                            (* ; "Edited  2-Nov-2021 22:40 by rmk:")

    (CAR (GIT-COMMAND
 (CONCAT "git checkout " (OR BRANCH (GIT-MAINBRANCH
 PROJECT))
                             "; git pull")
                NIL NIL PROJECT])

(GIT-WHICH-BRANCH

  [LAMBDA (PROJECT)
                                          (* ; "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])

(GIT-MAKE-BRANCH

  [LAMBDA (NAME TITLESTRING PROJECT)
                         (* ; "Edited 19-May-2022 17:57 by rmk")


                                                             (* ; "Edited  9-May-2022 15:13 by rmk")


    (* ;; " The new branch is directly under the currently checked out branch.  Maybe it should always make it under the main branch?")


    (* ;; 

    "This makes a new branch with name NAME: TITLESTRING, or just NAME if TITLESTRING is not given.")


    (* ;; "(GIT-MAKE-BRANCH) makes and checks out the next initialsn branch.")


    (CL:UNLESS NAME
        (SETQ NAME (GIT-MY-NEXT-BRANCH
 PROJECT)))
    (CL:WHEN TITLESTRING

        (* ;; "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 NAME (CONCAT NAME "--" TITLESTRING)))
    (LET ((UNDER (GIT-WHICH-BRANCH
 PROJECT))
          (RESULT (GIT-COMMAND
 (CONCAT "git checkout -b " NAME)
                         NIL NIL PROJECT)))
         (IF
 (STREQUAL (CAR RESULT)
                    (CONCAT "Switched to a new branch '" NAME "'"))
             THEN
 (CONCAT (CAR RESULT)
                         " under " UNDER)
           ELSEIF
 (STREQUAL (CAR RESULT)
                         (CONCAT "fatal: A branch named '" NAME "' already exists."))
             THEN
 (ERROR NAME "already exists")
           ELSE
 (HELP "Unexpected git result" RESULT])

(GIT-BRANCHES

  [LAMBDA (WHERE
 PROJECT EXCLUDEMERGED)
                      (* ; "Edited 19-May-2022 10:06 by rmk")


                                                             (* ; "Edited  9-May-2022 14:10 by rmk")


                                                             (* ; "Edited  7-May-2022 23:29 by rmk")

    (SETQ PROJECT (GIT-GET-PROJECT
 PROJECT))

    (* ;; "Strips of the %"* %" that indicates the current branch and the 2-space padding on other branches.  Packs local/ on to local branches")


    (LET ([LOCAL (CL:WHEN (MEMB (U-CASE WHERE)
                                '(NIL ALL LOCAL))
                     (FOR
 B IN
 (GIT-COMMAND
 "git branch" NIL NIL PROJECT)
                        COLLECT
 (PACK* "local/" (SUBATOM B 3))))]
          [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)))]
          BRANCHES)
         (SETQ BRANCHES (APPEND LOCAL REMOTE))
         (CL:WHEN EXCLUDEMERGED
             (SETQ BRANCHES (FOR
 B (MAINBRANCH _ (GIT-MAINBRANCH
 PROJECT LOCAL)) IN
 BRANCHES
                               UNLESS
 (GIT-COMMIT-DIFFS
 B MAINBRANCH PROJECT) COLLECT
 B)))
         (SORT BRANCHES])

(GIT-BRANCH-EXISTS?

  [LAMBDA (BRANCH NOERROR PROJECT EXCLUDEMERGED)
             (* ; "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])

(GIT-PICK-BRANCH

  [LAMBDA (BRANCHES TITLE)
                                   (* ; "Edited 18-May-2022 13:44 by rmk")

    (CL:WHEN (MKLIST BRANCHES)
        (MENU (CREATE
 MENU
                     TITLE _ (OR TITLE 'Branches)
                     ITEMS _ BRANCHES
                     MENUFONT _ DEFAULTFONT)))])

(GIT-PRC-MENU

  [LAMBDA (DRAFT PROJECT)
                                    (* ; "Edited 16-May-2022 19:44 by rmk")

    (LET ((PRS (GIT-PULL-REQUESTS
 T DRAFT PROJECT)))
         (CL:WHEN PRS
             (SETQ RELATIONS (GIT-BRANCH-RELATIONS
 (FOR
 PR IN
 PRS COLLECT
 (GITORIGIN
 (CADDR PR)))
                                    NIL T PROJECT))
             (SORT [FOR
 PR REL LABEL (SUPERSETS _ (CAR RELATIONS))
                        (EQUALS _ (CADR RELATIONS)) IN
 PRS
                      COLLECT
 (SETQ LABEL (IF
 [SETQ REL (CAR (CDR (SASSOC (CADDR PR)
                                                                         SUPERSETS]
                                              THEN
 (CONCAT (CADDR PR)
                                                          " > " REL)
                                            ELSEIF
 [SETQ REL (CAR (CDR (SASSOC (CADDR PR)
                                                                              EQUALS
]
                                              THEN
 (CONCAT (CADDR PR)
                                                          " = " REL)
                                            ELSE
 (CADDR PR)))
                            (LIST (CL:IF (MEMB 'DRAFT PR)
                                      (CONCAT LABEL " (draft)")
                                      LABEL)
                                  (GITORIGIN
 (CADDR PR))
                                  (CONCAT " " (CADR PR)
                                         "  #"
                                         (CAR PR]
                   T))])

(GIT-PULL-REQUESTS

  [LAMBDA (ALLINFO INCLUDEDRAFTS PROJECT)
                    (* ; "Edited  9-May-2022 16:54 by rmk")


                                                             (* ; "Edited 25-Feb-2022 09:26 by rmk")

    (FOR
 LINE 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
 (IF
 ALLINFO
                   THEN
 `[,(SUBATOM LINE 1 (SUB1 TAB1))
                          ,(SUBSTRING LINE (ADD1 TAB1)
                                  (SUB1 TAB2))
                          ,(SUBSTRING LINE (ADD1 TAB2)
                                  (SUB1 TAB3))
                          ,(SUBATOM LINE (ADD1 TAB3]
                 ELSE
 (SUBATOM LINE (ADD1 TAB2)
                             (SUB1 TAB3])
)



(* ;; "My branches")


(DEFINEQ

(GIT-MY-CURRENT-BRANCH

  [LAMBDA (PROJECT INITS)
                                    (* ; "Edited 19-May-2022 19:13 by rmk")

    (CL:UNLESS INITS
        (SETQ INITS (GIT-INITIALS
)))
    (FOR
 B IN
 (GIT-MY-BRANCHES
 PROJECT NIL INITS) LARGEST
 (OR (GIT-BRANCH-NUM
 B INITS)
                                                              0])

(GIT-MY-BRANCHP

  [LAMBDA (BRANCH PROJECT)
                                   (* ; "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])

(GIT-MY-NEXT-BRANCH

  [LAMBDA (PROJECT)
                                          (* ; "Edited 19-May-2022 14:08 by rmk")


                                                             (* ; "Edited  8-Jan-2022 09:43 by rmk")


    (* ;; "Figures out the number of my next incremental branch would be.  ")


    (PACK* (GIT-INITIALS
)
           (ADD1 (OR (GIT-MY-BRANCHP
 (GIT-MY-CURRENT-BRANCH
 PROJECT)
                            PROJECT)
                     0])

(GIT-MY-BRANCHES

  [LAMBDA (PROJECT EXCLUDEMERGED INITS)
                      (* ; "Edited 19-May-2022 19:10 by rmk")


    (* ;; "This returns only local branch names:  xyzn and not origin/xyzn or local/xyzn")


    (* ;; "If INITIALS is xyz or xyz:, returns xyzn where xyzn is a branch and n is greater than m for all other branches xyzm.  xyzn may not be be the current branch.")


    (* ;; "The return list is sorted so that lower n's come before later n's.  The last element is my current branch")


    (CL:UNLESS INITS
        (SETQ INITS (GIT-INITIALS
)))
    (FOR
 B IPOS IN
 (GIT-BRANCHES
 'LOCAL PROJECT EXCLUDEMERGED)
       WHEN
 [AND (SETQ IPOS (STRPOS INITS B 1 NIL NIL NIL UPPERCASEARRAY))
                 (OR (EQ IPOS 1)
                     (EQ (CHARCODE /)
                         (NTHCHARCODE B (SUB1 IPOS] COLLECT
 (CONS B (GIT-BRANCH-NUM
 B INITS))
       FINALLY
 

             (* ;; "We expect a branch beginning with INITS  rmk is of the form %"rmknnn%" or %"rmknnn--somestring%".  If so, we want to sort b the number.  If not, sort alphabetically at the end, with numbered ones first.")


             (RETURN (FOR
 B IN
 [SORT $$VAL (FUNCTION (LAMBDA (X Y)
                                                       (IF
 (CDR X)
                                                           THEN
 (IF
 (CDR Y)
                                                                    THEN
 (ILESSP (CDR X)
                                                                                (CDR Y))
                                                                  ELSE
 T)
                                                         ELSEIF
 (NOT (CDR Y))
                                                           THEN
 (ALPHORDER (CAR X)
                                                                       (CAR Y]
                        COLLECT
 (CAR B])
)



(* ;; "")





(* ;; "Worktrees")


(DEFINEQ

(GIT-ADD-WORKTREE

  [LAMBDA (BRANCH REMOTEONLY PROJECT)
                        (* ; "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))
           (ERROR BRANCH "is not a git branch"))
    (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
                                                                    (CONSTANT (ADD1 (NCHARS "origin/"
                                                                                           ]
                                           (CONCAT "git worktree add --guess-remote "
                                                  (WORKTREEDIR
 LOCALBRANCH PROJECT)
                                                  " " BRANCH)
                                    ELSE
 (CONCAT "git worktree add " (WORKTREEDIR
 BRANCH)
                                                " " BRANCH))
                            NIL NIL PROJECT))
         (CL:UNLESS (STRPOS "Preparing worktree" (CAR LINES)
                           1 NIL T)
                (ERROR "Could not create worktree for " BRANCH))
         BRANCH])

(GIT-REMOVE-WORKTREE

  [LAMBDA (BRANCH PROJECT)
                                   (* ; "Edited  9-May-2022 16:22 by rmk")


                                                            (* ; "Edited 17-Nov-2021 10:02 by rmk:")

    (GIT-BRANCH-EXISTS?
 BRANCH NIL PROJECT)
    (LET ((DIR (WORKTREEDIR
 BRANCH PROJECT))
          LINES)
         (SETQ LINES (GIT-COMMAND
 (CONCAT "git worktree remove " DIR)
                            NIL NIL PROJECT))
         (CL:WHEN (STRPOS "fatal: " (CAR LINES)
                         1 NIL T)
                (ERROR "Could not remove worktree for " BRANCH))
                                                             (* (DELFILE (CONCAT PATH "/.DS_Store"))

                                                             (GIT-COMMAND (CONCAT "rmdir " DIR) NIL 

                                                             NIL PROJECT))

         BRANCH])

(GIT-LIST-WORKTREES

  [LAMBDA NIL                                                (* ; "Edited 12-Dec-2021 12:13 by rmk")

                                                             (* ; "Edited 19-Nov-2021 18:53 by rmk:")


    (* ;; "The git command tells us what the clone thinks about it, but then we look to see what is actually in our worktrees directory, to make sure that the subdirectory wasn't deleted in a wy that the clone didn't know about.")


    (SORT (FOR
 L POS IN
 (GIT-COMMAND
 "git worktree list")
             WHEN
 (AND (SETQ POS (STRPOS "/worktrees/" L NIL NIL NIL T))
                       (STRPOS "(detached HEAD)" L)) COLLECT
 (SETQ L (SUBSTRING L POS))
                                                           (SUBATOM L 1 (SUB1 (STRPOS " " L])

(WORKTREEDIR

  [LAMBDA (BRANCH PROJECT)
                                   (* ; "Edited  9-May-2022 00:04 by rmk")


                                                             (* ; "Edited 18-Jan-2022 15:02 by rmk")


                                                            (* ; "Edited 25-Nov-2021 08:49 by rmk:")


                                                            (* ; "Edited 19-Nov-2021 20:56 by rmk:")


                                                            (* ; "Edited 17-Nov-2021 10:00 by rmk:")

    (CONCAT (FETCH
 GITHOST OF
 PROJECT)
           "../worktrees/"
           (IF
 BRANCH
               THEN
 "/"
             ELSE
 ""])
)



(* ;; "")





(* ;; "Comparisons")


(DEFINEQ

(GIT-GET-DIFFERENT-FILES

  [LAMBDA (BRANCH1 BRANCH2 DIR1 DIR2 PROJECT)
    (DECLARE
 (USEDFREE FROMGITN))

    (* ;; "Edited  9-May-2022 14:17 by rmk: Ask git for the files that differ between the branches, copy those files down to local DIR1 and DIR2, return the directories and a list of (dir1-file1 file2) mappings for renamed and copied files.")


    (* ;; "Edited  6-May-2022 08:26 by rmk: Ask git for the files that differ between the branches, copy those files down to local DIR1 and DIR2, return the directories and a list of (dir1-file1 file2) mappings for renamed and copied files.")


    (SETQ BRANCH1 (GIT-BRANCH-EXISTS?
 BRANCH1 NIL PROJECT))
    (SETQ BRANCH2 (GIT-BRANCH-EXISTS?
 BRANCH2 NIL PROJECT))
    (LET
     (MAPPINGS FROMGIT (DIFFS (GIT-BRANCH-DIFF
 BRANCH1 BRANCH2 PROJECT)))
     (CL:WHEN DIFFS
         (SETQ FROMGIT (PACK* '{FROMGIT (ADD
 FROMGITN 1)
                              '}))
         (PSEUDOHOST FROMGIT (CONCAT "{CORE}<" (FETCH
 PROJECTNAME OF
 PROJECT)
                                    ">"
                                    (DATE)
                                    ">"))

         (* ;; "UNSLASHIT because CORE doesn't know about slash")


         (CL:UNLESS DIR1
             (SETQ DIR1 (CONCAT FROMGIT "<" (UNSLASHIT BRANCH1)
                               ">")))
         (CL:UNLESS DIR2
             (SETQ DIR2 (CONCAT FROMGIT "<" (UNSLASHIT BRANCH2)
                               ">")))
         (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))
                          (OR (GIT-GET-FILE
 BRANCH1 D (CONCAT DIR1 D)
                                     T PROJECT)
                              (GIT-GET-FILE
 BRANCH2 D (CONCAT DIR2 D)
                                     T PROJECT)))
                   (DELETED 
                            (* ;; "Shouldn't exist in BRANCH1, should exist in BRANCH2.  But maybe git is just confused in marking a file that exists in the wrong place as a delete instead of an add, or maybe it may think of a file that doesn't exist at all as having been deleted.  Try for both, but don't cause an error.")


                            (SETQ D (CADR D))
                            (OR (GIT-GET-FILE
 BRANCH2 D (CONCAT DIR2 D)
                                       T PROJECT)
                                (GIT-GET-FILE
 BRANCH1 D (CONCAT DIR1 D)
                                       T PROJECT)))
                   (CHANGED                                  (* ; "Should exist in both branches")

                            (SETQ D (CADR D))
                            (GIT-GET-FILE
 BRANCH1 D (CONCAT DIR1 D)
                                   T PROJECT)
                            (GIT-GET-FILE
 BRANCH2 D (CONCAT DIR2 D)
                                   T PROJECT))
                   ((RENAMED COPIED) 

                                 (* ;; "These entries are from-to filename pairs.  If (CADDR) is 100, only need to fetch one, because it presumably has disappeared in BRANCH2 and reappeared in BRANCH1. MAPPINGS is returned so the connection can be reestablished higher up.  ")


                        
                        (* ;; "If renamed and then changed, for now treat as unrelated adds and deletes:  put both files in the fromgit directory.  Perhaps the mapping should still figure out how to relate them.")


                        (* ;; "For copied files, presumably 2 files are exactly the same.  But we hope we can show them on the same line, by virtue of the mapping.")


                        (LET ((GFILE (CDR D))
                              F1)

                             (* ;; "GFILE is a triple (F2 F1 N )")


                             (* ;; "F1 is the file in branch 1, if any, F2 is in branch 2")


                             (SETQ F1 (GIT-GET-FILE
 BRANCH1 (CADR GFILE)
                                             (CONCAT DIR1 (CADR GFILE))
                                             T PROJECT))
                             (IF
 (EQ (CADDR GFILE)
                                     100)
                                 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")


                                      (PUSH
 MAPPINGS (LIST (FULLNAME F1)
                                                           (SLASHIT (U-CASE (CONCAT DIR2 (CAR GFILE))
                                                                           )
                                                                  T)
                                                           (NTHCHAR (CAR D)
                                                                  1)
                                                           100))
                               ELSE
 
                                    (* ;; 

                                    "If not a perfect match, then the directory should figure it out")


                                    (GIT-GET-FILE
 BRANCH2 (CAR GFILE)
                                           (CONCAT DIR2 (CAR GFILE))
                                           T PROJECT))))
                   (HELP "UNKNOWN GIT-DIFF TAG" D)))
         (LIST DIR1 DIR2 MAPPINGS))])

(GIT-COMPARE-BRANCHES

  [LAMBDA (BRANCH1 BRANCH2 LOCAL PROJECT)
                    (* ; "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 BRANCH2 (GITORIGIN
 (OR BRANCH2 (GIT-MAINBRANCH
 PROJECT))
                         LOCAL))
    (PRINTOUT T "Comparing all " (L-CASE (FETCH
 PROJECTNAME OF
 PROJECT)
                                        T)
           " subdirectories of " BRANCH1 " and " BRANCH2 T)
    (LET (CDVALUE DIRS NENTRIES MAPPINGS)
         (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)
                  (SETQ CDVALUE (COMPAREDIRECTORIES (CAR DIRS)
                                       (CADR DIRS)
                                       '(> < ~= -* *-)
                                       '*>*.*)) 

                  (* ;; "We know that both sides come from Unix/unversioned, even if they have been copied into versioned FROMGIT, so we make a pass to remove the misleading versions.")


                  (* ;; 

          " Also, lower case and slash directories.  Perhaps can be done when the files are fetched?")


                  [CDMAP CDVALUE
                         (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)
                                                                       FILEDIRCASEARRAY)))]
                                          (CL:WHEN INFO1
                                              (CHANGE
 (FETCH
 (CDINFO FULLNAME) OF
 INFO1)
                                                     (SLASHIT (PACKFILENAME.STRING 'VERSION NIL
                                                                     'BODY DATUM)
                                                            T)))
                                          (CL:WHEN INFO2
                                              (CHANGE
 (FETCH
 (CDINFO FULLNAME) OF
 INFO2)
                                                     (SLASHIT (PACKFILENAME.STRING 'VERSION NIL
                                                                     'BODY DATUM)
                                                            T)))
                                          (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
                                                                  FULLNAME _ (CADR MAP)
                                                                  DATE _ (CL:IF (EQ 'R (CADDR MAP))
                                                                             " <-"
                                                                             " ==")
                                                                  LENGTH _ ""
                                                                  AUTHOR _ ""
                                                                  TYPE _ ""
                                                                  EOL _ ""))
                                                   (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 "Comparing " (L-CASE (FETCH
 PROJECTNAME
                                                                              OF
 PROJECT)
                                                                          T)
                                                     " " BRANCH1 " and " BRANCH2 "      "
                                                     (LENGTH (FETCH
 (CDVALUE CDENTRIES) OF
 CDVALUE))
                                                     " files")
                                  (LIST BRANCH1 BRANCH2)
                                  `(LABELFN GIT-CD-LABELFN BRANCH1 ,BRANCH1 BRANCH2 ,BRANCH2 PROJECT
                                          ,PROJECT)
                                  NIL
                                  `(Compare See))
                           (SETQ NENTRIES (LENGTH (FETCH
 (CDVALUE CDENTRIES) OF
 CDVALUE)))
                           (LIST NENTRIES (CL:IF (EQ NENTRIES 1)
                                              'difference
                                              'differences))
                    ELSE
 '(0 differences))
           ELSE
 '(0 differences])

(GIT-COMPARE-WITH-WORKINGMEDLEY

  [LAMBDA (SUBDIRS SELECT EXCLUDEDFILES FIXDIRECTORYDATES UPDATE PROJECT)

    (* ;; "Edited 17-May-2022 17:39 by rmk")


    (* ;; "Edited 10-May-2022 10:41 by rmk")


    (* ;; 

  "Edited 29-Mar-2022 13:58 by rmk: working medley subdirectories with the current local git branch.")


    (SETQ PROJECT (GIT-GET-PROJECT
 PROJECT))
    (CL:WHEN UPDATE (GIT-REMOTE-UPDATE
 NIL PROJECT))         (* ; "Doesn't matter if we are looking only at local files in the current branch.  We aren't fetching or checking out.")

    (CL:WHEN (AND (LISTP SUBDIRS)
                  (NULL (CDR SUBDIRS)))
        (SETQ SUBDIRS (CAR SUBDIRS)))
    (CL:UNLESS SUBDIRS
        (SETQ SUBDIRS (OR (FETCH
 DEFAULTSUBDIRS OF
 PROJECT)
                          'ALL)))
    (SETQ SUBDIRS (L-CASE SUBDIRS))
    (LET ((SUBDIRSTRING (IF
 (EQ SUBDIRS 'all)
                            THEN
 (SETQ SUBDIRS (ALLSUBDIRS
 PROJECT))
                                 "ALL subdirectories"
                          ELSE
 SUBDIRS)))
         (FOR
 SUBDIR TITLE CDVAL (WPROJ _ (CONCAT "Working " (L-CASE (FETCH
 PROJECTNAME OF
 PROJECT)
                                                                    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)
                  (SETQ CDVAL (COMPAREDIRECTORIES (MYMEDLEYSUBDIR
 SUBDIR T PROJECT)
                                     (GITSUBDIR
 SUBDIR T PROJECT)
                                     (OR SELECT '(> < ~= -* *-))
                                     NIL
                                     (FETCH
 EXCLUSIONS OF
 PROJECT)
                                     NIL NIL NIL FIXDIRECTORYDATES))
                  [FOR
 CDE IN
 (FETCH
 CDENTRIES OF
 CDVAL)
                     DO
 (CL:WHEN (FETCH
 INFO1 OF
 CDE)
                            (CHANGE
 (FETCH
 (CDINFO FULLNAME) OF
 (FETCH
 INFO1 OF
 CDE))
                                   (UNSLASHIT DATUM T)))
                        (CL:WHEN (FETCH
 INFO2 OF
 CDE)
                            (CHANGE
 (FETCH
 (CDINFO FULLNAME) OF
 (FETCH
 INFO2 OF
 CDE))
                                   (SLASHIT DATUM T)))]
                  CDVAL
            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 "Comparing " WPROJ " and  " BRANCH2 "      " SUBDIR 
                                           "         " (LENGTH (fetch
 (CDVALUE CDENTRIES)
                                                                  of
 CDVAL))
                                           " files"))
                        [CDBROWSER CDVAL TITLE `(,WPROJ ,BRANCH2)
                               `(BRANCH1 ,WPROJ BRANCH2 ,BRANCH2 SUBDIR ,SUBDIR LABELFN 
                                       GIT-CD-LABELFN PROJECT ,PROJECT)
                               NIL
                               `(Compare See "" Copy% <- (|Delete ALL <-| GIT-CD-MENUFN)
                                       ,@(CL:UNLESS (GIT-MAINBRANCH?
 BRANCH2 PROJECT T)
                                             '("" Copy% -> (Delete% -> GIT-CD-MENUFN)))]
                        (CONS (CONCAT SUBDIR "/")
                              (FOR
 CDENTRY IN
 (fetch
 CDENTRIES of
 CDVAL)
                                 COLLECT
 (fetch
 MATCHNAME of
 CDENTRY)))
                        (ADD
 NENTRIES (LENGTH (FETCH
 (CDVALUE CDENTRIES) OF
 CDVAL]
                  (SETQ LAST-WMEDLEY-CDVALUES $$VAL)
                  (TERPRI T)
                  (RETURN (LIST NENTRIES (CL:IF (EQ NENTRIES 1)
                                             'difference
                                             'differences)])

(GIT-COMPARE-WORKTREE

  [LAMBDA (BRANCH DONTUPDATE PROJECT)
                        (* ; "Edited  9-May-2022 16:17 by rmk")

    (CL:UNLESS DONTUPDATE
        (GIT-ADD-WORKTREE
 BRANCH T PROJECT)
        (GIT-ADD-WORKTREE
 (GIT-MAINBRANCH
 PROJECT)
               T PROJECT))
    (LET (ADDEDFILES DELETEDFILES SOURCEFILES COMPILEDFILES OTHERFILES (MAINBRANCH (GIT-MAINBRANCH

                                                                                    PROJECT)))
         (CL:UNLESS DONTUPDATE
             (GIT-ADD-WORKTREE
 BRANCH T PROJECT)
             (GIT-ADD-WORKTREE
 MAINBRANCH T PROJECT))
         (PRINTOUT T T "Comparing " (GIT-GET-PROJECT
 PROJECT NIL 'PROJECTNAME)
                (FETCH
 PROJECTNAME OF
 PROJECT)
                " origin/" BRANCH " and " MAINBRANCH T)
         (FOR
 FILE BFILE MFILE IN
 (GIT-BRANCH-DIFF
 BRANCH MAINBRANCH PROJECT)
            DO
 (SETQ BFILE (INFILEP (CONCAT (WORKTREEDIR
 BRANCH PROJECT)
                                           FILE)))
               (SETQ MFILE (INFILEP (CONCAT (WORKTREEDIR
 MAINBRANCH PROJECT)
                                           FILE)))
               (IF
 (AND BFILE MFILE)
                   THEN
 (IF
 (NOT (LISPSOURCEFILEP BFILE))
                            THEN
 (PUSH
 OTHERFILES FILE)
                          ELSEIF
 (MEMB (U-CASE (FILENAMEFIELD BFILE 'EXTENSION))
                                       *COMPILED-EXTENSIONS*)
                            THEN
 (PUSH
 COMPILEDFILES FILE)
                          ELSE
 (PUSH
 SOURCEFILES FILE))
                 ELSEIF
 BFILE
                   THEN
 (PUSH
 ADDEDFILES FILE)
                 ELSE
 (PUSH
 DELETEDFILES FILE)))
         (CL:WHEN ADDEDFILES
             (PRINTOUT T T "Added files: " T)
             (FOR
 F IN
 (SORT ADDEDFILES) DO
 (PRINTOUT T 2 F T)))
         (CL:WHEN DELETEDFILES
             (PRINTOUT T T "Deleted files: " T)
             (FOR
 F IN
 (SORT ADDEDFILES) DO
 (PRINTOUT T 2 F T)))
         (CL:WHEN SOURCEFILES
             (PRINTOUT T T "Changed Medley source files:" T)
             (FOR
 FILETAIL FILE BFILE MFILE ON
 (SORT SOURCEFILES)
                DO
 (SETQ FILE (CAR FILETAIL))
                   (PRINTOUT T 2 FILE T)
                   (SETQ FILE (CAR FILETAIL))
                   (SETQ BFILE (INFILEP (CONCAT (WORKTREEDIR
 BRANCH PROJECT)
                                               FILE)))
                   (SETQ MFILE (INFILEP (CONCAT (WORKTREEDIR
 MAINBRANCH PROJECT)
                                               FILE)))
                   (COMPARESOURCES-TEDIT BFILE MFILE)
                   (TTY.PROCESS T)
                   (CL:WHEN (OR OTHERFILES (CDR FILETAIL))
                          (WAITFORINPUT))))
         (CL:WHEN COMPILEDFILES
             (PRINTOUT T T "Medley compiled files, no comparisons:")
             (FOR
 F IN
 COMPILEDFILES DO
 (PRINTOUT T 2 F T)))
         (CL:WHEN OTHERFILES
             (PRINTOUT T T "Other changed files, using TEDIT-SEE")
             (FOR
 FILETAIL FILE BFILE MFILE ON
 (SORT OTHERFILES)
                DO
 (SETQ FILE (CAR FILETAIL))
                   (PRINTOUT T 2 FILE)
                   (SETQ FILE (CAR FILETAIL))
                   (SETQ BFILE (INFILEP (CONCAT (WORKTREEDIR
 BRANCH PROJECT)
                                               FILE)))
                   (SETQ MFILE (INFILEP (CONCAT (WORKTREEDIR
 MAINBRANCH PROJECT)
                                               FILE)))
                   (COMPARETEXT BFILE MFILE 'LINE)
                   (AND NIL (TEDIT-SEE BFILE)
                        (TEDIT-SEE MFILE))
                   (TTY.PROCESS T)
                   (CL:WHEN (CDR FILETAIL)
                          (WAITFORINPUT))))])

(GITCDOBJBUTTONFN

  [LAMBDA (OBJ WINDOW)
                                       (* ; "Edited 10-May-2022 00:30 by rmk")

    (HELP)
    (LET
     ([CDENTRY (CAR (IMAGEOBJPROP OBJ 'OBJECTDATUM]
      (BRANCH1 (WINDOWPROP WINDOW 'BRANCH1))
      (FONT (FONTCREATE 'TERMINAL 10))
      COPYITEM COMPAREITEMS TYPE INFO1 INFO2)
     (CL:WHEN (AND CDENTRY (CADR (IMAGEOBJPROP OBJ 'OBJECTDATUM))
                   (EQ LASTKEYBOARD 0))
         (SETQ INFO1 (FETCH
 (CDENTRY INFO1) OF
 CDENTRY))
         (SETQ INFO2 (FETCH
 (CDENTRY INFO2) OF
 CDENTRY))
         [IF
 (MOUSESTATE (ONLY LEFT))
             THEN

             [SETQ COMPAREITEMS
              (IF
 (AND INFO1 INFO2)
                  THEN
 [IF
 (EQ (SETQ TYPE (FETCH
 (CDINFO TYPE) OF
 INFO1))
                               (FETCH
 (CDINFO TYPE) OF
 INFO2))
                           THEN
 (SELECTQ TYPE
                                    (SOURCE [LIST (LIST "Compare sources?" ''COMPARESOURCES)
                                                  (LIST "Examine sources?" ''EXAMINE])
                                    (COMPILED)
                                    (TEXT (LIST (CONCAT "Compare text files?")
                                                ''TEXT))
                                    (IF
 (MEMB (U-CASE (FILENAMEFIELD (FETCH
 (CDINFO FULLNAME)
                                                                        OF
 INFO1)))
                                              '(TEXT TXT))
                                        THEN
 [LIST (LIST "Compare text files?" (KWOTE TYPE)
                                                         ''COMPARETEXT]
                                      ELSE
 (LIST (LIST (CONCAT "See " TYPE " files?")
                                                       (KWOTE TYPE]
                ELSEIF
 (OR INFO1 INFO2)
                  THEN
 (LIST (LIST "Show file?" ''TEDIT]
           ELSEIF
 [AND (MOUSESTATE (ONLY MIDDLE))
                       (NOT (WINDOWPROP WINDOW 'READONLY]
             THEN
 (SETQ COPYITEM (CONS (SELECTQ (CADDR (IMAGEOBJPROP OBJ 'OBJECTDATUM))
                                           (LEFT (LIST (CONCAT "Copy TO git " (GIT-WHICH-BRANCH
)
                                                              "?")
                                                       ''TOGIT))
                                           (RIGHT (LIST (CONCAT "Copy FROM git " (GIT-WHICH-BRANCH
)
                                                               "?")
                                                        ''FROMGIT))
                                           NIL]
         (CL:WHEN (OR COPYITEM COMPAREITEMS)
             (SELECTQ (MENU (CREATE
 MENU
                                   TITLE _ (CONCAT (WINDOWPROP WINDOW 'SUBDIR)
                                                  "/"
                                                  (FETCH
 MATCHNAME OF
 CDENTRY))
                                   ITEMS _ (APPEND COPYITEM COMPAREITEMS)
                                   MENUFONT _ FONT
                                   MENUTITLEFONT _ FONT))
                 (TOGIT (CL:WHEN (TOGIT
 (FETCH
 (CDINFO FULLNAME) OF
 INFO1)
                                        WINDOW)
                            (IMAGEOBJPROP OBJ 'COPIED T)
                            (REDISPLAYW WINDOW)
                            (CDOBJ.DISPLAYFN OBJ WINDOW)))
                 (FROMGIT (CL:WHEN (FROMGIT
 (FETCH
 (CDINFO FULLNAME) OF
 INFO2)
                                          WINDOW)
                              (IMAGEOBJPROP OBJ 'COPIED T)
                              (AND NIL (REDISPLAYW WINDOW))))
                 (COMPARESOURCES 
                      (TTY.PROCESS T)
                      (CSBROWSER (fetch
 (CDINFO FULLNAME) OF
 INFO1)
                             (fetch
 (CDINFO FULLNAME) OF
 INFO2)))
                 (COMPARETEXT (TTY.PROCESS T)
                              (COMPARETEXT (FETCH
 (CDINFO FULLNAME) OF
 INFO1)
                                     (FETCH
 (CDINFO FULLNAME) OF
 INFO2)
                                     'PARA))
                 (TEDIT (CL:WHEN INFO1
                            (TEDIT-SEE (FETCH
 (CDINFO FULLNAME) OF
 INFO1)))
                        (CL:WHEN INFO2
                            (TEDIT-SEE (FETCH
 (CDINFO FULLNAME) OF
 INFO2))))
                 NIL)))])

(GIT-CD-LABELFN

  [LAMBDA (FILE1 FILE2 USERDATA)                             (* ; "Edited  5-Jan-2022 15:10 by rmk")

                                                             (* ; "Edited 16-Dec-2021 12:25 by rmk")

                                                             (* ; "Edited 13-Dec-2021 22:13 by rmk")

    (DECLARE
 (USEDFREE CDVALUE))
    (LET (NC B LABEL1 LABEL2)
         (CL:WHEN (SETQ NC (FETCH
 NCDIR OF
 (FETCH
 CDMAXNC1 OF
 CDVALUE)))
             (SETQ LABEL1 (SLASHIT
 (SUBSTRING FILE1 (ADD1 NC))
                                 T))
             (CL:WHEN (SETQ B (LISTGET USERDATA 'BRANCH1))
                 (SETQ LABEL1 (CONCAT B "/" LABEL1))))
         (CL:WHEN (SETQ NC (FETCH
 NCDIR OF
 (FETCH
 CDMAXNC2 OF
 CDVALUE)))
             (SETQ LABEL2 (SLASHIT
 (SUBSTRING FILE2 (ADD1 NC))
                                 T))
             (CL:WHEN (SETQ B (LISTGET USERDATA 'BRANCH2))
                 (SETQ LABEL2 (CONCAT B "/" LABEL2))))
         (LIST (OR LABEL1 FILE1)
               (OR LABEL2 FILE2])

(GIT-CD-MENUFN

  [LAMBDA (TBITEM MENUITEM CDBROWSER KEY)
                    (* ; "Edited  8-May-2022 09:26 by rmk")


                                                             (* ; "Edited 10-Dec-2021 08:52 by rmk")


    (* ;; "MENUITEM is of the form (display-atom <this function> . extrainfo).  The selector for the selectq is either the CAR of the extrainfo or the display atom")


    (DECLARE
 (USEDFREE FILE1 FILE2 LABEL2 TYPE CDENTRY))
    (SELECTQ (OR (CADDR MENUITEM)
                 (CAR MENUITEM))
        (Delete% -> (FLASHWINDOW PWINDOW)
                    (IF
 FILE1
                        THEN
 (PRIN3 "Use 'Delete BOTH' instead")
                      ELSE
 (GIVE.TTY.PROCESS PWINDOW)
                           (CL:WHEN [OR (EQ KEY 'MIDDLE)
                                        (EQ 'Y (ASKUSER NIL 'N (CONCAT "Delete " LABEL2 " ? "]
                               (GIT-DELETE-FILE
 FILE2 (LISTGET USERDATA 'PROJECT))
                               (TB.DELETE.ITEM CDBROWSER TBITEM))))
        (|Delete ALL <-| 
             (FLASHWINDOW PWINDOW)
             (IF
 FILE2
                 THEN
 (PRIN3 "Use 'Delete BOTH' instead")
               ELSE
 (GIVE.TTY.PROCESS PWINDOW)
                    (CL:WHEN [OR (EQ KEY 'MIDDLE)
                                 (EQ 'Y (ASKUSER NIL 'N (CONCAT "Delete ALL versions of "
                                                               (NAMEFIELD LABEL1 T)
                                                               " ? "]
                        (MYMEDLEY-DELETE-FILES
 FILE1 (LISTGET USERDATA 'PROJECT))
                        (TB.DELETE.ITEM CDBROWSER TBITEM))))
        (Delete% BOTH (FLASHWINDOW PWINDOW)
                      (GIVE.TTY.PROCESS PWINDOW)
                      (CL:WHEN (EQ 'Y (ASKUSER NIL 'N (CONCAT 
                                                             "Delete all Medley and git versions of "
                                                             (NAMEFIELD LABEL1 T)
                                                             " ? ")))
                          (GIT-DELETE-FILE
 FILE2 (LISTGET USERDATA 'PROJECT))
                          (MYMEDLEY-DELETE-FILES
 FILE1 (LISTGET USERDATA 'PROJECT))
                          (TB.DELETE.ITEM CDBROWSER TBITEM)))
        (SHOULDNT])
)

(RPAQ? FROMGITN
 0)



(* ;; "")





(* ;; "Utilities")


(DEFINEQ

(CDGITDIR

  [LAMBDA (PROJECT)
                                          (* ; "Edited  7-May-2022 22:41 by rmk")


                                                            (* ; "Edited  2-Nov-2021 21:12 by rmk:")


    (* ;; "Strips off {UNIX}")


    (CONCAT "cd " [SLASHIT (STRIPHOST
 (TRUEFILENAME (FETCH
 GITHOST OF
 PROJECT]
           " ; "])

(GIT-COMMAND

  [LAMBDA (CMD ALL NOERROR PROJECT)
                          (* ; "Edited  7-May-2022 22:40 by rmk")


                                                            (* ; "Edited  7-Oct-2021 11:15 by rmk:")


    (* ;; "Suppress .git lines unless ALL")


    (SETQ PROJECT (GIT-GET-PROJECT
 PROJECT))
    (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))
                           (SUBSTRING CMD (IPLUS LPOS (NCHARS "local/"]
    (CL:WITH-OPEN-FILE (STREAM "{NODIRCORE}shell-dribble.txt" :DIRECTION :IO)
           (ShellCommand (CONCAT (CDGITDIR
 PROJECT)
                                CMD)
                  STREAM)
           (SETFILEPTR STREAM 0)
           (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 NIL T] COLLECT
 LINE
              FINALLY
 (CL:UNLESS NOERROR
                          (CL:WHEN (OR (EQ 1 (STRPOS "fatal" (CAR $$VAL)
                                                    1 NIL T))
                                       (EQ 1 (STRPOS "gh: Command not found" (CAR $$VAL)
                                                    1 NIL T)))
                              (ERROR (CONCAT "Git command %"" CMD "%" failed")
                                     (CAR $$VAL))))])

(GITORIGIN

  [LAMBDA (BRANCH LOCAL)
                                     (* ; "Edited  9-May-2022 14:26 by rmk")


                                                            (* ; "Edited 25-Nov-2021 08:47 by rmk:")


                                                            (* ; "Edited 22-Nov-2021 17:29 by rmk:")


    (* ;; "Insures origin/ unless LOCAL or local/ already")


    (CL:UNLESS BRANCH (HELP "BRANCH MUST BE SPECIFIED"))
    (IF
 (OR (STRPOS "origin/" BRANCH)
            (STRPOS "local/" BRANCH))
        THEN
 BRANCH
      ELSE
 (CONCAT (CL:IF LOCAL
                       "local/"
                       "origin/")
                  BRANCH])

(GIT-INITIALS

  [LAMBDA NIL
                                                (* ; "Edited 19-Jan-2022 13:18 by rmk")

    (OR (CL:IF (EQ (CHARCODE %:)
                   (NTHCHARCODE INITIALS -1))
            (SUBSTRING INITIALS 1 -2)
            INITIALS)
        (ERROR "INITIALS is not set"])
)

(PUTPROPS GITFNS
 FILETYPE
 :TCOMPL)
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (3441 17288 (GIT-CLONEP 3451 . 4714) (GIT-MAKE-PROJECT 4716 . 12828) (GIT-GET-PROJECT 
12830 . 14167) (GIT-PROJECT-PATH 14169 . 15213) (FIND-ANCESTOR-DIRECTORY 15215 . 15564) (
GIT-FIND-CLONE 15566 . 16647) (GIT-MAINBRANCH 16649 . 16933) (GIT-MAINBRANCH? 16935 . 17286)) (22251 
25039 (ALLSUBDIRS 22261 . 23547) (MEDLEYSUBDIRS 23549 . 24242) (GITSUBDIRS 24244 . 25037)) (25040 
29830 (TOGIT 25050 . 26456) (FROMGIT 26458 . 27439) (GIT-DELETE-FILE 27441 . 28287) (
MYMEDLEY-DELETE-FILES 28289 . 29828)) (29831 32363 (MYMEDLEYSUBDIR 29841 . 30297) (GITSUBDIR 30299 . 
30742) (STRIPDIR 30744 . 31115) (STRIPHOST 31117 . 31357) (STRIPNAME 31359 . 32112) (STRIPWHERE 32114
 . 32361)) (32364 34266 (GFILE4MFILE 32374 . 32737) (MFILE4GFILE 32739 . 33308) (GIT-REPO-FILENAME 
33310 . 34264)) (34315 42066 (GIT-COMMIT 34325 . 35151) (GIT-PUSH 35153 . 35797) (GIT-PULL 35799 . 
36411) (GIT-APPROVAL 36413 . 36762) (GIT-GET-FILE 36764 . 39233) (GIT-FILE-EXISTS? 39235 . 40179) (
GIT-REMOTE-UPDATE 40181 . 40905) (GIT-REMOTE-ADD 40907 . 41214) (GIT-FILE-DATE 41216 . 42064)) (42096 
51024 (GIT-BRANCH-DIFF 42106 . 46809) (GIT-COMMIT-DIFFS 46811 . 47255) (GIT-BRANCH-RELATIONS 47257 . 
51022)) (51069 59282 (GIT-BRANCH-NUM 51079 . 51652) (GIT-CHECKOUT 51654 . 52166) (GIT-WHICH-BRANCH 
52168 . 52466) (GIT-MAKE-BRANCH 52468 . 54212) (GIT-BRANCHES 54214 . 55595) (GIT-BRANCH-EXISTS? 55597
 . 56301) (GIT-PICK-BRANCH 56303 . 56631) (GIT-PRC-MENU 56633 . 58261) (GIT-PULL-REQUESTS 58263 . 
59280)) (59312 62647 (GIT-MY-CURRENT-BRANCH 59322 . 59692) (GIT-MY-BRANCHP 59694 . 60199) (
GIT-MY-NEXT-BRANCH 60201 . 60695) (GIT-MY-BRANCHES 60697 . 62645)) (62693 66645 (GIT-ADD-WORKTREE 
62703 . 64187) (GIT-REMOVE-WORKTREE 64189 . 65119) (GIT-LIST-WORKTREES 65121 . 65925) (WORKTREEDIR 
65927 . 66643)) (66693 94417 (GIT-GET-DIFFERENT-FILES 66703 . 72429) (GIT-COMPARE-BRANCHES 72431 . 
78145) (GIT-COMPARE-WITH-WORKINGMEDLEY 78147 . 82612) (GIT-COMPARE-WORKTREE 82614 . 86487) (
GITCDOBJBUTTONFN 86489 . 90979) (GIT-CD-LABELFN 90981 . 92063) (GIT-CD-MENUFN 92065 . 94415)) (94487 
97470 (CDGITDIR 94497 . 94875) (GIT-COMMAND 94877 . 96463) (GITORIGIN 96465 . 97162) (GIT-INITIALS 
97164 . 97468)))))
STOP