git.fiddlerwoaroof.com
ssh-configurator.lisp
1a481a69
 (defpackage :ssh-configurator
   (:use :clim :clim-lisp))
 (in-package :ssh-configurator)
 
 (defclass host ()
   ((%hosts :initarg :hosts :reader hosts)
    (%options :initarg :options :reader options)))
 (defclass ssh-config ()
   ((%hosts :initarg :hosts :reader hosts)
    (%options :initarg :options :reader options)))
 
 (defgeneric read-in (file object)
   (:method ((path string) object)
     (read-in (pathname path) object))
   (:method ((path pathname) object)
     (alexandria:with-input-from-file (f path)
       (read-in f object))))
 
 (defmethod read-in (file (host-blocks))
   )
 
 (defun prefix-count-if (pred seq)
   (length (serapeum:take-while pred seq)))
 
 (defun read-indented-block (stream)
   (values (loop for line = (read-line stream nil)
              for next-char = (peek-char nil stream nil)
              for whitespace-count = (prefix-count-if #'serapeum:whitespacep line)
              when (< whitespace-count (length line)) collect
                (cons whitespace-count
                      (subseq line whitespace-count))
              while (and next-char
                         (serapeum:whitespacep next-char)))
           stream))
 
 (defun tokenize-block (block)
   (mapcar (alexandria:compose 'serapeum:tokens
                               'cdr)
           block))
 
 (defun read-all-indented-blocks (stream)
   (loop for block = (read-indented-block stream)
      while block
      collect block))
 
 (define-application-frame ssh-configurator ()
   ((host-blocks :initarg :host-blocks :accessor host-blocks
                 :initform (error "need host blocks...")))
   (:panes
    (hosts (make-pane 'list-pane :items (host-blocks *application-frame*)))
    (props (make-pane 'list-pane :items '(2 3 41 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18))))
   (:layouts
    (default (vertically ()
               (scrolling ()
                 hosts)
               (scrolling ()
                 props))))
   )
 
 
 (defun ssh-configurator (host-blocks)
   (fw.lu:prog1-bind (f (make-application-frame 'ssh-configurator
                                                :host-blocks host-blocks))
     (bt:make-thread
      (serapeum:op (run-frame-top-level f))
      :name "ssh-configurator")))
 
 (defmacro print-and-return-when ((condition) form &rest others)
   `(let ((result ,form))
      (when ,condition
        (format *trace-output* "~&Result is: ~s~%~4t(~{~s~^ ~})~%" result (list ,@others)))
      result))
 
 (defun get-all-subclasses (object)
   (print-and-return-when ((typep (car result) 'standard-class))
    (etypecase object
      (list (mapcar 'get-all-subclasses object))
      (null (princ :what?))
      (symbol (get-all-subclasses (find-class object)))
      ((or standard-class sb-mop:funcallable-standard-class)
       (list (class-name object)
             (get-all-subclasses (sb-mop:class-direct-subclasses object)))))
    ))
 
 (defpackage :ssh-configurator/t
   (:use :cl :should-test))
 (in-package :ssh-configurator/t)
 (import 'ssh-configurator::read-indented-block)
 
 (deftest read-indented-block ()
     ()
   (should be equal
           '((0 . "a b c") (4 . "d"))
           (with-input-from-string (s (format nil "a b c~%~4td"))
             (read-indented-block s)))
   (should be equal
           '((0 . "e f g") (4 . "h"))
           (with-input-from-string (s (format nil "a b c~%~4td~%e f g~%~4th"))
             (read-indented-block
              (nth-value 1 (read-indented-block s)))))
   (should be equal
           '((0 . "e f g") (4 . "h"))
           (with-input-from-string (s (format nil "a b c~%~4td~%e f g~%~4th~%  "))
             (read-indented-block
              (nth-value 1 (read-indented-block s)))))
   (should be equal
           nil
           (with-input-from-string (s (format nil ""))
             (read-indented-block
              (nth-value 1 (read-indented-block s)))))
   (should be equal
           nil
           (with-input-from-string (s (format nil "   "))
             (read-indented-block
              (nth-value 1 (read-indented-block s))))))