Commits

carl douglas committed 3d493fa

Porting svn egg author tool to git

Comments (0)

Files changed (9)

+((synopsis "A small egg to make life easier for git-using authors of Chicken eggs")
+ (category egg-tools)
+ (author "Peter Bex" "A. Carl Douglas")
+ (doc-from-wiki)
+ (license "Public Domain")
+ (files "git-egg-author.meta" "git-egg-author.release-info" "git-egg-author.setup" "git-eggtag.scm" "git-update-meta.scm"))

git-egg-author.release-info

+(repo git "git://github.com/carld/{egg-name}.egg.git")
+(uri targz "https://github.com/carld/{egg-name}.egg/tarball/{egg-release}")
+(release "0.1")
+(release "0.2")
+(release "0.3")
+(release "0.4")
+;; -*- Scheme -*-
+
+(define version "0.1.3")
+
+(compile -O3 -d0 git-update-meta.scm)
+(install-program
+ `git-update-meta
+ `("git-update-meta")
+ `((version ,version)))
+
+(compile -O3 -d0 git-eggtag.scm)
+(install-program
+ `git-eggtag
+ `("git-eggtag")
+ `((version ,version)))
+(use setup-api posix files utils irregex)
+
+(define (usage code)
+  (print #<#EOF
+usage: git-eggtag [-n] RELEASE
+
+  -h   -help                    Show this message
+  -n   -no-update               No meta-file update
+
+git-eggtag will tag an egg for release with the name RELEASE and add a
+corresponding entry to the .release-info file.  It will also update
+the .meta-file's FILES section to contain all the files, unless -n is
+passed.
+
+EOF
+)
+(exit code))
+
+(define (call-with-input-pipe* cmd proc)
+  (let* ([p (open-input-pipe cmd)]
+         [res (proc p)])
+    (unless (zero? (close-input-pipe p))
+      (error "Got an error while executing command " cmd))
+    res))
+
+(define (git-exec cmd)
+  (call-with-input-pipe* cmd read-lines ))
+
+(define (irregex-grep irx lines)
+  (map (lambda(line)
+         (irregex-search irx line)) lines))
+
+(define (find-egg-name)
+  (let ((meta-file (glob "*.meta")))
+    (cond ((null? meta-file)
+           (fprintf (current-error-port)
+                    "Error: No meta file found! Please create one first~%")
+           (exit 1))
+          ((> (length meta-file) 1)
+           (fprintf (current-error-port)
+                    "Error: ~A meta files found. Can only deal with one!~%"
+                    (length meta-file))
+           (exit 1))
+          (else (pathname-file (car meta-file))))))
+
+(define (ensure-clean-wc!)
+  (let ((status (git-exec "git status --porcelain")))
+    (when (any values (irregex-grep "^ M" status))
+      (fprintf (current-error-port)
+               (conc "Working copy is not clean. Please commit all outstanding "
+                     "changes before tagging a release!~%"))
+      (exit 1))))
+
+(define (update-meta!)
+  (system* "~A/bin/git-update-meta" chicken-prefix))
+
+(define (update-release-info! release-version)
+  (let* ((release-infos (glob "*.release-info")))
+    (cond ((null? release-infos)
+           (fprintf (current-error-port)
+                    "Error: No release-info file found! Please create one first~%")
+           (exit 1))
+          ((> (length release-infos) 1)
+           (fprintf (current-error-port)
+                    "Error: ~A release-info files found. Can only deal with one!~%"
+                    (length release-infos))
+           (exit 1))
+          (else
+           ;; First check if this release already exists
+           (let lp ((contents (with-input-from-file (car release-infos) read-file)))
+             (cond ((null? contents) #f)
+                   ((and (eq? (caar contents) 'release)
+                         (string=? (cadar contents) release-version))
+                    (fprintf (current-error-port)
+                             "Release ~A already exists in release-info file!~%"
+                             release-version)
+                    (exit 1))
+                   (else (lp (cdr contents)))))
+           (with-output-to-file (car release-infos)
+             (lambda () (write `(release ,release-version)) (newline))
+             #:append)))))
+
+(define (check-tag-does-not-exist! release-version)
+  (when (any values (irregex-grep release-version (git-exec "git tag")))
+    (fprintf (current-error-port)
+             "There's already a tag that matches your release version ~S!~%"
+             release-version)
+    (exit 1)))
+
+(define (commit-all! egg-name release-version)
+  (system* "git commit -m ~A ~A ~A"
+           (qs (sprintf "~A: Add release ~A" egg-name release-version))
+           (qs (car (glob "*.release-info")))
+           (if *update-meta-file* (qs (car (glob "*.meta"))) "")))
+
+(define (push-all!)
+  (system* "git push --all"))
+
+(define (tag-egg release-version)
+  (let* ((egg-name (find-egg-name)))
+    (pp egg-name)
+    (ensure-clean-wc!)
+    (check-tag-does-not-exist! release-version)
+    (update-release-info! release-version)
+    (when *update-meta-file* (update-meta!))
+    (commit-all! egg-name release-version)
+    (push-all!)))
+
+(define *update-meta-file* #t)
+
+(define *short-options* '(#\h #\n))
+
+(define (main args)
+  (let loop ((args args))
+    (if (null? args)
+        (usage 1)
+        (let ((arg (car args)))
+          (cond ((or (string=? arg "-help")
+                     (string=? arg "-h")
+                     (string=? arg "--help"))
+                 (usage 0))
+                ((or (string=? arg "-n") (string=? arg "-no-update"))
+                 (set! *update-meta-file* #f)
+                 (loop (cdr args)))
+                ((and (positive? (string-length arg))
+                      (char=? #\- (string-ref arg 0)))
+                 (if (> (string-length arg) 2)
+                     (let ((sos (string->list (substring arg 1))))
+                       (if (null? (lset-intersection eq? *short-options* sos))
+                           (loop (append (map (cut string #\- <>) sos) (cdr args)))
+                           (usage 1)))
+                     (usage 1)))
+                ((= (length args) 1) (tag-egg (car args)))
+                (else (usage 1)))))))
+
+(main (command-line-arguments))
+(use posix files srfi-1)
+
+(define (usage code)
+  (print #<#EOF
+usage: git-update-meta
+
+  -h   -help                    Show this message
+
+git-update-meta will ask Git for all files that are managed by
+it and put those in the meta-file's FILES entry.  Files that are
+unversioned are ignored.
+
+EOF
+)
+(exit code))
+
+(define (call-with-input-pipe* cmd proc)
+  (let* ([p (open-input-pipe cmd)]
+         [res (proc p)])
+    (unless (zero? (close-input-pipe p))
+      (error "Got an error while executing command " cmd))
+    res))
+
+(define (git-exec cmd)
+  (call-with-input-pipe* cmd read-lines ))
+
+(define (ensure-meta-file-exists!)
+  (let* ((metas (glob "*.meta")))
+    (cond ((null? metas)
+           (fprintf (current-error-port)
+                    "Error: No meta-file found! Please create one first~%")
+           (exit 1))
+          ((> (length metas) 1)
+           (fprintf (current-error-port)
+                    "Error: ~A meta files found. Can only deal with one!~%"
+                   (length metas))
+           (exit 1))
+          (else #t))))
+
+(define (valid-meta-data? port)
+  (handle-exceptions exn
+    #f
+    (let ((meta (read-file port)))
+      (and (= 1 (length meta))
+           (list? (car meta))
+           (>= 1 (length (filter (lambda (e)
+                                   (eq? 'files (car e)))
+                                 (car meta))))))))
+
+(define (update-meta! files-list)
+  (let* ((files-list (sort files-list string<?))
+	 (meta-file (car (glob "*.meta")))
+         (meta-data (read-all meta-file)))
+    (unless (call-with-input-string meta-data valid-meta-data?)
+      (fprintf (current-error-port) "Error: invalid meta data in ~A~%" meta-file)
+      (exit 1))
+    (let* ((in (open-input-string meta-data))
+           (el #f)
+           (end #f))
+      (receive (start end)
+        (call/cc 
+         (lambda (found)
+           (##sys#read in (lambda (class data val)
+                            (if (eq? class 'list-info)
+                                (if (and el (eq? (car el) 'files))
+                                    (found (cdr el) (##sys#slot in 10))
+                                    (begin (set! el #f) (set! end (##sys#slot in 10))))
+                                (unless el
+                                  (set! el (cons data (##sys#slot in 10)))))))
+           (values #f end)))
+        (print "Updating " meta-file)
+        (with-output-to-file meta-file
+          (lambda ()
+            (if start
+                (begin
+                  (display (substring meta-data 0 start))
+                  (display #\space)
+                  (let ((s (with-output-to-string (lambda ()
+                                                    (write files-list)))))
+                   (display (substring s 1 (sub1 (string-length s)))))
+                  (display (substring meta-data (sub1 end))))
+                (begin
+                  (display (substring meta-data 0 (sub1 end)))
+                  (display "\n ")
+                  (write (cons 'files files-list))
+                  (display (substring meta-data (sub1 end)))))))))))
+
+(define (list-egg-files)
+  (git-exec "git ls-files"))
+
+(define *short-options* '(#\h))
+
+(define (main args)
+  (let loop ((args args))
+    (if (null? args)
+        (begin
+          (ensure-meta-file-exists!)
+          (update-meta! (list-egg-files)))
+        (let ((arg (car args)))
+          (cond ((or (string=? arg "-help")
+                     (string=? arg "-h")
+                     (string=? arg "--help"))
+                 (usage 0))
+                ((and (positive? (string-length arg))
+                      (char=? #\- (string-ref arg 0)))
+                 (if (> (string-length arg) 2)
+                     (let ((sos (string->list (substring arg 1))))
+                       (if (null? (lset-intersection eq? *short-options* sos))
+                           (loop (append (map (cut string #\- <>) sos) (cdr args)))
+                           (usage 1)))
+                     (usage 1)))
+                (else (usage 1)))))))
+
+(main (command-line-arguments))

svn-egg-author.meta

-((synopsis "A small egg to make life easier for svn-using authors of Chicken eggs")
- (category egg-tools)
- (author "Peter Bex")
- (doc-from-wiki)
- (license "Public Domain")
- (depends ssax sxpath)
- (files "svn-egg-author.meta" "svn-egg-author.release-info" "svn-egg-author.setup" "svn-eggtag.scm" "svn-update-meta.scm"))

svn-egg-author.setup

-;; -*- Scheme -*-
-
-(define version "0.1.3")
-
-(compile -O3 -d0 svn-update-meta.scm)
-(install-program
- `svn-update-meta
- `("svn-update-meta")
- `((version ,version)))
-
-(compile -O3 -d0 svn-eggtag.scm)
-(install-program
- `svn-eggtag
- `("svn-eggtag")
- `((version ,version)))

svn-eggtag.scm

-(use setup-api posix ssax sxpath sxpath-lolevel files utils)
-
-(define (usage code)
-  (print #<#EOF
-usage: svn-eggtag [-n] RELEASE
-
-  -h   -help                    Show this message
-  -n   -no-update               No meta-file update
-
-svn-eggtag will tag an egg for release with the name RELEASE and add a
-corresponding entry to the .release-info file.  It will also update
-the .meta-file's FILES section to contain all the files, unless -n is
-passed.
-
-EOF
-)
-(exit code))
-
-(define (call-with-input-pipe* cmd proc)
-  (let* ([p (open-input-pipe cmd)]
-         [res (proc p)])
-    (unless (zero? (close-input-pipe p))
-      (error "Got an error while executing command " cmd))
-    res))
-
-(define (svn-xml cmd)
-  (call-with-input-pipe* cmd (lambda (i) (ssax:xml->sxml i '()))))
-
-(define (find-root-url)
-  (let ((info (svn-xml "svn info --xml")))
-    (let lp ((url ((if-car-sxpath '(info entry url *text*)) info)))
-      (cond
-       ((or (not url) (string=? url ""))
-        (fprintf (current-error-port)
-                 "Could not figure out root URL; Please run from the 'trunk' of your egg")
-        (exit 1))
-       ((and (string? (pathname-file url))
-             (string=? (pathname-file url) "trunk"))
-        (pathname-directory url))
-       (else (lp (pathname-directory url)))))))
-
-(define (ensure-clean-wc!)
-  (let ((status (svn-xml "svn status --xml"))) ; -q doesn't work with --xml :(
-    (when ((if-car-sxpath `(status target entry wc-status
-                                   ;; There has to be a better way :(
-                                   ,(lambda (x y)
-                                      ((sxml:filter
-                                        (lambda (x)
-                                          (let ((s ((sxpath '(@ item)) x)))
-                                            (not (string=? (sxml:text s)
-                                                           "unversioned"))))) x))))
-           status)
-      (fprintf (current-error-port)
-               (conc "Working copy is not clean. Please commit all outstanding "
-                     "changes before tagging a release!~%"))
-      (exit 1))))
-
-(define (update-meta!)
-  (system* "~A/bin/svn-update-meta" chicken-prefix))
-
-(define (update-release-info! release-version)
-  (let* ((release-infos (glob "*.release-info")))
-    (cond ((null? release-infos)
-           (fprintf (current-error-port)
-                    "Error: No release-info file found! Please create one first~%")
-           (exit 1))
-          ((> (length release-infos) 1)
-           (fprintf (current-error-port)
-                    "Error: ~A release-info files found. Can only deal with one!~%"
-                    (length release-infos))
-           (exit 1))
-          (else
-           ;; First check if this release already exists
-           (let lp ((contents (with-input-from-file (car release-infos) read-file)))
-             (cond ((null? contents) #f)
-                   ((and (eq? (caar contents) 'release)
-                         (string=? (cadar contents) release-version))
-                    (fprintf (current-error-port)
-                             "Release ~A already exists in release-info file!~%"
-                             release-version)
-                    (exit 1))
-                   (else (lp (cdr contents)))))
-           (with-output-to-file (car release-infos)
-             (lambda () (write `(release ,release-version)) (newline))
-             #:append)))))
-
-(define (copy-to-tags! egg-name root-url release-version)
-  (let ((trunkdir (sprintf "~A/trunk" root-url))
-        (tagdir   (sprintf "~A/tags/~A" root-url release-version)))
-   (printf "Copying ~A\nto      ~A\n" trunkdir tagdir)
-   (system* "svn copy --parents -m ~A ~A ~A"
-            (qs (sprintf "~A: Tag release ~A" egg-name release-version))
-            (qs trunkdir)
-            (qs tagdir))))
-
-(define (check-tag-does-not-exist! root-url release-version)
-  (when (and ((if-car-sxpath `(// name (equal? "tags")))
-              (svn-xml (sprintf "svn ls --xml ~A" (qs root-url))))
-             ((if-car-sxpath `(// name (equal? ,release-version)))
-              (svn-xml (sprintf "svn ls --xml ~A/tags" (qs root-url)))))
-    (fprintf (current-error-port)
-             "There's already a tag that matches your release version ~S!~%"
-             release-version)
-    (exit 1)))
-
-(define (commit-all! egg-name release-version)
-  (system* "svn commit -m ~A ~A ~A"
-           (qs (sprintf "~A: Add release ~A" egg-name release-version))
-           (qs (car (glob "*.release-info")))
-           (if *update-meta-file* (qs (car (glob "*.meta"))) "")))
-
-(define (update-to-latest!)
-  (system* "svn update"))
-
-(define (tag-egg release-version)
-  (let* ((root-url (find-root-url))
-         (egg-name (or (pathname-file root-url)
-                       (pathname-file (pathname-directory root-url)))))
-    (ensure-clean-wc!)
-    (check-tag-does-not-exist! root-url release-version)
-    (update-release-info! release-version)
-    (when *update-meta-file* (update-meta!))
-    (commit-all! egg-name release-version)
-    (copy-to-tags! egg-name root-url release-version)
-    (update-to-latest!)))
-
-(define *update-meta-file* #t)
-
-(define *short-options* '(#\h #\n))
-
-(define (main args)
-  (let loop ((args args))
-    (if (null? args)
-        (usage 1)
-        (let ((arg (car args)))
-          (cond ((or (string=? arg "-help")
-                     (string=? arg "-h")
-                     (string=? arg "--help"))
-                 (usage 0))
-                ((or (string=? arg "-n") (string=? arg "-no-update"))
-                 (set! *update-meta-file* #f)
-                 (loop (cdr args)))
-                ((and (positive? (string-length arg))
-                      (char=? #\- (string-ref arg 0)))
-                 (if (> (string-length arg) 2)
-                     (let ((sos (string->list (substring arg 1))))
-                       (if (null? (lset-intersection eq? *short-options* sos))
-                           (loop (append (map (cut string #\- <>) sos) (cdr args)))
-                           (usage 1)))
-                     (usage 1)))
-                ((= (length args) 1) (tag-egg (car args)))
-                (else (usage 1)))))))
-
-(main (command-line-arguments))

svn-update-meta.scm

-(use posix ssax sxpath sxpath-lolevel files)
-
-(define (usage code)
-  (print #<#EOF
-usage: svn-update-meta
-
-  -h   -help                    Show this message
-
-svn-update-meta will ask Subversion for all files that are managed by
-it and put those in the meta-file's FILES entry.  Files that are
-unversioned are ignored.
-
-EOF
-)
-(exit code))
-
-(define (call-with-input-pipe* cmd proc)
-  (let* ([p (open-input-pipe cmd)]
-         [res (proc p)])
-    (unless (zero? (close-input-pipe p))
-      (error "Got an error while executing command " cmd))
-    res))
-
-(define (svn-xml cmd)
-  (call-with-input-pipe* cmd (lambda (i) (ssax:xml->sxml i '()))))
-
-(define (ensure-meta-file-exists!)
-  (let* ((metas (glob "*.meta")))
-    (cond ((null? metas)
-           (fprintf (current-error-port)
-                    "Error: No meta-file found! Please create one first~%")
-           (exit 1))
-          ((> (length metas) 1)
-           (fprintf (current-error-port)
-                    "Error: ~A meta files found. Can only deal with one!~%"
-                   (length metas))
-           (exit 1))
-          (else #t))))
-
-(define (valid-meta-data? port)
-  (handle-exceptions exn
-    #f
-    (let ((meta (read-file port)))
-      (and (= 1 (length meta))
-           (list? (car meta))
-           (>= 1 (length (filter (lambda (e)
-                                   (eq? 'files (car e)))
-                                 (car meta))))))))
-
-(define (update-meta! files-list)
-  (let* ((files-list (sort files-list string<?))
-	 (meta-file (car (glob "*.meta")))
-         (meta-data (read-all meta-file)))
-    (unless (call-with-input-string meta-data valid-meta-data?)
-      (fprintf (current-error-port) "Error: invalid meta data in ~A~%" meta-file)
-      (exit 1))
-    (let* ((in (open-input-string meta-data))
-           (el #f)
-           (end #f))
-      (receive (start end)
-        (call/cc 
-         (lambda (found)
-           (##sys#read in (lambda (class data val)
-                            (if (eq? class 'list-info)
-                                (if (and el (eq? (car el) 'files))
-                                    (found (cdr el) (##sys#slot in 10))
-                                    (begin (set! el #f) (set! end (##sys#slot in 10))))
-                                (unless el
-                                  (set! el (cons data (##sys#slot in 10)))))))
-           (values #f end)))
-        (print "Updating " meta-file)
-        (with-output-to-file meta-file
-          (lambda ()
-            (if start
-                (begin
-                  (display (substring meta-data 0 start))
-                  (display #\space)
-                  (let ((s (with-output-to-string (lambda ()
-                                                    (write files-list)))))
-                   (display (substring s 1 (sub1 (string-length s)))))
-                  (display (substring meta-data (sub1 end))))
-                (begin
-                  (display (substring meta-data 0 (sub1 end)))
-                  (display "\n ")
-                  (write (cons 'files files-list))
-                  (display (substring meta-data (sub1 end)))))))))))
-
-(define (list-egg-files)
-  (remove directory?
-          ((sxpath `(status target
-                            (entry (wc-status
-                                    ;; There has to be a better way :(
-                                    ,(lambda (x y)
-                                       ((sxml:filter
-                                         (lambda (x)
-                                           (let ((s ((sxpath '(@ item)) x)))
-                                             (not (string=? (sxml:text s)
-                                                            "unversioned"))))) x))))
-                            @ path (*text* 1)))
-           (svn-xml "svn status -v --xml"))))
-
-(define *short-options* '(#\h))
-
-(define (main args)
-  (let loop ((args args))
-    (if (null? args)
-        (begin
-          (ensure-meta-file-exists!)
-          (update-meta! (list-egg-files)))
-        (let ((arg (car args)))
-          (cond ((or (string=? arg "-help")
-                     (string=? arg "-h")
-                     (string=? arg "--help"))
-                 (usage 0))
-                ((and (positive? (string-length arg))
-                      (char=? #\- (string-ref arg 0)))
-                 (if (> (string-length arg) 2)
-                     (let ((sos (string->list (substring arg 1))))
-                       (if (null? (lset-intersection eq? *short-options* sos))
-                           (loop (append (map (cut string #\- <>) sos) (cdr args)))
-                           (usage 1)))
-                     (usage 1)))
-                (else (usage 1)))))))
-
-(main (command-line-arguments))