Prefer safe-name
This commit is contained in:
commit
8dae86ec79
|
|
@ -1,7 +1,7 @@
|
|||
(ns ^{:doc "Application Description Language - generate HUGSQL queries file."
|
||||
:author "Simon Brooke"}
|
||||
adl.to-hugsql-queries
|
||||
(:require [clojure.java.io :refer [file]]
|
||||
(:require [clojure.java.io :refer [file make-parents]]
|
||||
[clojure.math.combinatorics :refer [combinations]]
|
||||
[clojure.string :as s]
|
||||
[clojure.xml :as x]
|
||||
|
|
@ -54,7 +54,9 @@
|
|||
|
||||
(defn order-by-clause
|
||||
"Generate an appropriate `order by` clause for queries on this `entity`"
|
||||
[entity]
|
||||
([entity]
|
||||
(order-by-clause entity ""))
|
||||
([entity prefix]
|
||||
(let
|
||||
[entity-name (:name (:attrs entity))
|
||||
preferred (map
|
||||
|
|
@ -65,10 +67,10 @@
|
|||
(empty? preferred)
|
||||
""
|
||||
(str
|
||||
"ORDER BY " entity-name "."
|
||||
"ORDER BY " prefix entity-name "."
|
||||
(s/join
|
||||
(str ",\n\t" entity-name ".")
|
||||
(flatten (cons preferred (key-names entity))))))))
|
||||
(str ",\n\t" prefix entity-name ".")
|
||||
(flatten (cons preferred (key-names entity)))))))))
|
||||
|
||||
|
||||
(defn insert-query
|
||||
|
|
@ -152,8 +154,8 @@
|
|||
(str
|
||||
"-- :doc selects existing "
|
||||
pretty-name
|
||||
" records having any string field matching `:pattern` by substring match")
|
||||
(str "SELECT * FROM " entity-name)
|
||||
" records having any string field matching the parameter of the same name by substring match")
|
||||
(str "SELECT * FROM lv_" entity-name)
|
||||
"WHERE "
|
||||
(s/join
|
||||
"\n\tOR "
|
||||
|
|
@ -162,9 +164,9 @@
|
|||
(map
|
||||
#(if
|
||||
(#{"string" "date" "text"} (:type (:attrs %)))
|
||||
(str (-> % :attrs :name) " LIKE '%:pattern%'"))
|
||||
(str (-> % :attrs :name) " LIKE '%params." (-> % :attrs :name) "%'"))
|
||||
properties)))
|
||||
(order-by-clause entity)
|
||||
(order-by-clause entity "lv_")
|
||||
"--~ (if (:offset params) \"OFFSET :offset \")"
|
||||
"--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))})))
|
||||
|
||||
|
|
@ -232,8 +234,8 @@
|
|||
(list
|
||||
(str "-- :name " query-name " " signature)
|
||||
(str "-- :doc lists all existing " pretty-name " records")
|
||||
(str "SELECT * FROM " entity-name)
|
||||
(order-by-clause entity)
|
||||
(str "SELECT * FROM lv_" entity-name)
|
||||
(order-by-clause entity "lv_")
|
||||
"--~ (if (:offset params) \"OFFSET :offset \")"
|
||||
"--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))})))
|
||||
|
||||
|
|
@ -276,9 +278,11 @@
|
|||
"entity" (list
|
||||
(str "-- :name " query-name " " signature)
|
||||
(str "-- :doc lists all existing " pretty-name " records related to a given " pretty-far)
|
||||
(str "SELECT * \nFROM " entity-name)
|
||||
(str "WHERE " entity-name "." link-field " = :id")
|
||||
(order-by-clause entity))
|
||||
(str "SELECT * \nFROM lv_" entity-name ", " entity-name)
|
||||
(str "WHERE lv_" entity-name "." (first (key-names entity)) " = "
|
||||
entity-name "." (first (key-names entity))
|
||||
"\n\tAND " entity-name "." link-field " = :id")
|
||||
(order-by-clause entity "lv_"))
|
||||
"link" (let [link-table-name
|
||||
(link-table-name entity far-entity)]
|
||||
(list
|
||||
|
|
@ -325,18 +329,18 @@
|
|||
:near-entity near
|
||||
:far-entity far
|
||||
:query
|
||||
(s/join
|
||||
"\n"
|
||||
(remove
|
||||
empty?
|
||||
(list
|
||||
(str "-- :name " query-name " " signature)
|
||||
(str "-- :doc lists all existing " near-name " records related through " link-name " to a given " pretty-far )
|
||||
(str "SELECT "near-name ".*")
|
||||
(str "FROM " near-name ", " link-name )
|
||||
(str "WHERE " near-name "." (first (key-names near)) " = " link-name "." (singularise near-name) "_id" )
|
||||
("\tAND " link-name "." (singularise far-name) "_id = :id")
|
||||
(order-by-clause near))))}))))
|
||||
(s/join
|
||||
"\n"
|
||||
(remove
|
||||
empty?
|
||||
(list
|
||||
(str "-- :name " query-name " " signature)
|
||||
(str "-- :doc lists all existing " near-name " records related through " link-name " to a given " pretty-far )
|
||||
(str "SELECT "near-name ".*")
|
||||
(str "FROM " near-name ", " link-name )
|
||||
(str "WHERE " near-name "." (first (key-names near)) " = " link-name "." (singularise near-name) "_id" )
|
||||
("\tAND " link-name "." (singularise far-name) "_id = :id")
|
||||
(order-by-clause near))))}))))
|
||||
|
||||
|
||||
(defn link-table-queries [entity application]
|
||||
|
|
@ -392,13 +396,10 @@
|
|||
|
||||
(defn queries
|
||||
"Generate all standard queries for this `entity` in this `application`; if
|
||||
no entity is specified, generate all queris for the application."
|
||||
no entity is specified, generate all queries for the application."
|
||||
([application entity]
|
||||
(merge
|
||||
(if
|
||||
(link-table? entity)
|
||||
(link-table-queries entity application)
|
||||
{})
|
||||
;; TODO: queries that look through link tables
|
||||
(insert-query entity)
|
||||
(update-query entity)
|
||||
(delete-query entity)
|
||||
|
|
@ -416,22 +417,22 @@
|
|||
(defn to-hugsql-queries
|
||||
"Generate all [HugSQL](https://www.hugsql.org/) queries implied by this ADL `application` spec."
|
||||
[application]
|
||||
(spit
|
||||
(str *output-path* "queries.sql")
|
||||
(s/join
|
||||
"\n\n"
|
||||
(cons
|
||||
(s/join
|
||||
"\n-- "
|
||||
(list
|
||||
"-- File queries.sql"
|
||||
"autogenerated by adl.to-hugsql-queries at"
|
||||
(t/now)
|
||||
"See [Application Description Language](https://github.com/simon-brooke/adl).\n\n"))
|
||||
(let [file-path (str *output-path* "resources/sql/queries.sql")]
|
||||
(make-parents file-path)
|
||||
(spit
|
||||
file-path
|
||||
(s/join
|
||||
"\n\n"
|
||||
(cons
|
||||
(emit-header
|
||||
"--"
|
||||
"File queries.sql"
|
||||
(str "autogenerated by adl.to-hugsql-queries at " (t/now))
|
||||
"See [Application Description Language](https://github.com/simon-brooke/adl).")
|
||||
(map
|
||||
#(:query %)
|
||||
(sort
|
||||
#(compare (:name %1) (:name %2))
|
||||
(vals
|
||||
(queries application))))))))
|
||||
(queries application)))))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -47,12 +47,12 @@
|
|||
(f/unparse (f/formatters :basic-date-time) (t/now)))
|
||||
(list
|
||||
:require
|
||||
'[clojure.java.io :as io]
|
||||
'[compojure.core :refer [defroutes GET POST]]
|
||||
'[hugsql.core :as hugsql]
|
||||
'[noir.response :as nresponse]
|
||||
'[noir.util.route :as route]
|
||||
'[compojure.core :refer [defroutes GET POST]]
|
||||
'[ring.util.http-response :as response]
|
||||
'[clojure.java.io :as io]
|
||||
'[hugsql.core :as hugsql]
|
||||
(vector (symbol (str (safe-name (:name (:attrs application))) ".db.core")) :as 'db))))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -37,16 +37,6 @@
|
|||
;;; this is a pretty straight translation of adl2psql.xslt, and was written because
|
||||
;;; Clojure is easier to debug.
|
||||
|
||||
;;; TODO: the order in which we generate tables is critical, because tables
|
||||
;;; can only reference other tables which already exist. We could get around
|
||||
;;; this by generating referential integrity constraints post-hoc, which is
|
||||
;;; what the xslt version did.
|
||||
|
||||
(defn sort-by-name
|
||||
[elements]
|
||||
(sort #(.compareTo (:name (:attrs %1)) (:name (:attrs %2))) elements))
|
||||
|
||||
|
||||
(declare emit-field-type emit-property)
|
||||
|
||||
|
||||
|
|
@ -60,7 +50,7 @@
|
|||
(:pattern (:attrs typedef))
|
||||
(str
|
||||
" CONSTRAINT "
|
||||
(gensym "c-")
|
||||
(gensym "pattern_")
|
||||
" CHECK ("
|
||||
(:name (:attrs property))
|
||||
" ~* '"
|
||||
|
|
@ -70,7 +60,7 @@
|
|||
;; TODO: if base type is date, time or timestamp, values should be quoted.
|
||||
(str
|
||||
" CONSTRAINT "
|
||||
(gensym "c-")
|
||||
(gensym "minmax_")
|
||||
" CHECK ("
|
||||
(:minimum (:attrs typedef))
|
||||
" < "
|
||||
|
|
@ -83,7 +73,7 @@
|
|||
(:maximum (:attrs typedef))
|
||||
(str
|
||||
" CONSTRAINT "
|
||||
(gensym "c-")
|
||||
(gensym "max_")
|
||||
" CHECK ("
|
||||
(:name (:attrs property))
|
||||
" < "
|
||||
|
|
@ -92,7 +82,7 @@
|
|||
(:minimum (:attrs typedef))
|
||||
(str
|
||||
" CONSTRAINT "
|
||||
(gensym "c-")
|
||||
(gensym "min_")
|
||||
" CHECK ("
|
||||
(:minimum (:attrs typedef))
|
||||
" < "
|
||||
|
|
@ -154,15 +144,35 @@
|
|||
(:DELETE :ALL) #{"all"})
|
||||
group-names
|
||||
(set
|
||||
(remove
|
||||
nil?
|
||||
(map
|
||||
#(if (selector (:permission (:attrs %)))
|
||||
(:group (:attrs %)))
|
||||
permissions)))]
|
||||
(remove
|
||||
nil?
|
||||
(map
|
||||
#(if (selector (:permission (:attrs %)))
|
||||
(safe-name (:group (:attrs %)) :sql))
|
||||
permissions)))]
|
||||
(if
|
||||
(not (empty? group-names))
|
||||
(s/join " " (list "GRANT" (name privilege) "ON" table-name "TO" (s/join ",\n\t" (sort group-names)) ";")))))
|
||||
(s/join
|
||||
" "
|
||||
(list
|
||||
"GRANT"
|
||||
(name privilege)
|
||||
"ON"
|
||||
(safe-name table-name :sql)
|
||||
"TO"
|
||||
(s/join
|
||||
",\n\t"
|
||||
(sort group-names))
|
||||
";")))))
|
||||
|
||||
|
||||
(defn field-name
|
||||
[property]
|
||||
(safe-name
|
||||
(or
|
||||
(:column (:attrs property))
|
||||
(:name (:attrs property)))
|
||||
:sql))
|
||||
|
||||
|
||||
(defn emit-property
|
||||
|
|
@ -181,9 +191,17 @@
|
|||
(flatten
|
||||
(list
|
||||
"\t"
|
||||
(:name (:attrs property))
|
||||
(field-name property)
|
||||
(emit-field-type property entity application key?)
|
||||
(if default (list "DEFAULT" default))
|
||||
(if
|
||||
default
|
||||
(list
|
||||
"DEFAULT"
|
||||
(if
|
||||
(is-quotable-type? property application)
|
||||
(str "'" default "'") ;; TODO: but if the default value seems to be a function invocation, should it be quoted?
|
||||
;; it's quite common for 'now()' to be the default for a date, time or timestamp field.
|
||||
default)))
|
||||
(if
|
||||
key?
|
||||
"NOT NULL PRIMARY KEY"
|
||||
|
|
@ -203,7 +221,7 @@
|
|||
(if
|
||||
(= (:type (:attrs f)) "entity")
|
||||
(compose-convenience-entity-field f farside application)
|
||||
(str (:table (:attrs farside)) "." (:name (:attrs f)))))
|
||||
(str (safe-name (:table (:attrs farside))) "." (field-name f))))
|
||||
(user-distinct-properties farside)))))
|
||||
|
||||
|
||||
|
|
@ -213,7 +231,7 @@
|
|||
nil?
|
||||
(flatten
|
||||
(cons
|
||||
(:name (:attrs entity))
|
||||
(safe-name (:table (:attrs entity)) :sql)
|
||||
(map
|
||||
(fn [f]
|
||||
(if
|
||||
|
|
@ -242,13 +260,13 @@
|
|||
(let [farside (entity-for-property f application)]
|
||||
(cons
|
||||
(str
|
||||
(:table (:attrs entity))
|
||||
(safe-name (:table (:attrs entity)) :sql)
|
||||
"."
|
||||
(:name (:attrs f))
|
||||
(field-name f)
|
||||
" = "
|
||||
(:table (:attrs farside))
|
||||
(safe-name (:table (:attrs farside)) :sql)
|
||||
"."
|
||||
(first (key-names farside)))
|
||||
(safe-name (first (key-names farside)) :sql))
|
||||
#(compose-convenience-where-clause farside application false)))))
|
||||
(if
|
||||
top-level?
|
||||
|
|
@ -260,17 +278,17 @@
|
|||
[field entity application]
|
||||
(str
|
||||
(s/join
|
||||
" |', '| "
|
||||
" ||', '|| "
|
||||
(compose-convenience-entity-field field entity application))
|
||||
" AS "
|
||||
(:name (:attrs field))))
|
||||
(field-name field)))
|
||||
|
||||
|
||||
(defn emit-convenience-view
|
||||
"Emit a convenience view of this `entity` of this `application` for use in generating lists,
|
||||
menus, et cetera."
|
||||
[entity application]
|
||||
(let [view-name (str "lv_" (:table (:attrs entity)))
|
||||
(let [view-name (safe-name (str "lv_" (:table (:attrs entity))) :sql)
|
||||
entity-fields (filter
|
||||
#(= (:type (:attrs %)) "entity")
|
||||
(properties entity))]
|
||||
|
|
@ -294,12 +312,12 @@
|
|||
#(if
|
||||
(= (:type (:attrs %)) "entity")
|
||||
(emit-convenience-entity-field % entity application)
|
||||
(:name (:attrs %)))
|
||||
(str (safe-name entity) "." (field-name %)))
|
||||
(filter
|
||||
#(and (= (:tag %) :property) (not (= (:type (:attrs %)) "link")))
|
||||
#(not (= (:type (:attrs %)) "link"))
|
||||
(all-properties entity) ))))
|
||||
(str
|
||||
"FROM " (s/join ", " (compose-convenience-view-select-list entity application true)))
|
||||
"FROM " (s/join ", " (set (compose-convenience-view-select-list entity application true))))
|
||||
(if
|
||||
(not (empty? entity-fields))
|
||||
(str
|
||||
|
|
@ -315,13 +333,13 @@
|
|||
(entity? %)
|
||||
(= (:name (:attrs %)) (:entity (:attrs f)))))]
|
||||
(str
|
||||
(:table (:attrs entity))
|
||||
(safe-name (:table (:attrs entity)) :sql)
|
||||
"."
|
||||
(:name (:attrs f))
|
||||
(field-name f)
|
||||
" = "
|
||||
(:table (:attrs farside))
|
||||
(safe-name (:table (:attrs farside)) :sql)
|
||||
"."
|
||||
(first (key-names farside)))))
|
||||
(safe-name (first (key-names farside)) :sql))))
|
||||
entity-fields))))
|
||||
";"
|
||||
(emit-permissions-grant view-name :SELECT (permissions entity application))))))))
|
||||
|
|
@ -335,14 +353,15 @@
|
|||
" "
|
||||
(list
|
||||
"ALTER TABLE"
|
||||
(:name (:attrs nearside))
|
||||
(safe-name (:name (:attrs nearside)) :sql)
|
||||
"ADD CONSTRAINT"
|
||||
(str "ri_" (:name (:attrs nearside)) "_" (:name (:attrs property)))
|
||||
(safe-name (str "ri_" (:name (:attrs nearside)) "_" (:name (:attrs farside)) "_" (:name (:attrs property))) :sql)
|
||||
"\n\tFOREIGN KEY("
|
||||
(:name (:attrs property))
|
||||
(field-name property)
|
||||
") \n\tREFERENCES"
|
||||
(str
|
||||
(:table (:attrs farside)) "(" (:name (:attrs (first (key-properties farside)))) ")")
|
||||
(safe-name (:table (:attrs farside)) :sql)
|
||||
"(" (field-name (first (key-properties farside))) ")")
|
||||
;; TODO: ought to handle the `cascade` attribute, even though it's rarely used
|
||||
"\n\tON DELETE"
|
||||
(case
|
||||
|
|
@ -366,7 +385,7 @@
|
|||
(list
|
||||
(emit-header
|
||||
"--"
|
||||
(str "--\treferential integrity links for first-class tables"))
|
||||
"referential integrity links for primary tables")
|
||||
(map
|
||||
#(emit-referential-integrity-links % application)
|
||||
(sort-by-name (children-with-tag application :entity)))))))
|
||||
|
|
@ -374,7 +393,7 @@
|
|||
|
||||
(defn emit-table
|
||||
([entity application doc-comment]
|
||||
(let [table-name (:table (:attrs entity))
|
||||
(let [table-name (safe-name (:table (:attrs entity)) :sql)
|
||||
permissions (children-with-tag entity :permission)]
|
||||
(s/join
|
||||
"\n"
|
||||
|
|
@ -424,12 +443,11 @@
|
|||
(defn construct-link-property
|
||||
[entity]
|
||||
{:tag :property
|
||||
:attrs {:name (str (:name (:attrs entity)) "_id")
|
||||
:column (str (:name (:attrs entity)) "_id")
|
||||
:attrs {:name (safe-name (str (:name (:attrs entity)) "_id") :sql)
|
||||
:column (safe-name (str (:name (:attrs entity)) "_id") :sql)
|
||||
:type "entity"
|
||||
:entity (:name (:attrs entity))
|
||||
:farkey (first (key-names entity))}
|
||||
:content nil})
|
||||
:farkey (safe-name (first (key-names entity)) :sql)}})
|
||||
|
||||
|
||||
(defn emit-link-table
|
||||
|
|
@ -489,21 +507,13 @@
|
|||
(sort-by-name (children-with-tag application :entity)))))
|
||||
|
||||
|
||||
(defn emit-entity
|
||||
[entity application]
|
||||
(doall
|
||||
(list
|
||||
(emit-table entity application)
|
||||
(emit-convenience-view entity application))))
|
||||
|
||||
|
||||
(defn emit-group-declaration
|
||||
[group application]
|
||||
(list
|
||||
(emit-header
|
||||
"--"
|
||||
(str "security group " (:name (:attrs group))))
|
||||
(str "CREATE GROUP " (:name (:attrs group)) ";")))
|
||||
(str "CREATE GROUP " (safe-name (:name (:attrs group)) :sql) ";")))
|
||||
|
||||
|
||||
(defn emit-file-header
|
||||
|
|
@ -535,7 +545,11 @@
|
|||
(sort-by-name
|
||||
(children-with-tag application :group)))
|
||||
(map
|
||||
#(emit-entity % application)
|
||||
#(emit-table % application)
|
||||
(sort-by-name
|
||||
(children-with-tag application :entity)))
|
||||
(map
|
||||
#(emit-convenience-view % application)
|
||||
(sort-by-name
|
||||
(children-with-tag application :entity)))
|
||||
(emit-referential-integrity-links application)
|
||||
|
|
|
|||
|
|
@ -44,12 +44,12 @@
|
|||
(f/unparse (f/formatters :basic-date-time) (t/now)))
|
||||
(list
|
||||
:require
|
||||
'[clojure.java.io :as io]
|
||||
'[compojure.core :refer [defroutes GET POST]]
|
||||
'[hugsql.core :as hugsql]
|
||||
'[noir.response :as nresponse]
|
||||
'[noir.util.route :as route]
|
||||
'[compojure.core :refer [defroutes GET POST]]
|
||||
'[ring.util.http-response :as response]
|
||||
'[clojure.java.io :as io]
|
||||
'[hugsql.core :as hugsql]
|
||||
(vector (symbol (str (:name (:attrs application)) ".layout")) :as 'l)
|
||||
(vector (symbol (str (:name (:attrs application)) ".db.core")) :as 'db)
|
||||
(vector (symbol (str (:name (:attrs application)) ".routes.manual")) :as 'm))))
|
||||
|
|
@ -78,11 +78,25 @@
|
|||
:list
|
||||
{:records
|
||||
(list
|
||||
(symbol
|
||||
(str
|
||||
"db/search-strings-"
|
||||
(singularise (:name (:attrs e)))))
|
||||
'p)})))))))
|
||||
'if
|
||||
(list
|
||||
'not
|
||||
(list
|
||||
'empty?
|
||||
(list 'remove 'nil? (list 'vals 'p))))
|
||||
(list
|
||||
(symbol
|
||||
(str
|
||||
"db/search-strings-"
|
||||
(singularise (:name (:attrs e)))))
|
||||
(symbol "db/*db*")
|
||||
'p)
|
||||
(list
|
||||
(symbol
|
||||
(str
|
||||
"db/list-"
|
||||
(:name (:attrs e))))
|
||||
(symbol "db/*db*") {}))})))))))
|
||||
|
||||
(defn make-route
|
||||
"Make a route for method `m` to request the resource with name `n`."
|
||||
|
|
|
|||
|
|
@ -422,7 +422,7 @@
|
|||
[list-spec entity application]
|
||||
{:tag :tbody
|
||||
:content
|
||||
["{% for record in %records% %}"
|
||||
["{% for record in records %}"
|
||||
{:tag :tr
|
||||
:content
|
||||
(apply
|
||||
|
|
@ -438,7 +438,6 @@
|
|||
:attrs
|
||||
{:href
|
||||
(str
|
||||
"{{servlet-context}}/"
|
||||
(editor-name entity application)
|
||||
"?"
|
||||
(s/join
|
||||
|
|
@ -480,7 +479,7 @@
|
|||
(list-page-control true)]})
|
||||
|
||||
|
||||
(defn- list-to-template
|
||||
(defn list-to-template
|
||||
"Generate a template as specified by this `list` element for this `entity`,
|
||||
taken from this `application`. If `list` is nill, generate a default list
|
||||
template for the entity."
|
||||
|
|
@ -502,9 +501,9 @@
|
|||
`entity` in this `application`"
|
||||
[entity application]
|
||||
(let
|
||||
[forms (children entity #(= (:tag %) :form))
|
||||
pages (children entity #(= (:tag %) :page))
|
||||
lists (children entity #(= (:tag %) :list))]
|
||||
[forms (children-with-tag entity :form)
|
||||
pages (children-with-tag entity :page)
|
||||
lists (children-with-tag entity :list)]
|
||||
(if
|
||||
(and
|
||||
(= (:tag entity) :entity) ;; it seems to be an ADL entity
|
||||
|
|
|
|||
|
|
@ -39,6 +39,12 @@
|
|||
"resources/auto/")
|
||||
|
||||
|
||||
(defn element?
|
||||
"True if `o` is a Clojure representation of an XML element."
|
||||
[o]
|
||||
(and (map? o) (:tag o) (:attrs o)))
|
||||
|
||||
|
||||
(defn wrap-lines
|
||||
"Wrap lines in this `text` to this `width`; return a list of lines."
|
||||
;; Shamelessly adapted from https://www.rosettacode.org/wiki/Word_wrap#Clojure
|
||||
|
|
@ -73,6 +79,11 @@
|
|||
comment-rule)))
|
||||
|
||||
|
||||
(defn sort-by-name
|
||||
[elements]
|
||||
(sort #(compare (:name (:attrs %1)) (:name (:attrs %2))) elements))
|
||||
|
||||
|
||||
(defn link-table-name
|
||||
"Canonical name of a link table between entity `e1` and entity `e2`."
|
||||
[e1 e2]
|
||||
|
|
@ -249,24 +260,25 @@
|
|||
|
||||
|
||||
(defn safe-name
|
||||
([string]
|
||||
(s/replace string #"[^a-zA-Z0-9-]" ""))
|
||||
([string convention]
|
||||
(case convention
|
||||
(:sql :c) (s/replace string #"[^a-zA-Z0-9_]" "_")
|
||||
:c-sharp (s/replace (capitalise string) #"[^a-zA-Z0-9]" "")
|
||||
:java (let
|
||||
[camel (s/replace (capitalise string) #"[^a-zA-Z0-9]" "")]
|
||||
(apply str (cons (Character/toUpperCase (first camel)) (rest camel))))
|
||||
(safe-name string))))
|
||||
|
||||
|
||||
(defn link-table?
|
||||
"Return true if this `entity` represents a link table."
|
||||
[entity]
|
||||
(let [properties (children entity #(= (:tag %) :property))
|
||||
links (filter #(-> % :attrs :entity) properties)]
|
||||
(= (count properties) (count links))))
|
||||
"Return a safe name for the object `o`, given the specified `convention`.
|
||||
`o` is expected to be either a string or an entity."
|
||||
([o]
|
||||
(if
|
||||
(element? o)
|
||||
(safe-name (:name (:attrs o)))
|
||||
(s/replace (str o) #"[^a-zA-Z0-9-]" "")))
|
||||
([o convention]
|
||||
(if
|
||||
(element? o)
|
||||
(safe-name (:name (:attrs o)) convention)
|
||||
(let [string (str o)]
|
||||
(case convention
|
||||
(:sql :c) (s/replace string #"[^a-zA-Z0-9_]" "_")
|
||||
:c-sharp (s/replace (capitalise string) #"[^a-zA-Z0-9]" "")
|
||||
:java (let
|
||||
[camel (s/replace (capitalise string) #"[^a-zA-Z0-9]" "")]
|
||||
(apply str (cons (Character/toLowerCase (first camel)) (rest camel))))
|
||||
(safe-name string))))))
|
||||
|
||||
|
||||
(defn read-adl [url]
|
||||
|
|
@ -351,6 +363,14 @@
|
|||
`(filter insertable? (key-properties entity)))
|
||||
|
||||
|
||||
(defn link-table?
|
||||
"Return true if this `entity` represents a link table."
|
||||
[entity]
|
||||
(let [properties (all-properties entity)
|
||||
links (filter #(-> % :attrs :entity) properties)]
|
||||
(= (count properties) (count links))))
|
||||
|
||||
|
||||
(defn key-names [entity]
|
||||
(remove
|
||||
nil?
|
||||
|
|
@ -359,6 +379,37 @@
|
|||
(key-properties entity))))
|
||||
|
||||
|
||||
(defn base-type
|
||||
[property application]
|
||||
(cond
|
||||
(:typedef (:attrs property))
|
||||
(:type
|
||||
(:attrs
|
||||
(child
|
||||
application
|
||||
#(and
|
||||
(= (:tag %) :typedef)
|
||||
(= (:name (:attrs %)) (:typedef (:attrs property)))))))
|
||||
(:entity (:attrs property))
|
||||
(:type
|
||||
(:attrs
|
||||
(first
|
||||
(key-properties
|
||||
(child
|
||||
application
|
||||
#(and
|
||||
(= (:tag %) :entity)
|
||||
(= (:name (:attrs %)) (:entity (:attrs property)))))))))
|
||||
true
|
||||
(:type (:attrs property))))
|
||||
|
||||
|
||||
(defn is-quotable-type?
|
||||
"True if the value for this field should be quoted."
|
||||
[property application]
|
||||
(#{"date" "image" "string" "text" "time" "timestamp" "uploadable"} (base-type property application)))
|
||||
|
||||
|
||||
(defn has-primary-key? [entity]
|
||||
(> (count (key-names entity)) 0))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue