From 626ab0234ad2e578992d128ced35c2003902e90f Mon Sep 17 00:00:00 2001 From: Carlo Zancanaro Date: Wed, 15 May 2013 18:51:21 +1000 Subject: Split out core into compiler/dsl/query. The query namespace really only exists because I didn't want to put it in dsl, but I couldn't put it in core without a circular dependency. Users should only have to :require core to do things, though. It just aliases other stuff to make that work. --- src/clojure_sql/core.clj | 392 ++--------------------------------------------- 1 file changed, 16 insertions(+), 376 deletions(-) (limited to 'src/clojure_sql/core.clj') diff --git a/src/clojure_sql/core.clj b/src/clojure_sql/core.clj index ae0eb75..cdfa1c9 100644 --- a/src/clojure_sql/core.clj +++ b/src/clojure_sql/core.clj @@ -1,381 +1,22 @@ (ns clojure-sql.core (:refer-clojure :exclude [sort-by]) (:require [clojure.set :as set] - [clojure.string :as string] + [clojure-sql.compiler :as c] + [clojure-sql.dsl :as d] [clojure-sql.util :as u] [clojure.walk])) -(declare compile-query) +(def table d/table) +(def project d/project) +(def rename d/rename) +(def join d/join) +(def select d/select) +(def sort-by d/sort-by) +(def insert! d/insert!) +(def update! d/update!) +(def delete! d/delete!) -(def ^:private ^:dynamic *database-type* nil) -(defn set-database-type! [new-type] - (alter-var-root #'*database-type* (constantly new-type))) - -(def ^:private ^:dynamic *query-deref-behaviour* #(compile-query *database-type* %)) -(defn set-query-deref-behaviour! [f] - (alter-var-root #'*query-deref-behaviour* (constantly f))) - -(defrecord ^:private Query [] - clojure.lang.IDeref - (deref [this] (*query-deref-behaviour* this))) -(defmethod print-method Query [query writer] - (binding [*out* writer] - (pr (compile-query nil query)))) - - - - -(defn add-parentheses [s] - (str \( s \))) - -;; ============================================================== -;; DB specific escaping methods -;; ============================================================== - -(defmulti field-name (fn [db _] db)) -(defmethod field-name :default [_ field] - (str \" (name field) \")) - -(defmulti table-name (fn [db _] db)) -(defmethod table-name :default [_ table] - (str \" (name table) \")) - -(defmulti function-name (fn [db _] db)) -(defmethod function-name :default [_ function] - (str \" (name function) \")) - - - - - -;; ============================================================== -;; Utility functions for the compile-* functions -;; ============================================================== - -;; compile-* multimethods are of the signature: -;; (db, expr) -> [SQL & replacements] - -(def is-unary? (comp boolean '#{"not"} name)) -(def is-binary? (comp boolean '#{"=" "<" ">" "<=" ">=" "is" "in" "+" "-" "/" "*"} name)) -(def is-operator? (comp boolean '#{"and" "or"} name)) - -(defn c-return [val] [val]) -(defn c-lift [f & orig-args] - (fn [& c-args] - (apply vector - (apply f (concat orig-args - (map first c-args))) - (apply concat (map rest c-args))))) -(def c-str (c-lift str)) -(def c-join (fn [sep args] - (apply vector - (string/join sep (map first args)) - (apply concat (map rest args))))) -(def c-add-parentheses (c-lift add-parentheses)) - - - -;; ============================================================== -;; compile-* functions (turning a map into a query string) -;; ============================================================== - -(defmulti compile-expression (fn [db _] db)) -(defmethod compile-expression :default [db ex] - (condp #(%1 %2) ex - nil? (c-return "NULL") - vector? (c-return (str (table-name db (first ex)) \. (field-name db (second ex)))) - keyword? (c-return (field-name db ex)) - string? ["?" ex] ;;(sql-string db ex) - symbol? (c-return (string/upper-case (name ex))) - sequential? (-> (condp #(%1 %2) (first ex) - is-unary? (if (= (count ex) 2) - (->> ex - (map (partial compile-expression db)) - (c-join " ")) - (throw (ex-info "Unary operators can only take one argument." - {:operator (first ex) - :arguments (rest ex)}))) - is-binary? (if (= (count ex) 3) - (->> (rest ex) - (map (partial compile-expression db)) - (interpose (compile-expression db (first ex))) - (c-join " ")) - (throw (ex-info "Binary operators must take two arguments." - {:operator (first ex) - :arguments (rest ex)}))) - is-operator? (->> (rest ex) - (map (partial compile-expression db)) - (interpose (compile-expression db (first ex))) - (c-join " ")) - (->> (rest ex) - (map (partial compile-expression db)) - (c-join ", ") - c-add-parentheses - (c-str (c-return (function-name db (first ex)))))) - c-add-parentheses) - (c-return ex))) - -(defn ^:private make-table-name [db table & [alias]] - (if (or (= table alias) (nil? alias)) - (table-name db table) - (str (table-name db table) " AS " (field-name db alias))) ) - -(defn ^:private make-field-name [db table field & [alias]] - (if (or (= field alias) (nil? alias)) - (str (table-name db table) \. (field-name db field)) - (str (table-name db table) \. (field-name db field) " AS " (field-name db alias)))) - -(defmulti compile-fields (fn [db _] db)) -(defmethod compile-fields :default [db fields-map] - (if (seq fields-map) - (->> (for [[[table field] alias] fields-map] - (make-field-name db table field alias)) - (string/join ", ") - c-return) - (c-return "*"))) - -(defmulti compile-tables (fn [db _] db)) -(defmethod compile-tables :default [db tables-map] - (->> (for [[table alias] tables-map] - (make-table-name db table alias)) - (string/join ", ") - c-return)) - -(defmulti compile-join (fn [db _] db)) -(defmethod compile-join :default [db [type table-map on]] - (c-str (c-return (case type - :left " LEFT OUTER" - :right " RIGHT OUTER" - " INNER")) - (c-return " JOIN ") - (compile-tables db table-map) - (c-return " ON ") - (compile-expression db on))) - -(defmulti compile-joins (fn [db _] db)) -(defmethod compile-joins :default [db joins] - (->> joins - (map (partial compile-join db)) - (c-join " "))) - -(defmulti compile-where (fn [db _] db)) -(defmethod compile-where :default [db expr] - (if expr - (c-str (c-return " WHERE ") (compile-expression db expr)))) - -(defmulti compile-sort-by (fn [db _] db)) -(defmethod compile-sort-by :default [db fields] - (if fields - (->> (for [[[table field] dir] fields] - (str (make-field-name db table field) \space (string/upper-case (name dir)))) - (string/join ",") - (apply str " ORDER BY ") - c-return))) - -(defmulti compile-query (fn [db _] db)) -(defmethod compile-query :default [db {:keys [table fields joins where sort-by]}] - (c-str (c-return "SELECT ") - (compile-fields db fields) - (if table - (c-return " FROM ")) - (compile-tables db table) - (compile-joins db joins) - (compile-where db where) - (compile-sort-by db sort-by))) - - - -;; SQL SERVER -(defmethod field-name :sql-server [_ field] - (str \[ (name field) \])) - -(defmethod table-name :sql-server [_ table] - (str \[ (name table) \])) - -;; mySQL -(defmethod field-name :mysql [_ field] - (str \` (name field) \`)) - -(defmethod table-name :mysql [_ table] - (str \` (name table) \`)) - - - - - - - - - - - - - - - - -;; ============================================================== -;; The DSL for making query maps -;; ============================================================== - -;; important sections: -;; -PROJECTION- -;; -TABLES- -;; -FILTERS- -;; GROUPING -;; GROUPED FILTERS -;; -SORTING- - -;; { -;; :table => tablename -> table_alias, -;; :fields => (table_alias, fieldname) -> field_alias -;; :joins => [tablename -> (type, table_alias, on)] -;; :where => expression -;; :sort-by => [(field, direction)] -;; } - -(defn table [arg] - (into (->Query) - (if (map? arg) - {:table arg} - {:table {arg arg}}))) - -(defn ambiguous-error [field & [query]] - (throw (ex-info (str "Ambiguous field " field " in query with more than one table") - {:field field - :query query}))) - -(defn project [query fields] - (let [table (if-not (:joins query) - (-> query :table first val)) - alias-lookup (u/flip-map (:fields query)) - original-name (fn [field] - (if (vector? field) - field - (or (get alias-lookup field nil) - (if table - [table field] - (ambiguous-error field query)))))] - (assoc query - :fields (->> (for [[key val] (if (map? fields) - fields - (zipmap fields fields))] - [(original-name key) val]) - (into {}))))) - -(defn rename [query field-renames] - {:pre [(map? field-renames) - ;; the intersection of the new aliases with the old aliases NOT renamed by this operation - (empty? (set/intersection (set (vals field-renames)) - (set/difference (set (vals (:fields query))) - (set (keys field-renames)))))]} - (let [fields (:fields query) - alias-lookup (u/flip-map (:fields query)) - original-name (fn [field] - (cond (vector? field) field - (contains? alias-lookup field) (get alias-lookup field) - :else (throw (ex-info (str "Cannot rename field " (pr-str field) ". Field does not exist in query.") - {:field field - :query query - :renames field-renames}))) - (get alias-lookup field))] - (update-in query - [:fields] #(->> (for [[key val] field-renames] - ;(if (contains? val (:fields query))) - [(original-name key) val]) - (into %))))) - -(defn ^:private resolve-field [table aliases field] - (let [field-alias-lookup (u/flip-map aliases)] - (or (field-alias-lookup field) - (if table - [table field] - (ambiguous-error field))))) - -(defn ^:private resolve-fields [table aliases expression] - (clojure.walk/postwalk (fn [expr] - (cond - (keyword? expr) (resolve-field table aliases expr) - :else expr)) - expression)) - -(defn ^:private combine-wheres [& wheres] - (reduce (fn [acc where] - (cond (nil? acc) where - (nil? where) acc - :else (or (if (and (sequential? where) - (= (name (first where)) "and")) - `(and ~acc ~@(next where))) - (if (and (sequential? acc) - (= (name (first acc)) "and")) - `(and ~@(next acc) ~where)) - `(and ~acc ~where)))) - nil wheres)) - -(defn join [left right & {:keys [on type]}] - (let [joins-vector (or (:join left) []) - common-fields (set/intersection (set (vals (:fields left))) - (set (vals (:fields right)))) - joined-fields (if (:type :right) - (merge (->> (:fields left) - (filter (comp not common-fields val)) - (into {})) - (:fields right)) - (merge (:fields left) - (->> (:fields right) - (filter (comp not common-fields val)) - (into {})))) - implicit-on (if (seq common-fields) - (map (fn [field] - `(= ~(resolve-field (:table left) (:fields left) field) - ~(resolve-field (:table right) (:fields right) field))) - common-fields)) - on (if on - [(resolve-fields nil joined-fields on)]) - join-condition (if-let [condition (seq (concat implicit-on on))] - `(and ~@condition) - true)] - (-> left - (assoc :fields joined-fields) - (assoc :joins (into (conj joins-vector - [(or type :inner) (:table right) join-condition]) - (:joins right))) - (assoc :where (combine-wheres (:where left) (:where right)))))) - -(defn select [query expression] - (let [table-name (if-not (:joins query) - (-> query :table first val)) - old-where (:where query) - resolved-expression (resolve-fields table-name (:fields query) expression) - new-where (combine-wheres old-where resolved-expression)] - (assoc query :where new-where))) - -(defn sort-by [query fields] - (let [table-name (if-not (:joins query) - (-> query :table first val)) - fields-seq (if (sequential? fields) - fields - [fields])] - (assoc query - :sort-by (for [field fields-seq] - (if (vector? field) - (resolve-field table-name (:fields query) field) - [(resolve-field table-name (:fields query) field) :asc]))))) - - -(defn insert! [query & records] - {:pre [(empty? (:joins query))]} - ;; some code here - ) - -(defn update! [query & partial-records] - ;; some code here - ) - -(defn delete! [query] - ;; some code here - ) (comment @@ -395,14 +36,14 @@ (rename {:id :pid})) (-> (table {:others :o}) (project {:id :oid})) - '(= :pid :oid)) - uid-pid-match) + :on '(= :pid :oid)) + :on uid-pid-match) (select is-carlo) (project [:fname :sname :oid])))) (-> (table :users) (join (table :something-else-with-a-username) - true) + :on true) (select '(or (= :username "john") (not (= :username "carlo")))) (project [:username])) @@ -413,14 +54,13 @@ (join (-> (table {:nodes :parent}) (project [:id, :name]) (rename {:name :parent.name})) - '(= :parent-id :id)) + :on '(= :parent-id :id)) (project [:child.name :parent.name])) (-> (table :users) (project [:id]) (join (-> (table :people) - (project [:id])) - true)) + (project [:id])))) (-> (table :users) (project [:id :name]) (rename {:id :name -- cgit v1.2.3