Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

file 113 lines (96 sloc) 3.439 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113
(ns ^{:author "Gareth Jones"}
  clojure.tools.cli
  (:use [clojure.string :only (replace)]
        [clojure.pprint :only (pprint cl-format)])
  (:refer-clojure :exclude [replace]))

(defn build-doc [{:keys [switches docs default]}]
  [(apply str (interpose ", " switches))
   (or (str default) "")
   (or docs "")])

(defn banner-for [specs]
  (println "Usage:")
  (println)
  (let [docs (into (map build-doc specs)
                   [["--------" "-------" "----"]
                    ["Switches" "Default" "Desc"]])
        max-cols (->> (for [d docs] (map count d))
                      (apply map (fn [& c] (apply vector c)))
                      (map #(apply max %)))
        vs (for [d docs]
             (mapcat (fn [& x] (apply vector x)) max-cols d))]
    (doseq [v vs]
      (cl-format true "~{ ~vA ~vA ~vA ~}" v)
      (prn))))

(defn name-for [k]
  (replace k #"^--no-|^--\[no-\]|^--|^-" ""))

(defn flag-for [^String v]
  (not (.startsWith v "--no-")))

(defn opt? [^String x]
  (.startsWith x "-"))

(defn flag? [^String x]
  (.startsWith x "--[no-]"))

(defn end-of-args? [x]
  (= "--" x))

(defn spec-for
  [arg specs]
  (->> specs
       (filter (fn [s]
                   (let [switches (set (s :switches))]
                     (contains? switches arg))))
       first))

(defn default-values-for
  [specs]
  (into {} (for [s specs] [(s :name) (s :default)])))

(defn apply-specs
  [specs args]
  (loop [options (default-values-for specs)
         extra-args []
         args args]
    (if-not (seq args)
      [options extra-args]
      (let [opt (first args)
            spec (spec-for opt specs)]
        (cond
         (end-of-args? opt)
         (recur options (into extra-args (vec (rest args))) nil)

         (and (opt? opt) (nil? spec))
         (throw (Exception. (str "'" opt "' is not a valid argument")))
         
         (and (opt? opt) (spec :flag))
         (recur (assoc options (spec :name) (flag-for opt))
                extra-args
                (rest args))

         (opt? opt)
         (recur (assoc options (spec :name) ((spec :parse-fn) (second args)))
                extra-args
                (drop 2 args))

         :default
         (recur options (conj extra-args (first args)) (rest args)))))))

(defn switches-for
  [switches flag]
  (-> (for [^String s switches]
        (cond
         (and flag (flag? s)) [(replace s #"\[no-\]" "no-") (replace s #"\[no-\]" "")]
         (and flag (.startsWith s "--")) [(replace s #"--" "--no-") s]
         :default [s]))
      flatten))

(defn generate-spec
  [raw-spec]
  (let [[switches raw-spec] (split-with #(and (string? %) (opt? %)) raw-spec)
        [docs raw-spec] (split-with string? raw-spec)
        options (apply hash-map raw-spec)
        aliases (map name-for switches)
        flag (or (flag? (last switches)) (options :flag))]
    (merge {:switches (switches-for switches flag)
            :docs (first docs)
            :aliases (set aliases)
            :name (keyword (last aliases))
            :parse-fn identity
            :default (if flag false nil)
            :flag flag}
           options)))

(defn cli
  [args & specs]
  (let [specs (map generate-spec specs)]
    (let [[options extra-args] (apply-specs specs args)
          banner (with-out-str (banner-for specs))]
      [options extra-args banner])))
Something went wrong with that request. Please try again.