Split git function into separate module

gitto/Makefile

@@ -3,7 +3,7 @@ SITEDIR = $(shell pkg-config guile-2.0 --variable=sitedir \
 	--define-variable=prefix=$(DESTDIR))
 COMPDIR = $(DESTDIR)/lib/guile/2.0/site-ccache
 
-objects = main.scm main.go path.scm path.go
+objects = git.scm git.go main.scm main.go path.scm path.go
 install-objects = $(addprefix install-,$(objects))
 uninstall-objects = $(addprefix uninstall-,$(objects))
 

gitto/git.scm

@@ -0,0 +1,165 @@
+;; -*- coding: utf-8; -*-
+;; gitto -- Keep track of your git repositories
+;; Copyright (C) 2012 Tom Willemsen <tom at ryuslash dot org>
+
+;; This file is part of gitto.
+
+;; gitto is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; gitto is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with gitto.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gitto git)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 rdelim)
+  #:use-module (oop goops)
+  #:export (<branch>
+            <repository>
+
+            branch-name
+            branch-pullable
+            branch-pushable
+            branch-updated
+            git-dir?
+            print
+            repo-branches
+            repo-clean?
+            repo-location
+            repo-name
+            same-repository?))
+
+(define-generic print)
+(define-generic same-repository?)
+
+(define-class <branch> ()
+  (name #:getter branch-name)
+  (pushable #:getter branch-pushable)
+  (pullable #:getter branch-pullable)
+  (updated #:getter branch-updated))
+
+(define-class <repository> ()
+  (name #:getter repo-name)
+  (location #:getter repo-location)
+  (clean? #:getter repo-clean?)
+  (branches #:getter repo-branches))
+
+(define-method (branch-pullable (branch <branch>))
+  (force (slot-ref branch 'pullable)))
+
+(define-method (branch-pushable (branch <branch>))
+  (force (slot-ref branch 'pushable)))
+
+(define-method (branch-updated (branch <branch>))
+  (force (slot-ref branch 'updated)))
+
+(define (git-branches dir)
+  (let ((pipe (start-git dir "branch")))
+    (map
+     (lambda (b) (string-trim-both b (char-set #\* #\space)))
+     (string-split (string-trim-right (read-string pipe)) #\newline))))
+
+(define (git-clean? dir)
+  "Check whether a repository is clean, meaning there are no changes
+to the tracked files. Utracked files will not register."
+  (let* ((pipe (start-git dir "status -suno"))
+         (clean? (eof-object? (read-delimited "" pipe))))
+    (close-pipe pipe)
+    clean?))
+
+(define (git-dir? dir)
+  "Check whether or not DIR/.git exists."
+  (let ((dir (string-append dir "/.git")))
+    (if (file-exists? dir)
+        (let ((dirstat (stat dir)))
+          (eq? (stat:type dirstat) 'directory))
+        #f)))
+
+(define (git-last-update dir branch)
+  "Check when the last update upstream was."
+  (let* ((pipe (start-git
+                dir (format #f "log -1 --format=%ar ~a@{u}" branch)))
+         (relative-last-update (read-line pipe)))
+    (close-pipe pipe)
+    (if (eof-object? relative-last-update)
+        "never"
+        relative-last-update)))
+
+(define (git-revs-to-pull dir branch)
+  "Check how many commits should be pulled/merged from upstream."
+  (let* ((pipe (start-git
+                dir (format #f "log --pretty=oneline ~a..~:*~a@{u}" branch)
+                "| wc -l"))
+         (num (string->number (read-line pipe))))
+    (close-pipe pipe)
+    num))
+
+(define (git-revs-to-push dir branch)
+  "Check how many commits should be pushed upstream."
+  (let* ((pipe (start-git
+                dir (format #f "log --pretty=oneline ~a@{u}..~:*~a" branch)
+                "| wc -l"))
+         (num (string->number (read-line pipe))))
+    (close-pipe pipe)
+    num))
+
+(define-method (initialize (branch <branch>) args)
+  (let ((name (car args))
+        (dir (cadr args)))
+    (slot-set! branch 'name name)
+    (slot-set! branch 'pushable (delay (git-revs-to-push dir name)))
+    (slot-set! branch 'pullable (delay (git-revs-to-pull dir name)))
+    (slot-set! branch 'updated (delay (git-last-update dir name)))))
+
+(define-method (initialize (repo <repository>) args)
+  (let ((dir (car args)))
+    (slot-set! repo 'name (basename dir))
+    (slot-set! repo 'location dir)
+    (slot-set! repo 'clean? (delay (git-clean? dir)))
+
+    (slot-set! repo 'branches
+               (delay (map (lambda (b) (make <branch> b dir))
+                           (git-branches dir))))))
+
+(define-method (print (branch <branch>))
+  (format #t "  ~a:~15t~d to push and ~d to pull. Last update: ~a~%"
+          (branch-name branch) (branch-pushable branch)
+          (branch-pullable branch) (branch-updated branch)))
+
+(define-method (print (repo <repository>))
+  (if (file-exists? (repo-location repo))
+      (begin
+        (format #t "~a: Worktree is ~a~%" (repo-name repo)
+                (if (repo-clean? repo) "clean" "dirty"))
+        (for-each print (repo-branches repo))
+        (newline))
+      (format #t "~a:~15tnot found at ~s\n"
+              (repo-name repo) (repo-location repo))))
+
+(define-method (repo-branches (repo <repository>))
+  (force (slot-ref repo 'branches)))
+
+(define-method (repo-clean? (repo <repository>))
+  (force (slot-ref repo 'clean?)))
+
+(define-method (same-repository? (x <repository>) (y <repository>))
+  (string= (repo-location x) (repo-location y)))
+
+(define-method (same-repository? (x <repository>) (y <string>))
+  (string= (repo-location x) y))
+
+(define-method (same-repository? (x <string>) (y <repository>))
+  (string= x (repo-location y)))
+
+(define* (start-git dir args #:optional (extra ""))
+  (open-input-pipe
+   (format #f "git --work-tree=~s --git-dir=\"~a/.git\" ~a 2>/dev/null ~a"
+           dir dir args extra)))

gitto/main.scm

@@ -18,75 +18,15 @@
 ;; along with gitto.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gitto main)
+  #:use-module (gitto git)
   #:use-module (gitto path)
   #:use-module (ice-9 format)
-  #:use-module (ice-9 ftw)
   #:use-module (ice-9 getopt-long)
   #:use-module (ice-9 popen)
-  #:use-module (ice-9 rdelim)
   #:use-module (oop goops)
   #:use-module (srfi srfi-1)
   #:export (main))
 
-(define-generic same-repository?)
-(define-generic print)
-
-(define-class <repository> ()
-  (name #:getter repo-name)
-  (location #:getter repo-location)
-  (clean? #:getter repo-clean?)
-  (branches #:getter repo-branches))
-
-(define-class <branch> ()
-  (name #:getter branch-name)
-  (pushable #:getter branch-pushable)
-  (pullable #:getter branch-pullable)
-  (updated #:getter branch-updated))
-
-(define-method (initialize (repo <repository>) args)
-  (let ((dir (car args)))
-    (slot-set! repo 'name (basename dir))
-    (slot-set! repo 'location dir)
-    (slot-set! repo 'clean? (delay (git-clean? dir)))
-
-    (slot-set! repo 'branches
-               (delay (map (lambda (b) (make <branch> b dir))
-                           (git-branches dir))))))
-
-(define-method (initialize (branch <branch>) args)
-  (let ((name (car args))
-        (dir (cadr args)))
-    (slot-set! branch 'name name)
-    (slot-set! branch 'pushable (delay (git-revs-to-push dir name)))
-    (slot-set! branch 'pullable (delay (git-revs-to-pull dir name)))
-    (slot-set! branch 'updated (delay (git-last-update dir name)))))
-
-(define-method (repo-clean? (repo <repository>))
-  (force (slot-ref repo 'clean?)))
-(define-method (repo-branches (repo <repository>))
-  (force (slot-ref repo 'branches)))
-(define-method (branch-pushable (branch <branch>))
-  (force (slot-ref branch 'pushable)))
-(define-method (branch-pullable (branch <branch>))
-  (force (slot-ref branch 'pullable)))
-(define-method (branch-updated (branch <branch>))
-  (force (slot-ref branch 'updated)))
-
-(define-method (print (repo <repository>))
-  (if (file-exists? (repo-location repo))
-      (begin
-        (format #t "~a: Worktree is ~a~%" (repo-name repo)
-                (if (repo-clean? repo) "clean" "dirty"))
-        (for-each print (repo-branches repo))
-        (newline))
-      (format #t "~a:~15tnot found at ~s\n"
-              (repo-name repo) (repo-location repo))))
-
-(define-method (print (branch <branch>))
-  (format #t "  ~a:~15t~d to push and ~d to pull. Last update: ~a~%"
-          (branch-name branch) (branch-pushable branch)
-          (branch-pullable branch) (branch-updated branch)))
-
 (define (storage-dir xdg-env fallback)
   (let ((xdg (getenv xdg-env)))
     (string-append
@@ -118,21 +58,6 @@ gitto [options]
   -h, --help           Display this help
 "))
 
-(define (git-dir? dir)
-  "Check whether or not DIR/.git exists."
-  (let ((dir (string-append dir "/.git")))
-    (if (file-exists? dir)
-        (let ((dirstat (stat dir)))
-          (eq? (stat:type dirstat) 'directory))
-        #f)))
-
-(define-method (same-repository? (x <repository>) (y <repository>))
-  (string= (repo-location x) (repo-location y)))
-(define-method (same-repository? (x <string>) (y <repository>))
-  (string= x (repo-location y)))
-(define-method (same-repository? (x <repository>) (y <string>))
-  (string= (repo-location x) y))
-
 (define (known? repo)
   "Do we know REPO?"
   (or (member repo repositories same-repository?)
@@ -187,53 +112,6 @@ gitto [options]
       (display "Not a registered repository."))
   (newline))
 
-(define (git-revs-to-push dir branch)
-  "Check how many commits should be pushed upstream."
-  (let* ((pipe (start-git
-                dir (format #f "log --pretty=oneline ~a@{u}..~:*~a" branch)
-                "| wc -l"))
-         (num (string->number (read-line pipe))))
-    (close-pipe pipe)
-    num))
-
-(define (git-revs-to-pull dir branch)
-  "Check how many commits should be pulled/merged from upstream."
-  (let* ((pipe (start-git
-                dir (format #f "log --pretty=oneline ~a..~:*~a@{u}" branch)
-                "| wc -l"))
-         (num (string->number (read-line pipe))))
-    (close-pipe pipe)
-    num))
-
-(define* (start-git dir args #:optional (extra ""))
-  (open-input-pipe
-   (format #f "git --work-tree=~s --git-dir=\"~a/.git\" ~a 2>/dev/null ~a"
-           dir dir args extra)))
-
-(define (git-branches dir)
-  (let ((pipe (start-git dir "branch")))
-    (map
-     (lambda (b) (string-trim-both b (char-set #\* #\space)))
-     (string-split (string-trim-right (read-string pipe)) #\newline))))
-
-(define (git-clean? dir)
-  "Check whether a repository is clean, meaning there are no changes
-to the tracked files. Utracked files will not register."
-  (let* ((pipe (start-git dir "status -suno"))
-         (clean? (eof-object? (read-delimited "" pipe))))
-    (close-pipe pipe)
-    clean?))
-
-(define (git-last-update dir branch)
-  "Check when the last update upstream was."
-  (let* ((pipe (start-git
-                dir (format #f "log -1 --format=%ar ~a@{u}" branch)))
-         (relative-last-update (read-line pipe)))
-    (close-pipe pipe)
-    (if (eof-object? relative-last-update)
-        "never"
-        relative-last-update)))
-
 (define (list-repositories)
   "List information about every repository."
   (for-each print repositories))