ryuslash/gitto
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Split git function into separate module

Browse source
This commit is contained in:
Tom Willemse 2013-05-12 16:02:23 +02:00
parent a3d1cc969f
commit 964756b730
3 changed files with 167 additions and 124 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
gitto/Makefile
View file

@ -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))

165
gitto/git.scm Normal file
View file

@ -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)))

124
gitto/main.scm
View file

@ -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))