REBOL [
Title: "SQL PROTOCOL"
Date: 05-Mar-2006
Author: ["Marco"]
Version: 0.6.8
Email: [mvri@bluewin.ch]
File: %sql-protocol.r
Category: [database]
Library: [
level: 'intermediate
platform: 'all
type: [dialect protocol tool]
domain: [database dialects protocol scheme sql]
tested-under: [win]
support: mvri@bluewin.ch
license: 'public-domain
see-also: none
]
Purpose: {
SQL-PROTOCOL is a SQL Relationnal Database Management System (RDBMS) entirely written in REBOL
with JOIN and SORT capability. This allow you having an easy to use lightweight database engine embeded
in your REBOL application.
Today, sql-protocol execute only these kind of query :
* SELECT ... FROM ... WHERE ... ORDER BY ...
* INSERT ... INTO ... VALUES ...
* UPDATE ... SET ... WHERE ...
* DELETE FROM ... WHERE ...
* CREATE TABLE ...
* DROP TABLE ...
Query can be submited either as a standard SQL query string or as a SQL like query dialect block.
* by using SQL query string you will have a better compatibility with other database system like MySQL, Oracle or DB2.
* by using SQL query dialect you will get advantage of REBOL scripting facility.
This quick example illustrates how to load the protocol, open a database,
select some rows from two tables, probe the result and close the database.
Using standard SQL query string :
do %sql-protocol.r
db: open sql:my-db
insert db {
SELECT * FROM a, b
WHERE a.c2 = b.c1 AND a.c1 = 1
ORDER BY 1, 2 DESC
}
foreach item copy db [probe item]
close db
The same using the SQL dialect :
do %sql-protocol.r
db: open sql:my-db
insert db [
SELECT * FROM a b
WHERE a.c2 = b.c1 AND a.c1 = 1
ORDER BY 1 [2 DESC]
]
foreach item copy db [probe item]
close db
Moreover, sql-protocol provide a basic compabibility with the ODBC text driver {Microsoft text driver (*.csv,*.txt)}
in order to provide a quick and simple way to share data between REBOL application and any ODBC application,
for example, MS Excel to produce table or chart,or MS Word to produce letters or mailing.
sql-protocol provide also a set of file protocol which can be used directly in your script :
DATA: - text file containing a REBOL block for each row
HEAP: - same as DATA but for transient table (in memory table)
CSV: - delimited file by any caracter except doublequote ("), newline (^/) or linefeed (^M).
}
Comment: {
This script includes some elements inspired from Logan
This script is also inspired by ODBC and MySQL
Many thanks to Christophe for the Rebol Unit tool that I use to test each version of sql-protocol.
Many thanks to Robert for the Make Doc Pro tool that I use to produce the documentation of sql-protocol.
}
Usage: {
Columns id must be either table-name.column-name or row/index
Table & Alias couple must be placed in a block
Columns & Asc | Desc couple must be placed in a block
Sample for persistent dababase :
--------------------------------
do %sql-protocol.r
db: open sql:my-db
insert db [CREATE TABLE a [c1 c2 c3] IF NOT EXISTS]
insert db [CREATE TABLE b [c1 c2] IF NOT EXISTS]
insert db [CREATE TABLE c [c1 c2 c3] TYPE = HEAP]
insert db [CREATE TABLE d [c1 c2 c3] TYPE = [CSV ColNameHeader: false format: 'Delimited delimited: ";"]
insert db [INSERT INTO a VALUES
[1 2 3]
[1 2 4]
[2 3 4]
[3 4 5]
]
insert db [INSERT INTO b VALUES
[1 "x"]
[2 "y"]
]
repeat i 100 [insert db compose/deep [INSERT INTO c VALUES [(i) (i + 1) (i + 2)]]]
insert db [SELECT DISTINCT * a.c2 FROM a [b b1]
WHERE a.c2 = b1.c1 AND a.c1 = 1
ORDER BY 1 [2 DESC]
]
foreach item copy db [probe item]
insert db [UPDATE c SET c1: 1 WHERE c1 > 50]
insert db [DELETE FROM c WHERE c1 >= 2]
insert db [DROP TABLE a]
close db
}
History: [
0.0.1 [15-Sep-2004 {Initial alpha version} marco@adyreb.org]
0.1.0 [28-Sep-2004 {Change in provision of SQl protocol - DATA: protocol & database object} marco@adyreb.org]
0.2.0 [13-Oct-2004 {First beta published on www.rebol.org} marco@adyreb.org]
0.3.0 [11-Nov-2004 {Add CSV protocol, change on DATA protocol and preparation to FIXED protocol} marco@adyreb.org]
0.4.0 [14-Dec-2004 {Implement new schema.ctl and extend TYPE = clause} marco@adyreb.org]
0.5.0 [17-Jan-2005 {Alpha version published on www.rebol.org} marco@adyreb.org]
0.6.0 [17-Jan-2005 {More flexible SQL dialect (FROM clause)} marco@adyreb.org]
0.6.1 [16-Mar-2005 {More flexible SQL dialect (columns, WHERE and ORDER BY clause)} marco@adyreb.org]
0.6.2 [29-Mar-2005 {Extends test case} marco@adyreb.org]
0.6.3 [11-May-2005 {End of extended test and publication to library} marco@adyreb.org]
0.6.4 [02-Feb-2006 {Add LIKE clause + some bug correction} marco@adyreb.org]
0.6.5 [05-Feb-2006 {First attempt of SQL string parsing for SELECT + some bug correction} marco@adyreb.org]
0.6.6 [07-Feb-2006 {Correction of a bug when using word in the SQL dialect} marco@adyreb.org]
0.6.7 [08-Feb-2006 {Improvement of word handling in dialect} marco@adyreb.org]
0.6.8 [05-Mar-2006 {Implement SQL parsing for INSERT, UPDATE & DELETE clauses} marco@adyreb.org]
]
to-do: [
{Implement /new when openning sql protocol and throw an error fr all other refinements}
{Implement directory mngt for sql protocol}
{implement FixedLength file (FIXED protocol)}
{More and more, improve performance and simplify the script}
]
]
; *******************************************************************
; protocol utilities
; *******************************************************************
; -----------------
; Word redefinition
; -----------------
; These words are redefined because
; - either they are functions redefined for the protocol handler
; - or they are used as refinement within functions of thze protocol handler
all*: get in system/words 'all
any*: get in system/words 'any
change*: get in system/words 'change
close*: get in system/words 'close
copy*: get in system/words 'copy
find*: get in system/words 'find
get-modes*: get in system/words 'get-modes
insert*: get in system/words 'insert
open*: get in system/words 'open
pick*: get in system/words 'pick
poke*: get in system/words 'poke
query*: get in system/words 'query
remove*: get in system/words 'remove
update*: get in system/words 'update
skip*: get in system/words 'skip
select*: get in system/words 'select
sort*: get in system/words 'sort
set-modes*: get in system/words 'set-modes
; -----------------------
; port flags redefinition
; -----------------------
; These are the values I could find, but some are misssing
system/standard/port-flags: make system/standard/port-flags [
read: to-integer power 2 0
write: to-integer power 2 1
append: to-integer power 2 2
new: to-integer power 2 3
flag-4: to-integer power 2 4
binary: to-integer power 2 5
lines: to-integer power 2 6
flag-7: to-integer power 2 7
with: to-integer power 2 8
opened: to-integer power 2 9
closed: to-integer power 2 10
wait: to-integer power 2 11
flag-12: to-integer power 2 12
eof: to-integer power 2 13
async: to-integer power 2 14
flag-15: to-integer power 2 15
flag-16: to-integer power 2 16
changed: to-integer power 2 17
updated: to-integer power 2 18
direct: to-integer power 2 19
flag-20: to-integer power 2 20
custom: to-integer power 2 21
pass-thru: to-integer power 2 22
flag-23: to-integer power 2 23
seek: to-integer power 2 24
skip: to-integer power 2 25
flag-26: to-integer power 2 26
flag-27: to-integer power 2 27
allow-read: to-integer power 2 28
allow-write: to-integer power 2 29
flag-30: to-integer power 2 30
flag-31: to-integer -1
]
; --------------------
; throw-error function
; --------------------
throw-error: func [
[throw]
"Throw an error base on err parms"
err [error! block! object!]
][
either error? err [
err: disarm err
][
err: make error-object err
]
throw make error! reduce bind [type id arg1 arg2 arg3 near where] in err 'self
]
; -----------------------
; to-record function
; -----------------------
to-record: func [
value
only
/local data item rule out-data sub-data
][
parse data: copy/deep value rule: [
any [
s: set item word! (either value? item [
change/only s get item
][
s: next s
]) :s
|
into rule
|
skip
]
]
either all [
not only
parse data [any [block!]]
][
data
][
reduce [data]
]
]
; *******************************************************************
; Base data protocol handler
; *******************************************************************
base-protocol: context [
; ------------------
; BASE Close handler
; ------------------
close: func [
{Close sub-port}
port [port!] "An open port spec"
][
net-utils/net-log reduce ["Closing port for" to-string port/scheme]
if port? port/sub-port [
close* port/sub-port
]
port
]
; -------------------
; BASE Update handler
; -------------------
update: func [
{Update sub-port}
port [port!] "An open port spec"
][
net-utils/net-log reduce ["Updating port for" to-string port/scheme]
if port? port/sub-port [
update* port/sub-port
]
port
]
; -----------------
; BASE Pick handler
; -----------------
pick: func [
"Pick operation."
port [port!] "An open port spec"
data "Index where to pick data"
/local buffer
][
net-utils/net-log ["Pick at " data "index"]
if none? data [data: 1]
buffer: at port/state/inBuffer index? port
pick* buffer data
]
; -----------------
; BASE Copy handler
; -----------------
copy: func [
"Copy operation."
port [port!] "An open port spec"
/local buffer
][
net-utils/net-log ["Copy of" port/scheme]
buffer: at port/state/inBuffer index? port
copy*/part buffer port/state/num
]
; ----------------------
; BASE get-modes handler
; ----------------------
get-modes: func [
port [port!] "An open port spec"
modes "A mode block"
][
get-modes* port
]
; ----------------------
; BASE set-modes handler
; ----------------------
set-modes: func [
port [port!] "An open port spec"
modes "A mode block"
][
set-modes* port
]
]
; *******************************************************************
; Default file handler (reused for data, csv and fixed protocol)
; *******************************************************************
file-handler: context [
; -----------------
; FILE Init handler
; -----------------
init: func [
port
spec
/local scheme file path target locals
][
net-utils/net-log reduce ["Initializing" to-string spec "for" to-string port/scheme]
if url? spec [
set [scheme target] parse/all spec ":"
spec: compose [scheme: (scheme) target: (target)]
]
spec: context spec
; ------------
; Manage shema
; ------------
if any [
none? locals: in spec 'schema
none? locals: get locals
][
locals: []
]
port/locals: make file-schema locals
; ----------------------------
; Manage file, path and target
; ----------------------------
target: to-file spec/target
if any [
none? path: in spec 'path
none? path: get path
][
either #"/" = first target [
path: %/.
][
path: %.
]
]
if #"/" <> first target [
path: dirize to-file path
]
set [path target] split-path file: join path spec/target
if none? target [target: %./]
if not any [
#"/" = last target
find target #"."
][
target: join target port/handler/file-extension port
]
port/path: clean-path path
port/target: target
if none? port/target [
net-error reform ["No target file for" port/scheme "is specified"]
]
]
; -----------------
; FILE Open handler
; -----------------
open: func [
{Open sub-port.}
port "Initalized port spec"
/local sub-port inBuffer file header delimiter cmd parms
][
net-utils/net-log reduce ["Opening port for" to-string port/scheme]
port/status: 'file
port/state/flags: port/state/flags and complement system/standard/port-flags/direct
port/state/flags: port/state/flags or system/standard/port-flags/lines
port/state/flags: port/state/flags or system/standard/port-flags/pass-thru
port/sub-port: make port! join port/path port/target
port/sub-port/state/flags: port/sub-port/state/flags or (port/state/flags and system/standard/port-flags/new)
either #"/" = last port/target [
open* port/sub-port
port/state/inBuffer: copy* port/sub-port
][
port/state/inBuffer: port/handler/read-sub-port port
]
port/state/tail: length? port/state/inBuffer
port
]
; ------------------
; FILE Close handler
; ------------------
close: func [
{Close sub-port}
port [port!] "An open port spec"
][
net-utils/net-log reduce ["Closing port for" to-string port/scheme]
if all [
not #"/" = last port/target
system/standard/port-flags/changed = (port/state/flags and system/standard/port-flags/changed)
][
port/handler/write-sub-port port
port/state/flags: port/state/flags and complement system/standard/port-flags/changed
]
close* port/sub-port
port
]
; -------------------
; FILE Update handler
; -------------------
update: func [
port [port!] "An open port spec"
][
net-utils/net-log reduce ["Updating port for" to-string port/scheme]
if all [
not #"/" = last port/target
system/standard/port-flags/changed = (port/state/flags and system/standard/port-flags/changed)
][
port/handler/write-sub-port port
port/state/flags: port/state/flags and complement system/standard/port-flags/changed
]
update* port/sub-port
port
]
; -----------------
; FILE Pick handler
; -----------------
pick: func [
"Pick operation."
port [port!] "An open port spec"
data "Index where to pick data"
/local buffer
][
net-utils/net-log ["Pick at " data "index"]
if none? data [data: 1]
buffer: at port/state/inBuffer index? port
pick* buffer data
]
; -----------------
; FILE Copy handler
; -----------------
copy: func [
"Copy operation."
port [port!] "An open port spec"
/local buffer
][
net-utils/net-log ["Copy of" port/scheme]
buffer: at port/state/inBuffer index? port
copy*/part buffer port/state/num
]
; -------------------
; FILE Insert handler
; -------------------
insert: func [
port [port!]
value
/part
range [number! series! port! pair!]
/only
/dup
count [number! pair!]
/local buffer cmd parms
][
net-utils/net-log ["Insert of " port/state/num "bytes"]
cmd: to-path 'insert*
parms: copy* []
if all [value? 'part part][append cmd 'part repend parms [range]]
if dup [append cmd 'dup repend parms [dup]]
either #"/" = last port/target [
buffer: at port/sub-port index? port
buffer: do compose [(cmd) buffer value (parms)]
][
value: to-record value only
buffer: at port/state/inBuffer index? port
buffer: do compose [(cmd) buffer value (parms)]
port/handler/insert-sub-port port value cmd parms
]
port/state/tail: length? head buffer
at port index? buffer
]
; -------------------
; FILE Change handler
; -------------------
change: func [
port [port!]
value
/part
range [number! series! port! pair!]
/only
/dup
count [number! pair!]
/local buffer cmd parms data
][
net-utils/net-log ["Change of " port/state/num "bytes"]
cmd: to-path 'change*
parms: copy* []
if part [append cmd 'part repend parms [range]]
if dup [append cmd 'dup repend parms [count]]
either #"/" = last port/target [
buffer: at port/sub-port index? port
buffer: do compose [(cmd) buffer value (parms)]
][
value: to-record value only
buffer: at port/state/inBuffer index? port
buffer: do compose [(cmd) buffer value (parms)]
port/handler/change-sub-port port value cmd parms
]
port/state/tail: length? head buffer
at port index? buffer
]
; -----------------
; FILE Sort handler
; -----------------
sort: func [
port [port!]
/case "Case sensitive sort."
/skip "Treat the series as records of fixed size."
size [integer!] "Size of each record."
/compare "Comparator offset, block or function."
comparator [integer! block! function!]
/part "Sort only part of a series."
length [integer!] "Length of series to sort."
/all "Compare all fields"
/reverse "Reverse sort order"
/local buffer cmd parms
][
net-utils/net-log ["Sort in" port/scheme]
cmd: to-path 'sort*
parms: copy* []
if skip [append cmd 'skip repend parms [size]]
if compare [append cmd 'compare repend parms [:comparator]]
if part [append cmd 'part repend parms [length]]
if all [append cmd 'all]
if reverse [append cmd 'reverse]
either #"/" = last port/target [
buffer: at port/sub-port index? port
buffer: do compose [(cmd) buffer value (parms)]
][
buffer: at port/state/inBuffer index? port
buffer: do compose [(cmd) buffer (parms)]
port/handler/sort-sub-port port cmd parms
]
port/state/tail: length? head buffer
at port index? buffer
]
; -----------------
; FILE Poke handler
; -----------------
poke: func [
port [port!]
index [number! logic! pair!]
value
/local buffer item
][
net-utils/net-log ["Pick at " data "index"]
either #"/" = last port/target [
buffer: at port/sub-port index? port
poke* buffer index value
][
buffer: at port/state/inBuffer index? port
buffer: poke* buffer index value
port/handler/poke-sub-port port index value
]
value
]
; -------------------
; FILE Remove handler
; -------------------
remove: func [
"Remove operation."
port [port!] "An open port spec"
/local buffer cmd parms
][
net-utils/net-log ["Remove of" port/scheme]
either #"/" = last port/target [
buffer: at port/sub-port index? port
buffer: remove*/part buffer port/state/num
][
buffer: at port/state/inBuffer index? port
remove*/part buffer port/state/num
remove-sub-port port
]
port/state/tail: length? head buffer
at port index? buffer
]
; ------------------
; FILE Query handler
; ------------------
query: func [
port [port!]
/clear
/local sub-port
][
net-utils/net-log ["query of " port/scheme]
sub-port: make port! rejoin [port/path port/target]
query* sub-port
port/status: sub-port/status
port/date: sub-port/date
port/size: sub-port/size
none
]
; ---------------------------
; FILE get-modes handler
; ---------------------------
get-modes: func [
port [port!] "An open port spec"
modes "A mode block"
][
get-modes* port
]
; ----------------------
; FILE set-modes handler
; ----------------------
set-modes: func [
port [port!] "An open port spec"
modes "A mode block"
][
set-modes* port
]
; ----------------------------
; FILE file-extension function
; ----------------------------
file-extension: func [
port [port!]
][
%.dat
]
; ----------------------------
; FILE file-schema function
; ----------------------------
file-schema: context [
format: none
cols: []
]
; --------------------
; FILE insert-sub-port
; --------------------
insert-sub-port: func [
port [port!]
value
cmd [path!]
parms [block!]
/local buffer result data
][
result: data: make block! length? value
foreach item value [
data: insert* data port/handler/to-sub-record port item
]
buffer: at port/sub-port index? port
buffer: do compose [(cmd) buffer result (parms)]
]
; --------------------
; FILE change-sub-port
; --------------------
change-sub-port: func [
port [port!]
value
cmd [path!]
parms [block!]
/local buffer result data
][
result: data: make block! length? value
foreach item value [
data: insert* data port/handler/to-sub-record port item
]
buffer: at port/sub-port index? port
buffer: do compose [(cmd) buffer result (parms)]
]
; ------------------
; FILE sort-sub-port
; ------------------
sort-sub-port: func [
port [port!]
cmd [path!]
parms [block!]
/local buffer
][
close* port/sub-port
buffer: open*/new/lines port/sub-port
foreach item port/state/inBuffer [
buffer: insert* buffer port/handler/to-sub-record port item
]
port/sub-port
]
; ------------------
; FILE poke-sub-port
; ------------------
poke-sub-port: func [
port [port!]
index [number! logic! pair!]
value
][
buffer: at port/sub-port index? port
buffer: poke* buffer index port/handler/to-sub-record port value
]
; --------------------
; FILE remove-sub-port
; --------------------
remove-sub-port: func [
port [port!]
][
buffer: at port/sub-port index? port
buffer: remove*/part buffer port/state/num
]
; --------------------------
; FILE Register the protocol
; --------------------------
; --> net-utils/net-install FILE self none
]
; *******************************************************************
; DELIMITED Protocol Handler
; *******************************************************************
make file-handler [
; ---------------------------------
; DELIMITED file-extension function
; ---------------------------------
file-extension: func [
port [port!]
][
switch port/locals/format [
Delimited %.txt
CSVDelimited %.csv
TABDelimited %.tab
]
""
]
; ---------------------------------
; DELIMITED file-delimiter function
; ---------------------------------
file-delimiter: func [
{Default file delimiter}
port [port!]
][
switch/default port/locals/format [
Delimited [";"]
CSVDelimited [","]
TABDelimited ["^-"]
][
";,^-"
]
]
; -----------------------------
; DELIMITED file-schema
; -----------------------------
file-schema: context [
ColNameHeader: false
format: 'Delimited
delimiter: none
max-scan-rows: 0
character-set: 'OEM
cols: none
]
; -----------------------
; DELIMITED Read sub-port
; -----------------------
read-sub-port: func [
port "Initalized port spec"
/local result line d m y v s e
end-of-line
quote-char
double-quote
end-of-line-set
digit-set
delimited-header-line
delimited-text-line
delimited-data
delimited-string
unquoted-string
quoted-string
number
exact-number
approximate-number
unsigned-integer
date
mm dd yy yyyy mmm
date-separator
delimited-null
current-delimiter
delimiter-set
character-set
][
net-utils/net-log reduce ["Reading sub-port for" to-string port/scheme]
; Basic char
; ----------
quote-char: {"}
digit-char: "0123456789"
end-of-line-char: "^/^M"
; Basic character set
; -------------------
end-of-line: [ "^/^M" | "^M" | "^/" ]
double-quote: rejoin [quote-char quote-char]
end-of-line-set: charset end-of-line-char
digit-set: charset digit-char
; Manage delimiter
; ----------------
current-delimiter: any [
port/locals/delimiter
port/handler/file-delimiter port
",;^-"
]
delimiter-set: charset current-delimiter
character-set: complement charset rejoin [current-delimiter quote-char end-of-line-char]
delimiter: [
copy d delimiter-set (
if none? port/locals/delimiter [
delimiter-set: charset port/locals/delimiter: d
character-set: complement charset rejoin [current-delimiter quote-char end-of-line-char]
]
)
]
; Manage file
; -----------
text-file: either port/locals/ColNameHeader [
[delimited-header-line any delimited-text-line]
][
[any delimited-text-line]
]
; Manage line
; -----------
delimited-header-line: [delimited-text-line (
if none? port/locals/cols [
port/locals/cols: copy* []
foreach item first result [
repend port/locals/cols [to-word item copy* []]
]
]
clear result
)]
delimited-text-line: [
end-of-line
|
(line: copy* [])
delimited-data
any [delimiter delimited-data]
end-of-line
(insert*/only tail result line)
]
; Manage data
; -----------
delimited-data: [[
date s: [delimiter | end-of-line] :s
|
number s: [delimiter | end-of-line] :s
|
delimited-string s: [delimiter | end-of-line] :s
|
delimited-null s: [delimiter | end-of-line] :s
] (append line v)]
; Manage date
; -----------
date: [[
copy d dd date-separator copy m [mm | mmm] date-separator copy y [yyyy | yy]
|
copy m mmm date-separator copy d dd date-separator copy y [yyyy | yy]
|
copy y yyyy date-separator copy m [mm | mmm] date-separator copy d dd
] (v: to-date rejoin [d "-" m "-" y])]
mm: [digit-set [digit-set | none]]
dd: [digit-set [digit-set | none]]
yy: [digit-set digit-set]
yyyy: [digit-set digit-set digit-set digit-set]
mmm: ["Jan" | "Feb" | "Mar" | "Apr" | "May" | "Jun" | "Jul" | "Aug" | "Sep" | "Oct" | "Nov" | "Dec"]
date-separator: [ "-" | "/" | "."]
; Manage number
; -------------
number: [approximate-number | exact-number]
approximate-number: [copy v [
["+" | "-" | none] [
unsigned-integer ["." unsigned-integer | none]
|
"." unsigned-integer
]["e" | "E"] ["+" | "-"] unsigned-integer
] (v: to-decimal v) ]
exact-number: [s:
["+" | "-" | none]
[
unsigned-integer "." [unsigned-integer | none] e: (v: to-decimal copy*/part s e)
|
"." unsigned-integer e: (v: to-decimal copy*/part s e)
|
unsigned-integer e: (v: to-integer copy*/part s e)
]
]
unsigned-integer: [some digit-set]
; Manage string
; -------------
delimited-string: [unquoted-string | quoted-string]
unquoted-string: [
s: character-set
any [character-set | quote-char]
e: (v: to-string copy*/part s e)
]
quoted-string: [
quote-char s:
any [character-set | delimiter-set | end-of-line-set | double-quote]
e: quote-char
(v: to-string copy*/part s e)
]
; Manage null value
; -----------------
delimited-null: [s: delimiter :s (v: none)] ; NULL is represented by no data between two delimiters.
either system/standard/port-flags/new =(port/state/flags and system/standard/port-flags/new) [
; port/state/flags: port/state/flags or system/standard/port-flags/changed
port/state/inBuffer: copy* []
write-sub-port port
port/state/inBuffer
][
open* port/sub-port
result: make block! 0
either parse/all copy* port/sub-port text-file [
port/state/inBuffer: result
][
make error! "Invalid CSV file"
]
]
]
; ----------------------
; DELIMITED Write record
; ----------------------
write-sub-port: func [
{Write the file.}
port "Initalized port spec"
/local line sep
][
net-utils/net-log reduce ["Writing records" to-string port/scheme]
if none? port/locals/delimiter [
port/locals/delimiter: port/handler/file-delimiter port
]
; clear head port/sub-port
attempt [close* port/sub-port]
open*/new port/sub-port
if port/locals/ColNameHeader [
line: clear []
sep: ""
foreach item port/locals/cols [
if block? item [
item: first item
]
item: to-string item
append line sep
append line item
sep: port/locals/delimiter
]
append port/sub-port line
append port/sub-port newline
]
foreach item head port/state/inBuffer [
line: clear []
sep: ""
foreach jtem item [
if none? find [integer! decimal! date! time!] type? jtem [
jtem: to-string jtem
jtem: replace/all to-string jtem {"} {""}
if any [
find* jtem {"}
find* jtem port/locals/delimiter
find* jtem {^/}
find* jtem {^M}
][
jtem: rejoin [{"} jtem {"}]
]
]
append line sep
append line jtem
sep: port/locals/delimiter
]
append port/sub-port line
append port/sub-port newline
]
]
; -------------------------
; DELIMITED insert-sub-port
; -------------------------
insert-sub-port: func [
port [port!]
value
cmd [path!]
parms [block!]
/local
][
port/state/flags: port/state/flags or system/standard/port-flags/changed
]
; -------------------------
; DELIMITED change-sub-port
; -------------------------
change-sub-port: func [
port [port!]
value
cmd [path!]
parms [block!]
/local
][
port/state/flags: port/state/flags or system/standard/port-flags/changed
]
; -------------------------
; DELIMITED sort-sub-port
; -------------------------
sort-sub-port: func [
port [port!]
cmd [path!]
parms [block!]
/local
][
port/state/flags: port/state/flags or system/standard/port-flags/changed
]
; -----------------------
; DELIMITED poke-sub-port
; -----------------------
poke-sub-port: func [
port [port!]
index [number! logic! pair!]
value
/local
][
port/state/flags: port/state/flags or system/standard/port-flags/changed
]
; -------------------------
; DELIMITED remove-sub-port
; -------------------------
remove-sub-port: func [
port [port!]
][
port/state/flags: port/state/flags or system/standard/port-flags/changed
]
; -------------------------------
; DELIMITED Register the protocol
; -------------------------------
net-utils/net-install CSV self none
]
; *******************************************************************
; DATA Protocol Handler
; *******************************************************************
make file-handler [
; ----------------------------
; DATA file-extension function
; ----------------------------
file-extension: func [
port [port!]
][
%.data
]
; -----------------------
; DATA Read sub-port
; -----------------------
read-sub-port: func [
port
/local result data sub-port
][
sub-port: open*/lines port/sub-port
port/state/inBuffer: data: make block! length? sub-port
while [not tail? sub-port][
data: insert*/only data load first sub-port
sub-port: next sub-port
]
port/state/inBuffer
]
; -----------------
; DATA Write record
; -----------------
write-sub-port: func [
{Write the file.}
port "Initalized port spec"
][
none
]
; ---------------------------
; DATA to-sub-record function
; ---------------------------
to-sub-record: func [
port [port!]
value
][
mold value
]
; --------------------------
; DATA Register the protocol
; --------------------------
net-utils/net-install DATA self none
]
; *******************************************************************
; HEAP Protocol Handler
; *******************************************************************
context [
root-heap: make block! 0
; -----------------
; HEAP Init handler
; -----------------
init: func [
"Parse URL and/or check the port spec object"
port "Unopened port spec"
spec {Argument passed to open or make (a URL or port-spec)}
/local scheme file path target locals
][
net-utils/net-log reduce ["Initializing" to-string spec "for" to-string port/scheme]
either url? spec [
set [scheme file] parse/all spec ":"
set [path target] split-path file: to-file file
if none? target [target: %./]
if not any [
#"/" = last target
find target #"."
][=
target: join target %.heap
]
port/path: clean-path to-rebol-file path
port/target: target
port/url: spec
][
spec: context spec
target: to-file spec/target
if any [
none? path: in spec 'path
none? path: get path
][
either #"/" = first target [
path: %/.
][
path: %.
]
]
path: dirize to-file path
set [path target] split-path file: join path target
if none? target [target: %./]
if not any [
#"/" = last target
find target #"."
][
target: join target %.heap
]
port/path: clean-path path
port/target: target
]
if none? port/target [
net-error reform ["No target file for" port/scheme "is specified"]
]
]
; -----------------
; HEAP Open handler
; -----------------
open: func [
{Open sub-port.}
port "Initalized port spec"
/local item file path new-flag
][
net-utils/net-log reduce ["Opening port for" to-string port/scheme]
port/status: 'file
port/state/flags: port/state/flags or system/standard/port-flags/lines
port/state/flags: port/state/flags or system/standard/port-flags/pass-thru
file: rejoin [port/path port/target]
new-flag: system/standard/port-flags/new = (system/standard/port-flags/new and port/state/flags)
either none? port/state/inBuffer: select-heap file root-heap [
either all [
#"/" = last port/target
not new-flag
][
throw-error [type: 'access id: 'cannot-open arg1: file]
][
port/state/inBuffer: insert-heap file root-heap
]
][
if new-flag [
either #"/" = last port/target [
throw-error [type: 'access id: 'cannot-open arg1: file]
][
clear port/state/inBuffer
]
]
]
if #"/" = last port/target [
port/state/inBuffer: extract port/locals: port/state/inBuffer 2
]
port/state/tail: length? port/state/inBuffer
port
]
; ------------------
; HEAP Close handler
; ------------------
close: func [
{Close sub-port}
port [port!] "An open port spec"
][
net-utils/net-log reduce ["Closing port for" to-string port/scheme]
port
]
; -------------------
; HEAP Update handler
; -------------------
update: func [
{Update sub-port}
port [port!] "An open port spec"
][
net-utils/net-log reduce ["Updating port for" to-string port/scheme]
port
]
; -----------------
; HEAP Pick handler
; -----------------
pick: func [
"Pick operation."
port [port!] "An open port spec"
data "Index where to pick data"
/local buffer
][
net-utils/net-log ["Pick at " data "index"]
if none? data [data: 1]
buffer: at port/state/inBuffer index? port
pick* buffer data
]
; -----------------
; HEAP Copy handler
; -----------------
copy: func [
"Copy operation."
port [port!] "An open port spec"
/local buffer
][
net-utils/net-log ["Copy of" port/scheme]
buffer: at port/state/inBuffer index? port
copy*/part buffer port/state/num
]
; -------------------
; HEAP Insert handler
; -------------------
insert: func [
port [port!]
value
/part
range [number! series! port! pair!]
/only
/dup
count [number! pair!]
/local buffer cmd parms
][
net-utils/net-log ["Insert of " port/state/num "bytes"]
cmd: to-path 'insert*
parms: copy* []
if all [value? 'part part][append cmd 'part repend parms [range]]
if dup [append cmd 'dup repend parms [dup]]
either #"/" = last port/target [
throw-error [type: 'script id: 'bad-port-action arg1: 'insert]
][
buffer: at port/state/inBuffer index? port
buffer: do compose [(cmd) buffer to-record value only (parms)]
]
port/state/tail: length? head buffer
at port index? buffer
]
; -------------------
; HEAP Change handler
; -------------------
change: func [
port [port!]
value
/part
range [number! series! port! pair!]
/only
/dup
count [number! pair!]
/local buffer cmd parms data
][
net-utils/net-log ["Change of " port/state/num "bytes"]
cmd: to-path 'change*
parms: copy* []
if part [append cmd 'part repend parms [range]]
if dup [append cmd 'dup repend parms [count]]
either #"/" = last port/target [
buffer: at port/locals (2 * index? port) - 1
change* buffer value
buffer: at port/state/inBuffer index? port
buffer: change* buffer value
][
buffer: at port/state/inBuffer index? port
buffer: do compose [(cmd) buffer to-record value only (parms)]
]
port/state/tail: length? head buffer
at port index? buffer
]
; -----------------
; HEAP Poke handler
; -----------------
poke: func [
port [port!]
index [number! logic! pair!]
value
/local buffer item
][
net-utils/net-log ["Pick at " data "index"]
either #"/" = last port/target [
buffer: at port/locals (2 * index? port) - 1
poke* buffer (2 * index) - 1 value
buffer: at port/state/inBuffer index? port
poke* buffer index value
][
buffer: at port/state/inBuffer index? port
poke* buffer index value
]
value
]
; -------------------
; HEAP Remove handler
; -------------------
remove: func [
"Remove operation."
port [port!] "An open port spec"
/local buffer cmd parms
][
net-utils/net-log ["Remove of" port/scheme]
either #"/" = last port/target [
buffer: at port/locals (2 * index? port) - 1
buffer: remove*/part buffer 2 * port/state/num
buffer: at port/state/inBuffer index? port
buffer: remove*/part buffer port/state/num
][
buffer: at port/state/inBuffer index? port
buffer: remove*/part buffer port/state/num
]
port/state/tail: length? head buffer
at port index? buffer
]
; ------------------
; HEAP Query handler
; ------------------
query: func [
port [port!]
/clear
][
net-utils/net-log ["query at " data "index"]
if select-heap rejoin [port/path port/target] root-heap [
either #"/" = last port/target [
port/status: 'directory
][
port/status: 'file
]
]
none
]
; ----------------------
; HEAP get-modes handler
; ----------------------
get-modes: func [
port [port!] "An open port spec"
modes "A mode block"
][
get-modes* port
]
; ----------------------
; HEAP set-modes handler
; ----------------------
set-modes: func [
port [port!] "An open port spec"
modes "A mode block"
][
set-modes* port
]
; ===================================================================
; HEAP protocol utilities
; ===================================================================
split-full-path: func [
file [file!]
/local path target result block
][
file: clean-path file
block: result: parse/all file "/"
forall block [
change* block to-file rejoin [first block "/"]
]
if #"/" <> last file [
remove* back tail last result
]
next result
]
select-heap: func [
file [file!]
heap [block!]
/local item
][
file: split-full-path file
while [all [
not tail? file
heap: select* heap first file
]][
file: next file
]
heap
]
find-heap: func [
file [file!]
heap [block!]
][
file: split-full-path file
item: heap
while [all [
not tail? file
heap: find*/skip item first file 2
]][
file: next file
item: second heap
]
heap
]
insert-heap: func [
file [file!]
heap [block!]
/locals item
][
file: split-full-path file
while [not tail? file][
if none? item: select* heap first file [
insert* tail heap reduce [first file item: make block! 0]
]
heap: item
file: next file
]
item
]
; --------------------------
; HEAP Register the protocol
; --------------------------
net-utils/net-install HEAP self none
]
; *******************************************************************
; SQL protocol context
; *******************************************************************
; This object contains 4 things:
; - the SQL engine (various functions)
; - the SQL protocol
; - the DATA protocol
; - some utilities
sql-ctx: context [
; *******************************************************************
; SQL parsing
; *******************************************************************
result: cols: where: values: value: item: item-1: item-2: sql-err: sql-exp: none
; Parse function
sql-parse-request: func [
"Return an SQL Rebol dialect block from SQL request string"
request [string!] "The request string"
][
sql-exp: request
result: copy []
cols: copy []
values: copy []
value: copy []
sql-err: 'SQL
either not parse/all request [
any space-set [
sqlc-select
|
sqlc-insert
|
sqlc-update
|
sqlc-delete
]
][
return throw-error [type: 'sql id: 'syntax arg1: sql-err arg2: sql-exp]
][
result
]
]
; Basic charset
end-of-line: [ "^/^M" | "^/" ]
end-of-line-set: charset "^/^M"
space-set: charset " ^-^/^M"
any-space: [any space-set]
some-space: [some space-set]
num-set: charset "1234567890"
alpha-set: charset "abcdefghijklmnopqrstuvwxyz"
name-set: union num-set alpha-set
str-set: complement charset "'"
; Basic type
sqlc-integer: [some num-set]
sqlc-decimal: [some num-set opt ["." some num-set]]
sqlc-number: [copy item sqlc-integer (item: to integer! item)| sqlc-decimal (item: to integer! item)]
sqlc-string: [any str-set]
sqlc-name: [alpha-set any name-set]
sqlc-full-name: [sqlc-name "." sqlc-name | sqlc-name]
; -------------------------------------------------------
; SELECT clause
; -------------------------------------------------------
sqlc-select: [
any space-set "SELECT" some space-set (append result [SELECT])
opt ["DISTINCT" some space-set (append result [DISTINCT])]
[
"FROM" some space-set
|
sqlc-column any [any space-set "," any space-set sqlc-column] some space-set "FROM" some space-set
] (append result [FROM])
sqlc-table any [any space-set "," any space-set sqlc-table]
opt [
some space-set "WHERE" some space-set (
append result [WHERE]
insert*/only where: copy [] result
) sqlc-where
]
opt [
some space-set "GROUP" some space-set "BY" (append result [GROUP BY])
some space-set sqlc-group any [any space-set "," any space-set sqlc-group]
]
opt [
some space-set "ORDER" some space-set "BY" (append result [ORDER BY])
some space-set sqlc-order any [any space-set "," any space-set sqlc-order]
]
any space-set
]
; Column clause
sqlc-column: [
sqlc-count
|
"*" (append result '*)
|
copy item [sqlc-name ".*"] (append result to word! item)
|
(insert/only where: copy [] to paren! copy []) sqlc-value (append result first where)
]
; COUNT clause
sqlc-count: [
"COUNT" any space-set "(" any space-set ["UNIQUE" some space-set | none]
sqlc-count-col any [any space-set "," any space-set sqlc-count-col]
any space-set ")"
]
; Count column clause
sqlc-count-col: ["*" | sqlc-full-name]
; From table clause
sqlc-table: [
copy item-1 sqlc-name [
some space-set opt ["AS" some space-set] copy item-2 sqlc-name (
insert*/only tail result compose [(to word! item-1) AS (to word! item-2)]
)
|
none (append result to word! item-1)
]
]
; WHERE clause
sqlc-where: [
sqlc-where-condition
any [
any space-set copy item ["AND" | "OR"] some space-set (append first where to word! uppercase item)
sqlc-where-condition
]
]
; Test clause
sqlc-where-condition: [
"(" any space-set (
insert/only where to paren! copy []
) sqlc-where any space-set ")" (
insert*/only tail second where first where
remove where
)
|
sqlc-value any space-set [
"LIKE" (append first where 'LIKE) some space-set [
"'" copy item sqlc-string "'" (
item: copy item
replace/all item #"%" #"*"
replace/all item #"_" #"?"
append first where item
)
|
sqlc-value
]
|
copy item ["<>" | "<=" | ">=" | "=" | "<" | ">"] (append first where to word! item)
any space-set sqlc-value
]
]
; GROUP BY clause
sqlc-group: [
copy item sqlc-integer (append result to integer! item)
|
copy item sqlc-full-name (append result to word! item)
]
; ORDER BY clause
sqlc-order: [
[
copy item sqlc-integer (item-1: to integer! item)
|
copy item sqlc-full-name (item-1: to word! item)
][
some space-set copy item-2 ["ASC" | "DESC"] (insert*/only tail result compose [(item-1) (to word! uppercase item-2)])
|
none (insert*/only tail result item-1)
]
]
; Value clause
sqlc-value: [
[
"(" any space-set (
insert/only where to paren! copy []
) sqlc-value any space-set ")" (
insert*/only tail second where first where
remove where
)
|
"'" copy item sqlc-string "'" (append first where item)
|
copy item sqlc-full-name (append first where to word! item)
|
sqlc-number (append first where item)
]
opt [
any space-set copy item ["+" | "-" | "*" | "/"] (append first where to word! item)
any space-set sqlc-value
]
]
; -------------------------------------------------------
; INSERT clause
; -------------------------------------------------------
sqlc-insert: [
any space-set sql-exp: "INSERT" opt [ some space-set "INTO"] (append result [INSERT INTO])
some space-set sql-exp: sqlc-table
opt [
any space-set "(" sql-exp: copy item sqlc-name (append cols to word! item) any [
any space-set "," any space-set sql-exp: copy item sqlc-name (append cols to word! item)
]
any space-set ")" (insert*/only tail result cols)
]
[
any space-set "VALUES" (append result [VALUES]) sqlc-insert-values any [
any space-set "," any space-set sqlc-insert-values
]
|
any space-set sqlc-select
]
]
; INSERT values
sqlc-insert-values: [
any space-set "(" (
insert*/only tail result copy []
insert/only where: copy [] last result
) sql-exp: sqlc-value
any [
any space-set "," any space-set sql-exp: sqlc-value
] ")"
]
; -------------------------------------------------------
; UPDATE clause
; -------------------------------------------------------
sqlc-update: [
any space-set sql-exp: "UPDATE" (append result [UPDATE])
some space-set sql-exp: sqlc-table
some space-set sql-exp: "SET" (append result [SET]) some space-set sql-exp: sqlc-set
any [
any space-set "," any space-set sql-exp: sqlc-set
]
opt [
some space-set "WHERE" some space-set (
append result [WHERE]
insert*/only where: copy [] result
) sqlc-where
]
]
sqlc-set: [
copy item sqlc-name any space-set "=" (
insert* tail result to set-word! item
insert*/only where: copy [] result
) sql-exp: sqlc-value
]
; -------------------------------------------------------
; DELETE clause
; -------------------------------------------------------
sqlc-delete: [
any space-set sql-exp: "DELETE" some space-set "FROM"(append result [DELETE FROM])
some space-set sql-exp: sqlc-table
opt [
some space-set "WHERE" some space-set (
append result [WHERE]
insert*/only where: copy [] result
) sqlc-where
]
]
; *******************************************************************
; SQL Engine
; *******************************************************************
; ===================================================================
; sql-query function
; ===================================================================
sql-query: func [
"Execute sql like request on a database"
query [string! block!]
port [port!]
/local word distinct cols col from where order-by table values value if-not-exist scheme spec
][
if string? query [sql-exp: query: sql-parse-request query]
distinct: if-not-exist: false
cols: copy* []
where: copy* []
order-by: copy* []
values: copy* []
scheme: 'data
spec: copy* []
sql-exp: query
sql-err: 'SQD
either parse query [
sql-exp: 'SELECT (word: 'SELECT)
['DISTINCT (distinct: true) | none]
copy cols to 'FROM
'FROM copy from [to 'WHERE | to 'ORDER | to end]
[
'WHERE copy where [to 'ORDER | to end]
|
none
]
[
'ORDER 'BY copy order-by to end
|
none
]
end
|
sql-exp: 'INSERT (word: 'INSERT)
opt 'INTO set table word!
opt [set cols block!]
'VALUES copy values to end
|
sql-exp: 'UPDATE (word: 'UPDATE)
set table word!
'SET copy values [to 'WHERE | to end]
[
'WHERE copy where to end
|
none
]
|
sql-exp: 'DELETE (word: 'DELETE)
'FROM set table word!
[
'WHERE copy where to end
|
none
]
|
sql-exp: ['CREATE 'TABLE] (word: 'CREATE-TABLE)
set table word!
set cols block!
['IF 'NOT 'EXISTS (if-not-exist: true) | none]
[
'TYPE '= [
set scheme word!
|
set spec block! (
scheme: first spec
spec: copy next spec
)
]
|
none
]
|
sql-exp: ['DROP 'TABLE] (word: 'DROP-TABLE)
set table word!
][
switch/default word [
SELECT [
sql-select distinct cols from where order-by port
]
INSERT [
sql-insert table cols values port
]
UPDATE [
sql-update table values where port
]
DELETE [
sql-delete table where port
]
CREATE-TABLE [
sql-create-table table cols if-not-exist scheme spec port
]
DROP-TABLE [
sql-drop-table table port
]
][
return throw-error [type: 'sql id: 'syntax arg1: sql-err arg2: sql-exp]
]
][
return throw-error [type: 'sql id: 'syntax arg1: sql-err arg2: sql-exp]
]
]
; ===================================================================
; SQL-SELECT function
; ===================================================================
; This function return the rows corresponding to the cols, from, where and order-by clause
; It does 4 things :
; - normalize the cols clause (replace the * and table.* element by corresponding cols)
; - normalize the where clause (add parenthesis when necessary and translate the LIKE clause)
; - generate dynamicaly the code that
; - extract the data from the database
; - join the tables (if many)
; - execute the where condition
; - obtain the columns
; - apply the distinct flag if any
; - sort the result
; - return the result
; The result is a block of block (one for each resulting row)
; If the where block is empty, the function return all the row
; The join is done even if the where clause is empty (this is not true in SQL)
; Return a block of block (one for each resulting row)
sql-select: func [
distinct [logic!]
cols [block!]
from [block!]
where [block!]
order-by [block!]
port [port!]
/local result spec body rows index way
][
; Normalize the cols, from and where clause
; -----------------------------------
from: to-rebol-from from
cols: either empty? cols [
[*]
][
to-rebol-cols cols from port
]
where: either empty? where [
[true]
][
to-rebol-where where
]
order-by: to-rebol-path order-by
; Extract the data, applies joins, where and cols clause
; ------------------------------------------------------
result: rows: copy* []
set [spec body] make-do-select cols from where port
bind body 'result
use spec body
; Applies the distinct clause
; ---------------------------
if distinct [result: unique result]
; Applies the order by clause
; ---------------------------
if not empty? order-by [
foreach item head reverse copy order-by [
set [index way] either block? item [
item
][
reduce [item 'asc]
]
if not integer? index [
index: index? find cols reduce [index]
]
either way = 'desc [
sort/compare/reverse result index
][
sort/compare result index
]
]
]
; return the result
; -----------------
result
]
; -------------
; to-rebol-from
; -------------
; This function normalize the from clause in order to be compatible with Rebol, can be
; FROM table table ...
; FROM table AS alias ... !!! To remove -> not good
; FROM [table alias] ...
; FROM [table AS alias] ...
; or combination of above
to-rebol-from: func [
from [block!]
/local table item1 item2
][
table: copy* []
parse from [any [
into [
copy item1 word! opt 'AS copy item2 word! (
append table reduce [first item2 first item1]
)
]
|
copy item1 word! 'AS copy item2 word! (
append table reduce [first item2 first item1]
)
|
copy item1 word! (
append table reduce [first item1 first item1]
)
]]
table
]
; -------------
; to-rebol-cols
; -------------
; This function normalize the cols clause in order to be compatible with Rebol
; It replace * and alias.* by the corresponding columns
; Return a normalized cols clause (block of column or alias/column)
to-rebol-cols: func [
cols [block!]
from [block!]
port [port!]
/local result rule p item1 item2
][
cols: to-rebol-path cols
result: copy* []
foreach item cols [
set [item1 item2] to-block item
either item1 = '* [
foreach [item1 item2] from [
foreach item get-cols item2 port [
item: first to-block item
insert*/only tail result to-path reduce [item1 item]
]
]
][
either item2 = '* [
item2: first select/skip from item1 2
foreach item get-cols item2 port [
item: first to-block item
insert*/only tail result to-path reduce [item1 item]
]
][
insert*/only tail result item
]
]
]
result
]
; --------------
; to-rebol-where
; --------------
; This function normalize the where clause in order to be compatible with Rebol
; - Column names are normalized
; - Clause before or after AND or OR are placed between parenthesis
; AND is applied before OR
; sample : a = 1 and b = 2 or a = 2 ==>> ((a = 1) and (b = 2)) or (a = 2)
; - LIKE is changed to
; tail? any [find/any/match "*"]
; Return the normalized where clause
to-rebol-where: func [
where [block!]
/local result item item-1 item-2
][
result: copy* []
where: to-rebol-path where
parse where [
any [
end
break
|
'OR copy item [to 'OR | to end] (
append result 'OR
if parse item [paren!] [item: to-block first item]
insert*/only tail result to-paren to-rebol-where item
)
|
copy item to 'OR (
if parse item [paren!] [item: to-block first item]
insert*/only tail result to-paren to-rebol-where item
)
|
'AND copy item [to 'AND | to end] (
append result 'AND
if parse item [paren!] [item: to-block first item]
append result to-rebol-where item
)
|
copy item to 'AND (
if parse item [paren!] [item: to-block first item]
append result to-rebol-where item
)
|
copy item to end (
if parse item [paren!] [item: to-rebol-where to block! first item]
parse item [
; 'LIKE copy item-2 to end (
; item: compose/deep [tail? any [find/any/match (item-2) "*"]]
; )
; |
copy item-1 to 'LIKE 'LIKE copy item-2 to end (
item: compose/deep [tail? any [find/any/match (item-1) (item-2) "*"]]
)
|
to end
]
insert*/only tail result to-paren item
)
]
]
result
]
; --------------
; to-rebol-path
; --------------
; This function normalize the block or paren to remove the dot notation
; Return a normalized block
to-rebol-path: func [
block [block! paren!]
/local result p
][
result: copy* []
parse block rule: [any [
set p word! (
if find to string! p "." [
p: parse/all to-string p "."
forall p [change p to-word first p]
p: to path! head p
]
insert*/only tail result p
)
|
set p [block! | paren!] (
insert*/only tail result to-rebol-path p
)
|
set p any-type! (
insert*/only tail result p
)
]]
either block? block [
result
][
to-paren result
]
]
; ---------------------
; make-do-select
; ---------------------
; This function build dynamicaly a the used spec and body to process the data
; Return the body and the spec
make-do-select: func [
cols [block!]
from [block!]
where [block!]
port [port!]
/local body words set-words £item1 spec
][
spec: copy* [cols]
body: copy* []
foreach [item1 item2] from [
append spec reduce [item1 £item1: to-word rejoin ['£ item1]]
words: copy* []
set-words: copy* []
foreach item get-cols item2 port [
item: first to-block item
append words item
append set-words to-set-word item
]
insert body compose/deep [
(to-set-word item1) context [(set-words) none]
(to-set-word £item1) bind [(words)] in (item1) 'self
bind cols in (item1) 'self
bind where in (item1) 'self
]
]
insert body compose/deep [
cols: [(cols)]
]
append body make-do-loop cols from where port 1
reduce [spec body]
]
; -------------------
; make-do-loop
; -------------------
; This function build dynamicaly a the spec and body that applies the where clause.
; Return the body of the function
make-do-loop: func [
cols [block!]
from [block!]
where [block!]
port [port!]
index [integer!]
/local item item1 item2 code
][
either tail? from [
compose/deep [
if (where) [
rows: insert*/only rows reduce cols
]
]
][
set [item1 item2] from
item: to-word join '£ index
compose/deep [
use [(item)][
(to-set-word item) get-data (to-lit-word item2) port
while [not tail? (item)][
set (to-word rejoin ['£ item1]) first (item)
(make-do-loop cols skip from 2 where port index + 1)
(to-set-word item) next (item)
]
]
]
]
]
; ===================================================================
; SQL-INSERT function
; ===================================================================
; This execute the sql INSERT query
sql-insert: func [
table [word!]
cols [block!]
values [block!]
port [port!]
/local spec rows
][
spec: get-cols-name table port
if empty? cols [
cols: copy spec
]
cols
rows: get-data table port
do compose/deep [
use [(spec)] [
foreach item to-record values false [
set [(cols)] item
insert*/only tail rows reduce [(spec)]
]
]
]
copy* []
]
; ===================================================================
; SQL-UPDATE function
; ===================================================================
; This execute the sql UPDATE query
sql-update: func [
table [word!]
values [block!]
where [block!]
port [port!]
/local spec data
][
where: either empty? where [
[true]
][
to-rebol-where where
]
spec: get-cols-name table port
data: get-data table port
do compose/deep [
use [(spec)][
while [not tail? data][
row: first data
set [(spec)] row
if (where) [
reduce [(values)]
change/only data reduce [(spec)]
]
data: next data
]
]
]
copy* []
]
; ===================================================================
; SQL-DELETE function
; ===================================================================
; This execute the sql DELETE query
sql-delete: func [
table [word!]
where [block!]
port [port!]
/local spec data row
][
where: either empty? where [
[true]
][
to-rebol-where where
]
spec: copy* []
foreach item get-cols table port [
append spec item
]
data: get-data table port
do compose/deep [
use [(spec)][
while [not tail? data][
row: first data
set [(spec)] row
either (where) [
data: remove data
][
data: next data
]
]
]
]
copy* []
]
; ===================================================================
; SQL-CREATE-TABLE function
; ===================================================================
; This execute the sql CREATE TABLE query
table-schema: context [
scheme: none
cols: none
]
sql-create-table: func [
table [word!]
cols [block!]
if-not-exist [none! logic!]
scheme [none! word!]
spec [none! block!]
port [port!]
/local item file url
][
if attempt [port/locals/table/:table] [
either if-not-exist [
return copy* []
][
throw-error [type: 'sql id: 'already-exist arg1: "Table" arg2: table]
]
]
if none? scheme [scheme: 'data]
scheme: to-word lowercase to-string scheme
if none? in system/schemes scheme [
throw-error [type: 'sql id: 'invalid-type arg1: "table" arg2: table arg3: scheme]
]
if none? spec [
spec: copy* []
]
if scheme = 'CSV [
spec: make sql-text spec
spec/format: to-string spec/format
spec/delimiter: any [
select ["CSVDelimited" "," "TabDelimited" "^-" "FixedLength" ""] spec/format
spec/delimiter
";"
]
spec: third spec
]
port/locals/table: make port/locals/table compose/deep [
(to-set-word table) [
scheme: (to-lit-word scheme)
target: (to-file rejoin [table either find to-string table #"." [copy ""][rejoin ["." scheme]]])
schema: [
(spec)
cols: [(cols)]
]
]
]
save-schema port
get-data/new table port
copy* []
]
; ===================================================================
; SQL-DROP-TABLE function
; ===================================================================
; This execute the sql DROP TABLE query
sql-drop-table: func [
table [word!]
port [port!]
/local item data url
][
url: get-url table port
if data: attempt [port/locals/data/:table] [
close* data
port/locals/data: context remove find third port/locals/data to-set-word table
]
if exists? url [delete url]
port/locals/table: context remove find third port/locals/table to-set-word table
save-schema port
copy* []
]
; ===================================================================
; Other function
; ===================================================================
; -----------------
; get-cols function
; -----------------
get-cols: func [
table [word!]
port [port!]
/local spec
][
if none? spec: attempt [port/locals/table/:table] [
throw-error [type: 'sql id: 'not-found arg1: "Table" arg2: table]
]
spec: select spec to-set-word 'schema
select spec to-set-word 'cols
]
; ----------------------
; get-cols-name function
; ----------------------
get-cols-name: func [
table [word!]
port [port!]
/local result
][
result: copy* []
foreach item get-cols table port [
append result either block? item [ first item ][ item ]
]
result
]
; -----------------
; get-data function
; -----------------
get-data: func [
table [word!]
port [port!]
/new
/locals spec data
][
if none? spec: attempt [port/locals/table/:table] [
throw-error [type: 'sql id: 'not-found arg1: "Table" arg2: table]
]
spec: compose [
(spec)
path: (port/path)
]
if none? data: attempt [port/locals/data/:table] [
port/locals/data: make port/locals/data compose [
(to-set-word table) either new [data: open*/new spec][data: open* spec]
]
]
data
]
; ----------------
; get-url function
; ----------------
get-url: func [
table [word!]
port [port!]
/local spec word
][
if none? spec: attempt [port/locals/table/:table] [
throw-error [type: 'sql id: 'not-found arg1: "Table" arg2: table]
]
spec: context spec
to-url rejoin [spec/scheme ":" port/path spec/target]
]
; --------------------
; load-schema function
; --------------------
load-schema: func [
port [port!]
/local file table spec item cols name value
][
either port/target = %schema.ini [
file: open/lines rejoin [port/path port/target]
table: copy* []
forall file [
parse/all first file [
"[" copy name to "]" to end (
name: trim name
append table compose/only [
(to-set-word name) (spec: compose/only [
target: (to-file name)
schema: (item: compose/only [cols: (cols: copy* [])])
])
]
)
|
"ColNameHeader=" copy value to end (
append item compose/only [
ColNameHeader: (do value)
]
)
|
"Format=Delimited(" copy value to ")" to end (
append spec compose [scheme: 'CSV]
append item compose/only [
Format: "Delimited"
Delimiter: (value)
]
)
|
"Format=" copy value to end (
value: trim value
append spec compose [scheme: (select ["CSVDelimited" 'CSV "TabDelimited" 'CSV "FixedLength" 'FEXED] value)]
append item compose [
Format: (value)
Delimiter: (select ["CSVDelimited" "," "TabDelimited" "^-" "FixedLength" ""] value)
]
)
|
"Col" to "=" skip copy name to " " skip copy type to " width " " width " copy length to end (
insert*/only tail cols compose [
(to-word name) (to-word type) (to-integer length)
]
)
|
"Col" to "=" skip copy name to " " skip copy type to end (
insert*/only tail cols compose [
(to-word name) (to-word type)
]
)
|
copy name to "=" skip copy value to end (
append item compose/only [
(to-set-word trim name) (value)
]
)
]
]
close file
port/locals/table: context table
][
port/locals/table: context load rejoin [port/path port/target]
]
]
; --------------------
; save-schema function
; --------------------
save-schema: func [
port [port!]
/local file index schema
][
either port/target = %schema.ini [
file: open*/new/lines rejoin [port/path port/target]
foreach [table spec] third port/locals/table [
append file rejoin ["[" to-word table "]"]
schema: third make sql-text select spec to-set-word 'schema
foreach [name value] schema [
name: lowercase to-string name
switch/default name [
"format" [
value: lowercase value
either value = "delimited" [
append file rejoin ["format=Delimited(" select schema to-set-word 'delimiter ")"]
][
append file rejoin ["format=" value]
]
]
"delimiter" [
]
"cols" [
index: 0
foreach col value [
index: index + 1
either block? col [
append file reform [rejoin ["Col" index "=" col/1] col/2 either col/3 [reform ['width col/3]][""]]
][
append file reform [rejoin ["Col" index "=" col] 'char 'width 255]
]
]
]
][
append file rejoin ["" name "=" value]
]
]
]
close* file
][
if file? port/target [
save rejoin [port/path port/target] third port/locals/table
]
]
]
; ===================================================================
; sql-locals prototype
; ===================================================================
sql-locals: context [
; Table object
; -------------
table: context []
; Data object
; -----------
data: context []
]
; ===================================================================
; sql-text prototype
; ===================================================================
sql-text: context [
ColNameHeader: True
Format: "Delimited"
Delimiter: ";"
MaxScanRows: 0
CharacterSet: "OEM"
]
; ===================================================================
; SQL Error model
; ===================================================================
system/error: make system/error [
sql: context [
code: 8100
type: "SQL Error"
syntax: ["Syntax error" :arg1 "in query expression" :arg2]
already-exist: [:arg1 :arg2 "already exist"]
invalid-type: [:arg3 "is an invalid type for" :arg1 :arg2 ]
not-found: [:arg1 :arg2 "could not be found. Make sur the object exists and that you spell it correctly"]
]
]
; ===================================================================
; SQL Protocol Handler
; ===================================================================
; This object contains the handler for the SQL protocol.
context [
; ----------------
; SQL Init handler
; ----------------
init: func [
port
spec [url! block!]
/local scheme file path target locals
][
net-utils/net-log reduce ["Initializing" mold/only spec "for" to-string port/scheme]
either url? spec [
set [scheme file] parse/all spec ":"
set [path target] split-path file: to-file file
if not find target #"." [
set [path target] compose [(dirize file)]
]
port/path: clean-path to-rebol-file path
if none? target [
either exists? rejoin [port/path %schema.ini] [
target: %schema.ini
][
target: %schema.ctl
]
]
port/target: target
port/url: spec
port/locals: make sql-locals []
][
spec: context spec
if none? locals: attempt [spec/database] [
locals: []
]
locals: make sql-locals locals
if none? path: attempt [spec/path] [
path: %.
]
path: dirize to-file path
port/path: path
port/target: 'transient
port/locals: locals
]
if none? port/target [
net-error reform ["No target file for" port/scheme "is specified"]
]
]
; ----------------
; SQL Open handler
; ----------------
open: func [
port
/local target file
][
net-utils/net-log reduce ["Opening port for" to-string port/scheme]
port/status: 'file
port/state/flags: port/state/flags or system/standard/port-flags/pass-thru
if file? port/target[
target: join port/path port/target
query* file: make port! target
either file/status [
load-schema port
][
make-dir port/path
save-schema port
]
]
port/state/inBuffer: copy* []
port/state/tail: length? port/state/inBuffer
port
]
; -----------------
; SQL Close handler
; -----------------
close: func [
port [port!]
][
net-utils/net-log reduce ["Closing port for" to-string port/scheme]
foreach item second port/locals/data [
if port? item [
close* item
]
]
port
]
; ------------------
; SQL Update handler
; ------------------
update: func [
port [port!]
][
net-utils/net-log reduce ["Updating port for" to-string port/scheme]
foreach item next second port/locals/data [
if port? item [
update* item
]
]
port
]
; ----------------
; SQL Pick handler
; ----------------
pick: func [
port [port!]
][
pick* port/state/inBuffer (port/state/index + port/state/num)
]
; ----------------
; SQL Copy handler
; ----------------
copy: func [
port [port!]
][
net-utils/net-log ["Copy of" port/scheme]
copy*/part at port/state/inBuffer index? port port/state/num
]
; ------------------
; SQL Insert handler
; ------------------
insert: func [
port [port!]
value [string! block!]
/local result
][
net-utils/net-log ["Insert of " port/state/num "bytes"]
; port/state/inBuffer: sql-query to-block value port
port/state/inBuffer: sql-query value port
port/state/tail: length? port/state/inBuffer
head port
]
; ---------------------
; SQL get-modes handler
; ---------------------
get-modes: func [
port [port!]
modes
][
get-modes* port
]
; ---------------------
; SQL set-modes handler
; ---------------------
set-modes: func [
port [port!] "An open port spec"
modes
][
set-modes* port
]
; -------------------------
; SQL Register the protocol
; -------------------------
net-utils/net-install SQL self none
]
]
AI