1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/src/clojure/contrib/command_line.clj	Sat Aug 21 06:25:44 2010 -0400
     1.3 @@ -0,0 +1,121 @@
     1.4 +;   Copyright (c) Chris Houser, Nov-Dec 2008. All rights reserved.
     1.5 +;   The use and distribution terms for this software are covered by the
     1.6 +;   Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
     1.7 +;   which can be found in the file epl-v10.html at the root of this distribution.
     1.8 +;   By using this software in any fashion, you are agreeing to be bound by
     1.9 +;   the terms of this license.
    1.10 +;   You must not remove this notice, or any other, from this software.
    1.11 +
    1.12 +; Process command-line arguments according to a given cmdspec
    1.13 +
    1.14 +(ns 
    1.15 +    ^{:author "Chris Houser", 
    1.16 +       :doc "Process command-line arguments according to a given cmdspec"}
    1.17 +    clojure.contrib.command-line
    1.18 +    (:use     (clojure.contrib [string :only (join)])))
    1.19 +
    1.20 +(defn make-map [args cmdspec]
    1.21 +  (let [{spec true [rest-sym] false} (group-by vector? cmdspec)
    1.22 +        rest-str (str rest-sym)
    1.23 +        key-data (into {} (for [[syms [_ default]] (map #(split-with symbol? %)
    1.24 +                                                        (conj spec '[help? h?]))
    1.25 +                                sym syms]
    1.26 +                            [(re-find #"^.*[^?]" (str sym))
    1.27 +                             {:sym (str (first syms)) :default default}]))
    1.28 +        defaults (into {} (for [[_ {:keys [default sym]}] key-data
    1.29 +                                :when default]
    1.30 +                            [sym default]))]
    1.31 +    (loop [[argkey & [argval :as r]] args
    1.32 +           cmdmap (assoc defaults :cmdspec cmdspec rest-str [])]
    1.33 +      (if argkey
    1.34 +        (let [[_ & [keybase]] (re-find #"^--?(.*)" argkey)]
    1.35 +          (cond
    1.36 +            (= keybase nil) (recur r (update-in cmdmap [rest-str] conj argkey))
    1.37 +            (= keybase "")  (update-in cmdmap [rest-str] #(apply conj % r))
    1.38 +            :else (if-let [found (key-data keybase)]
    1.39 +                    (if (= \? (last (:sym found)))
    1.40 +                      (recur r (assoc cmdmap (:sym found) true))
    1.41 +                      (recur (next r) (assoc cmdmap (:sym found)
    1.42 +                                             (if (or (nil? r) (= \- (ffirst r)))
    1.43 +                                               (:default found)
    1.44 +                                               (first r)))))
    1.45 +                    (throw (Exception. (str "Unknown option " argkey))))))
    1.46 +        cmdmap))))
    1.47 +
    1.48 +(defn- align
    1.49 +   "Align strings given as vectors of columns, with first vector
    1.50 +   specifying right or left alignment (:r or :l) for each column."
    1.51 +   [spec & rows]
    1.52 +   (let [maxes (vec (for [n (range (count (first rows)))]
    1.53 +                        (apply max (map (comp count #(nth % n)) rows))))
    1.54 +         fmt (join " " 
    1.55 +                  (for [n (range (count maxes))] 
    1.56 +                     (str "%" 
    1.57 +                        (when-not (zero? (maxes n))
    1.58 +                           (str (when (= (spec n) :l) "-") (maxes n))) 
    1.59 +                          "s")))]
    1.60 +      (join "\n"
    1.61 +         (for [row rows]
    1.62 +            (apply format fmt row)))))
    1.63 +
    1.64 +(defn- rmv-q
    1.65 +   "Remove ?"
    1.66 +   [^String s]
    1.67 +   (if (.endsWith s "?")
    1.68 +      (.substring s 0 (dec (count s)))
    1.69 +      s))
    1.70 +
    1.71 +(defn print-help [desc cmdmap]
    1.72 +  (println desc)
    1.73 +  (println "Options")
    1.74 +  (println 
    1.75 +     (apply align [:l :l :l] 
    1.76 +        (for [spec (:cmdspec cmdmap) :when (vector? spec)]
    1.77 +            (let [[argnames [text default]] (split-with symbol? spec)
    1.78 +                  [_ opt q] (re-find #"^(.*[^?])(\??)$"
    1.79 +                                 (str (first argnames)))
    1.80 +                  argnames  (map (comp rmv-q str) argnames)
    1.81 +                  argnames
    1.82 +                        (join ", "
    1.83 +                          (for [arg argnames]
    1.84 +                            (if (= 1 (count arg))
    1.85 +                              (str "-" arg)
    1.86 +                              (str "--" arg))))]
    1.87 +               [(str "  " argnames (when (= "" q) " <arg>") " ")
    1.88 +                text 
    1.89 +                (if-not default
    1.90 +                  ""
    1.91 +                  (str " [default " default "]"))])))))
    1.92 +
    1.93 +(defmacro with-command-line 
    1.94 +  "Bind locals to command-line args."
    1.95 +  [args desc cmdspec & body]
    1.96 +  (let [locals (vec (for [spec cmdspec]
    1.97 +                      (if (vector? spec)
    1.98 +                        (first spec)
    1.99 +                        spec)))]
   1.100 +    `(let [{:strs ~locals :as cmdmap#} (make-map ~args '~cmdspec)]
   1.101 +       (if (cmdmap# "help?")
   1.102 +         (print-help ~desc cmdmap#)
   1.103 +         (do ~@body)))))
   1.104 +
   1.105 +(comment
   1.106 +
   1.107 +; example of usage:
   1.108 +
   1.109 +(with-command-line *command-line-args*
   1.110 +  "tojs -- Compile ClojureScript to JavaScript"
   1.111 +  [[simple? s? "Runs some simple built-in tests"]
   1.112 +   [serve      "Starts a repl server on the given port" 8081]
   1.113 +   [mkboot?    "Generates a boot.js file"]
   1.114 +   [verbose? v? "Includes extra fn names and comments in js"]
   1.115 +   filenames]
   1.116 +  (binding [*debug-fn-names* verbose? *debug-comments* verbose?]
   1.117 +    (cond
   1.118 +      simple? (simple-tests)
   1.119 +      serve   (start-server (Integer/parseInt serve))
   1.120 +      mkboot? (mkboot)
   1.121 +      :else   (doseq [filename filenames]
   1.122 +                 (filetojs filename)))))
   1.123 +
   1.124 +)