REBOL [
Title: "Schema Handler for MySQL"
Date: 5-Aug-2012
Author: "Christopher Ross-Gill"
Type: 'module
Exports: [
load-schema
analyse-schema
apply-schema
]
]
map: func [series [any-block! port!] action [any-function!] /only /copy /local new][
if copy [series: system/words/copy/deep series]
while [not tail? series][
series: either only [
change/part/only series action series/1 1
][
change/part series action series/1 1
]
]
head series
]
assert-all: func [[throw] cases [block!] /local value][
until [
set [value cases] do/next cases
unless value cases/1
cases: next cases
any [not value tail? cases]
]
any [value]
]
load-schema: use [parse-schema result database table field view queries to-parse-set][
to-parse-set: func [block [block!]][
block: copy block
remove head forskip block 2 [insert block '|]
]
result: context [
out: copy []
position: database: table: view: field: query: none
add: func [name [set-word!] 'type [word!]][
name: to-word name
switch type compose/deep [
database [
position: form name
append out name
append out database: context [
name: (to-lit-word name)
tables: copy []
views: copy []
options: copy []
]
database
]
table [
position: rejoin [form database/name "/" name]
append database/tables name
append database/tables table: context [
name: (to-lit-word name)
fields: copy []
options: copy []
primary: none
indices: copy []
parent: :database
]
table
]
field [
position: rejoin [form database/name "/" table/name "/" name]
append table/fields name
append table/fields field: context [
name: (to-lit-word name)
type: rel: width: required: default: increment: none
parent: :table
]
field
]
view [
position: rejoin [form database/name "/" name]
append database/views name
append database/views view: context [
name: (to-lit-word name)
tables: copy []
fields: copy []
expressions: none
order: direction: none
parent: :database
]
view
]
]
]
return: has [rel][
foreach [name database] out [
foreach [name table] database/tables [
foreach [name field] table/fields [
if rel: field/rel [
unless rel: all [
find out/(database/name)/tables rel/1
find out/(database/name)/tables/(rel/1)/fields rel/2
out/(database/name)/tables/(rel/1)/fields/(rel/2)
][throw make error! join "Could Not Find Relation: " [field/rel/1 "/" field/rel/2]]
field/type: rel/type
field/width: rel/width
]
]
]
]
out
]
reset: does [
out: clear out
database: table: view: field: query: none
position: "!START!"
self
]
]
database: use [name rule this][
rule: [
into [some [table | view]]
]
database: [
set name set-word! 'database
(bind rule this: result/add name database)
rule
]
]
table: use [name rule this][
rule: [
into [some field]
]
table: [
set name set-word! 'table
(bind rule this: result/add name table)
rule
]
]
field: use [name rule this string binary date logic integer decimal][
integer: ['integer!]
decimal: ['decimal!]
logic: ['logic!]
string: ['string!]
binary: ['block! | 'binary! | 'email! | 'url! | 'tuple! | 'issue!]
date: ['date!]
rule: [
set required opt 'opt (required: required <> 'opt)
[
[
set type integer set width integer!
| set type [decimal | logic (required: true) | date]
| set type string set width opt [integer! | into [some string!]]
| set type binary set width opt integer!
] (type: get :type)
| set rel [get-word! | into [get-word! word!]] (
case [
get-word? rel [rel: to-path reduce [to-word rel 'id]]
any-block? rel [rel: to-path reduce [to-word rel/1 to-word rel/2]]
]
)
]
any [
'primary (parent/primary: name)
| 'index (append parent/indices name)
| 'increment (increment: true)
| 'init set default any-type! (
unless type = type? default [
throw make error! rejoin [
"Default Value Does Not Match Field Type: "
parent/parent/name "/" parent/name "/" name
]
]
)
]
]
field: [
set name set-word!
(bind rule this: result/add name field)
rule
]
]
view: use [name rule this][
rule: [into queries]
view: [
set name set-word! 'view
(bind rule this: result/add name view)
rule
]
]
queries: use [expression rule term table fieldset ops mk ex][
ops: to-parse-set map ["<>" "<" ">" ">=" "<="] :to-lit-word
wrap: use [ex][
[ex: (mk: change/part/only mk to-paren copy/part mk ex ex) :mk]
]
expression: [
mk: 'find into [some string! | some integer!] [word! | into [word! word!]] wrap
|
[word! | path!] ['= | ops] [
[word! | path!]
| integer! | decimal! | logic! | string! | date!
| block! | binary! | email! | url! | tuple! | issue!
] wrap
|
['all | 'any] into [some expression]
]
rule: [
(result/position: rejoin [form result/database/name "/" result/view/name " Query Start"])
[
some [
set term set-word!
set table word!
set fieldset ['* | into [some word!]]
(
repend tables [term table]
foreach field envelop fieldset [
append/only fields to-path new-line/all reduce [term: to-word term field] false
]
)
]
|
set table word!
set fieldset ['* | into [some word!]]
(
append tables table
append fields fieldset
)
]
(result/position: rejoin [form result/database/name "/" result/view/name " Query Clause"])
'where copy expressions expression
(result/position: rejoin [form result/database/name "/" result/view/name " Query Order"])
opt [
['order | into ['order set direction ['ascending | 'descending]]]
copy order some [word! | into [word! word!]]
]
]
queries: [
'select
(bind rule result/view)
into rule
]
]
parse-schema: func [
[catch]
schema [block!]
/local table field
][
result/reset
either parse schema [
object!
some database
to end
][
result/return
][
throw make error! join "Unable to Parse Schema at: " result/position
]
]
load-schema: func [
[catch]
schema [file! url! string! block! none!]
][
case/all [
any [file? schema url? schema][
schema: assert-all [
exists? schema [
throw make error! "Unable to Locate Schema"
]
attempt [load/header schema][
throw make error! "Schema does not contain header"
]
]
]
string? schema [
unless schema: attempt [load/header schema][
throw make error! "Schema does not contain header"
]
]
block? schema [
unless schema: all [
object? pick schema 1
in schema/1 'type
schema/1/type = 'schema
schema
][
throw make error! "Not marked as Schema data"
]
]
not block? schema [throw make error! "Unknown Schema Error"]
]
throw-on-error [parse-schema schema]
]
]