From 3cf3367faf60340728cf1009ff9ea2f725ad912b Mon Sep 17 00:00:00 2001
From: SANO Masatoshi <snmsts@gmail.com>
Date: Fri, 6 May 2016 16:17:01 +0900
Subject: [PATCH] WIP on swank.ros

---
 lisp/locations.lisp |   2 +
 lisp/swank.ros      | 101 ++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 103 insertions(+)
 create mode 100644 lisp/swank.ros

diff --git a/lisp/locations.lisp b/lisp/locations.lisp
index 11e7959..65b2ed3 100644
--- a/lisp/locations.lisp
+++ b/lisp/locations.lisp
@@ -42,3 +42,5 @@
 
 (defuri sbcl-bin-version-uri)
 (defuri sbcl-bin-uri)
+
+(defuri slime-uri "https://github.com/slime/slime.git")
diff --git a/lisp/swank.ros b/lisp/swank.ros
new file mode 100644
index 0000000..eb597cc
--- /dev/null
+++ b/lisp/swank.ros
@@ -0,0 +1,101 @@
+#!/bin/sh
+#|-*- mode:lisp -*-|#
+#|[WIP] manage swank version for roswell
+exec ros -Q -m roswell -L sbcl-bin -- $0 "$@"
+|#
+
+#-ros.util
+(ros:include "util")
+
+#-ros.install.util
+(ros:include "util-install")
+
+(defpackage :ros.script.swank.3671440529
+  (:use :cl :ros.locations :ros.util))
+
+(in-package :ros.script.swank.3671440529)
+
+(defvar *sub* '(("rm" . swank-rm)
+                ("delete" . swank-rm)
+                ("install" . swank-install)))
+
+(defun main (method command &optional sub &rest argv)
+  (declare (ignorable argv method command))
+  (let ((func (cdr (assoc sub *sub* :test #'equal))))
+    (when func (apply func argv))))
+
+(defun swank-from-git (name)
+  (let* ((str (slime-uri))
+         (end (position #\/ str :from-end t))
+         (end2 (position #\. str :from-end t))
+         (start (position #\/ str :from-end t :end end)))
+    (ros.util:clone-github
+     (subseq str (1+ start) end)
+     (subseq str (1+ end) end2)
+     :path "lisp/swank" :branch (format nil "v~A" name) :alias name
+     ))
+  :git)
+
+(defun swank-from-ql (name)
+  (let ((dist-file (merge-pathnames "tmp/swank-distinfo.txt" (homedir)))
+        (release-file (merge-pathnames "tmp/swank-release.txt" (homedir)))
+        (archive-file (merge-pathnames "tmp/swank.tgz" (homedir)))
+        (extract-path (merge-pathnames "lisp/swank/tmp/" (homedir)))
+        dist)
+    (unless (ql-impl-util:probe-directory extract-path)
+      (let ((uri (cdr (assoc (substitute #\- #\. name) 
+                             (ql-dist:available-versions (ql-dist:dist "quicklisp"))
+                             :test 'equal))))
+        (if uri (download uri dist-file)
+            (progn
+              (format *error-output* "invalid version ~A" name)
+              (ros:quit 1))))
+      (setq dist (ql-dist::make-dist-from-file dist-file))
+      (download (ql-dist::release-index-url
+                 (ql-dist::make-dist-from-file #P"~/.roswell/tmp/swank-distinfo.txt"))
+                release-file)
+      (with-open-file (in release-file)
+        (loop for line = (read-line in nil nil)
+           while line
+           for list = (ql-util:split-spaces line)
+           when (equal (first list) "slime")
+           do (download (second list) archive-file)))
+      (uiop/filesystem:delete-directory-tree (ensure-directories-exist extract-path) :validate t)
+      (expand archive-file (ensure-directories-exist extract-path))
+      (prog1
+          (ql-impl-util:rename-directory
+           (first (directory (make-pathname :defaults extract-path :name :wild :type :wild)))
+           (merge-pathnames (format nil "lisp/swank/~A/" name) (homedir)))
+        (uiop/filesystem:delete-directory-tree (ensure-directories-exist extract-path) :validate t))))
+  :ql)
+
+(defun name-error (name)
+  (format *error-output* "~A is not appropriate format. ~% quicklisp dist for XXXX.XX.XX , slime version for X.XX.~%" name)
+  (ros:quit 1))
+
+(defun swank-write-version (name)
+  (with-open-file (out (merge-pathnames "lisp/swank/version.txt" (homedir))
+                       :direction :output
+                       :if-exists :supersede)
+    (format out "~A" name)))
+
+(defun swank-write-helper (name)
+  (declare (ignore name)))
+
+(defun swank-install (name &rest argv)
+  "two type of name would be accepted 'date format' or 'version'"
+  (declare (ignorable argv))
+  (unless (loop for x across name
+             always (or (digit-char-p x)
+                        (eql x #\.)))
+    (name-error name))
+   (case (count #\. name)
+     (1 (swank-from-git name))
+     (2 (or
+         (ignore-errors (swank-from-git name)) ;; 2.10.1 couldn't be install without this line.
+         (swank-from-ql name)))
+     (t (name-error name)))
+   (swank-write-version name)
+   (swank-write-helper name))
+
+;;; vim: set ft=lisp lisp: