REBOL [
Title: "SQLite Driver"
Author: "Christopher Ross-Gill"
Comment: "Based on the driver by Ashley Truter - http://www.dobeash.com/"
Purpose: "REBOL script to utilize the SQLite3 Database Library"
Notes: "Extracted from the QuarterMaster project"
Date: 17-Jun-2009
Settings: [
spaces: [
"system" %/Volumes/Sandbox/QM/test/
"space" %/Volumes/Sandbox/Data/
;-- Add more for your convenience
"home" %/Users/chris/
]
]
]
do http://reb4.me/r/as
settings: make context [
spaces: []
zone: 0:00
] any [
system/script/args
system/script/header/settings
]
;--## EXTENDED CORE FUNCTIONS
;-------------------------------------------------------------------##
context [
with: func [object [any-word! object! port!] block [any-block!] /only][
block: bind block object
either only [block][do block]
]
envelop: func [data [any-type!]][either any-block? data [data][reduce [data]]]
fortype: func [type [datatype!] block [block!] f [any-function!] /local val][
parse block [some [to type set val type (f :val)]]
]
export: func [words [word! block!] /to dest [object!] /local word][
dest: any [dest system/words]
fortype word! to-block words func [word] [
set/any in dest word get/any word
; protect in dest word
]
]
export [with fortype envelop export]
]
;--## STRING HELPERS
;-------------------------------------------------------------------##
context [
pad: func [text length [integer!] /with padding [char!]][
padding: any [padding #"0"]
text: form text
skip tail insert/dup text padding length negate length
]
interpolate: func [body [string!] escapes [any-block!] /local out][
body: out: copy body
parse/all body [
any [
to #"%" body: (
body: change/part body reduce any [
select/case escapes body/2 body/2
] 2
) :body
]
]
out
]
export [pad interpolate]
]
;--## PORT HELPERS
;-------------------------------------------------------------------##
context [
add-protocol: func ['name id handler /with block][
unless in system/schemes name [
system/schemes: make system/schemes compose [
(to-set-word name) #[none]
]
]
set in system/schemes name make system/standard/port compose [
scheme: name
port-id: (id)
handler: (handler)
passive: #[none]
cache-size: 5
proxy: make object! [host: port-id: user: pass: type: bypass: #[none]]
(block)
]
]
codes: [read 1 write 2 append 4 new 8 binary 32 lines 64 direct 524288]
get-port-flags: func [port words][
remove-each word copy words [
word: select codes word
word <> (port/state/flags and word)
]
]
chars: ; charset [#"a" - #"z" #"A" - #"Z" #"0" - #"9" "-_!+%"]
#[bitset! 64#{AAAAACIo/wP+//+H/v//BwAAAAAAAAAAAAAAAAAAAAA=}]
space!: context [
root: domain: path: target: folder: file: suffix: mark: #[none]
]
spaces: compose [(settings/spaces)]
get-space: func [base [url!] location [url!] /local space][
base: form base
space: make space! [uri: :location]
if all with/only space [
parse/all uri [
base
copy domain some chars #"/"
copy path any [some [some chars | #"."] #"/"]
copy target opt [any chars #"." 1 10 chars]
copy mark opt ["#" some chars]
]
root: select spaces domain
] with/only space [
path: all [path to-file path]
target: all [target to-file target]
folder: join root any [path ""]
file: join folder any [target ""]
suffix: suffix? file
all [mark mark: to-issue next mark]
self
]
]
export [add-protocol get-port-flags get-space]
]
;--## VALUES HELPERS
;-------------------------------------------------------------------##
context [
default-zone: any [
all [
time? settings/zone
settings/zone
] 0:00
]
pad-zone: func [time /flat][
rejoin [
pick "-+" time/hour < 0
pad abs time/hour 2
either flat [""][#":"]
pad time/minute 2
]
]
date-codes: [
#"a" [copy/part pick system/locale/days date/weekday 3]
#"A" [pick system/locale/days date/weekday]
#"b" [copy/part pick system/locale/months date/month 3]
#"B" [pick system/locale/months date/month]
#"C" [to-integer date/year / 100]
#"d" [pad date/day 2]
#"D" [date/year #"/" pad date/month 2 #"/" pad date/day 2]
#"e" [date/day]
#"h" [time/hour + 11 // 12 + 1]
#"H" [pad time/hour 2]
#"i" [any [get-class [st 1 21 31 nd 2 22 rd 3 23] date/day "th"]]
#"I" [pad time/hour + 11 // 12 + 1 2]
#"j" [pad date/julian 3]
#"J" [date/julian]
#"m" [pad date/month 2]
#"M" [pad time/minute 2]
#"p" [pick ["am" "pm"] time/hour < 12]
#"P" [pick ["AM" "PM"] time/hour < 12]
#"S" [pad round time/second 2]
#"t" [#"^-"]
#"T" [pad time/hour 2 #":" pad time/minute 2 #":" pad round time/second 2]
#"u" [date/weekday]
#"U" [pad to-integer date/julian + 6 - (date/weekday // 7) / 7 2]
#"w" [date/weekday // 7]
#"W" [pad to-integer date/julian + 7 - date/weekday / 7 2]
#"y" [pad date/year // 100 2]
#"Y" [date/year]
#"z" [pad-zone/flat zone]
#"Z" [pad-zone zone]
]
form-date: func [date [date!] format [any-string!] /gmt /local time zone nyd][
all [
date/time date/zone
date/time: date/time - date/zone
date/time: date/time + date/zone: either gmt [0:00][default-zone]
]
time: any [date/time 0:00]
zone: any [date/zone settings/zone 0:00]
interpolate format bind date-codes 'date
]
export [form-date]
]
;--## SQLITE3 CORE
;-------------------------------------------------------------------##
sqlite3: make object! [
comment {Tested on Version 3.5.4}
log: func [st][]
to-struct: func [spec [block!]][make struct! spec none]
get-flag: func [flags flag][found? find flags flag]
api: context [
library: load/library switch/default fourth system/version [
; 2 [%sqlite3.dylib]
2 [%/usr/lib/libsqlite3.dylib]
3 [%sqlite3.dll]
][%libsqlite3.so]
sqlite-func: func [name specs][
make routine! specs library join "sqlite3_" name
]
version: make tuple! do sqlite-func "libversion" [return: [string!]]
open: sqlite-func "open" [
name [string!] db-handle [struct! [[integer!]]]
return: [integer!]
]
close: sqlite-func "close" [
db [integer!]
return: [integer!]
]
complete?: sqlite-func "complete" [
q [string!]
return: [integer!]
]
prepare: sqlite-func "prepare_v2" [
db [integer!] dbq [string!] len [integer!] stmt [struct! [[integer!]]] dummy [struct! [[integer!]]]
return: [integer!]
]
reset: sqlite-func "reset" [ ; Required by IMPORT
stmt [integer!]
return: [integer!]
]
step: sqlite-func "step" [
stmt [integer!]
return: [integer!]
]
finalize: sqlite-func "finalize" [
stmt [integer!]
return: [integer!]
]
error-for: sqlite-func "errmsg" [
db [integer!]
return: [string!]
]
bind-null: sqlite-func "bind_null" [
stmt [integer!] idx [integer!]
return: [integer!]
]
bind-int: sqlite-func "bind_int" [
stmt [integer!] idx [integer!] val [integer!]
return: [integer!]
]
bind-double: sqlite-func "bind_double" [
stmt [integer!] idx [integer!] val [decimal!]
return: [integer!]
]
bind-text: sqlite-func "bind_text" [
stmt [integer!] idx [integer!] val [string!] len [integer!] fn [integer!]
return: [integer!]
]
bind-blob: sqlite-func "bind_blob" [
stmt [integer!] idx [integer!] val [string!] len [integer!] fn [integer!]
return: [integer!]
]
column-count: sqlite-func "column_count" [
stmt [integer!]
return: [integer!]
]
column-name: sqlite-func "column_name" [
stmt [integer!] idx [integer!]
return: [string!]
]
column-type: sqlite-func "column_type" [
stmt [integer!] idx [integer!]
return: [integer!]
]
column-int: sqlite-func "column_int" [
stmt [integer!] idx [integer!]
return: [integer!]
]
column-double: sqlite-func "column_double" [
stmt [integer!] idx [integer!]
return: [decimal!]
]
column-text: sqlite-func "column_text" [
stmt [integer!] idx [integer!]
return: [string!]
]
column-blob: sqlite-func "column_blob" [
stmt [integer!] idx [integer!]
return: [string!]
]
]
; // Error Handling
raise: use [codes][
codes: [
0 "Successful result"
1 "SQL error or missing database"
2 "An internal logic error in SQLite"
3 "Access permission denied"
4 "Callback routine requested an abort"
5 "The database file is locked"
6 "A table in the database is locked"
7 "A malloc() failed"
8 "Attempt to write a readonly database"
9 "Operation terminated by sqlite_interrupt()"
10 "Some kind of disk I/O error occurred"
11 "The database disk image is malformed"
12 "(Internal Only) Table or record not found"
13 "Insertion failed because database is full"
14 "Unable to open the database file"
15 "Database lock protocol error"
16 "(Internal Only) Database table is empty"
17 "The database schema changed"
18 "Too much data for one row of a table"
19 "Abort due to constraint violation"
20 "Data type mismatch"
21 "Library used incorrectly"
22 "Uses OS features not supported on host"
23 "Authorization denied"
100 "sqlite_step() has another row ready"
101 "sqlite_step() has finished executing"
]
system/error: make system/error [
sqlite: make object! [
code: 1000
type: "SQLite Error"
message: none
]
]
func [[throw] db [integer!] error [string! integer!] /local status][
log ["Error:" error]
case/all [
integer? error [status: error error: api/error-for db]
error = "not an error" [error: select codes status]
none? error [error: "Unhandled error"]
]
system/error/sqlite/message: :error
throw make error! [sqlite message]
]
]
; // Status
false?: ok?: func [code [integer!]][code = 0]
true?: func [code [integer!]][code = 1]
busy?: func [code [integer!]][code = 5]
row?: func [code [integer!]][code = 100]
done?: func [code [integer!]][code = 101]
; // Statements
statement!: context [
owner: id: status: direct: result: args: sql: none
row: none
step: func [[catch]][
log ["Step:" id sql]
loop 30 [
unless busy? status: api/step id [break]
wait 0.02
]
switch/default status [
100 [true] 101 [none]
][
raise owner/id status
]
]
width: does [api/column-count id]
headers: none
get-headers: does [
log ["Get Headers:" id sql]
headers: make block! width
repeat col width [
append headers as word! api/column-name id -1 + col
]
]
get-row: has [out col hdrs][
log ["Get Row:" id sql]
out: make block! 2 * width
col: 0
repeat idx width [
all [owner/headers? insert tail out pick headers idx]
insert/only tail out status: switch api/column-type id col [
1 [api/column-int id col]
2 [api/column-double id col]
3 [api/column-text id col]
4 [debase/base api/column-blob id col 16]
5 [none]
]
col: :idx
]
if owner/headers? [new-line/all/skip out true 2]
log ["Got Row:" id mold out]
out
]
prep-date: func [date [date!]][
case [
all [date/time date/zone][form-date/gmt date "%Y-%m-%d %H:%M:%S"]
date/time [form-date date "%Y-%m-%d %H:%M:%S"]
date [form-date date "%Y-%m-%d"]
]
]
prep-time: func [time [time!]][pad time 5]
bind-one: func [idx val][
case [
date? val [val: prep-date val]
time? val [val: prep-time val]
]
unless ok? status: switch/default type?/word val [
integer! [api/bind-int id idx val]
decimal! [api/bind-double id idx val]
binary! [api/bind-blob id idx val: enbase/base val 16 length? val 0]
none! [api/bind-null id idx]
][
api/bind-text id idx val: form val length? val 0
][
raise owner/id status
]
]
bind: func [[catch]][
log ["Bind:" id sql]
args: reduce any [args []]
repeat idx length? args [bind-one idx pick args idx]
]
reset: does [all [ok? status: api/reset id true]]
finalize: does [
log ["Finalize:" id sql]
all [
ok? status: api/finalize id
remove find owner/statements self
true
]
]
]
; // Database
database!: context [
id: file: status: statements: headers?: flat?: none
open: func [[catch] file [file!] /new][
log ["Open:" mold file]
self/file: :file
unless any [new exists? file][
raise 0 rejoin ["Database file <" file "> not found"]
]
either ok? status: api/open to-local-file file id: to-struct [id [integer!]][
statements: make block! 10
log ["Opened:" id/id]
id: id/id
][raise 0 status]
]
queries: 0
prepare: func [[catch] sql /local args][
log ["Recycles:" queries]
all [100 = queries: queries + 1 queries: 0 recycle]
log ["Prepare:" id sql]
all [
sql: head insert copy ";" take args: compose envelop sql
false? api/complete? sql
raise id "SQL Syntax Error"
]
log ["Preparing: Syntax OK"]
sql: make statement! compose/only [
owner: (self)
sql: (sql)
args: (args)
id: to-struct [id [integer!]]
status: api/prepare owner/id sql length? sql id to-struct [[integer!]]
id: id/id
]
either ok? sql/status [
log ["Prepared:" id sql/id]
insert statements sql
return sql
][
log ["Aborted:" id]
sql/finalize
throw raise id sql/status
]
]
purge: has [statement][
while [statement: take statements][statement/finalize]
]
close: func [[catch]][
log ["Close:" id]
case [
not id [raise 0 "Nothing to Close"]
not empty? statements [raise id "Statements Pending"]
not ok? status: api/close id [raise id status]
true [
log ["Closed:" id]
id: none return true
]
]
]
]
]
;--## SQLITE3 INTERFACE
;-------------------------------------------------------------------##
context with/only sqlite3 [
; INTERFACE
language: context [
query!: [
statement: values: table: columns: values: where: order: #[none]
]
prepare: has [out][
out: make string! 30
case/all []
]
]
add-protocol sqlite 0 context [
port-flags: system/standard/port-flags/pass-thru
init: func [port url /local spec][
unless spec: all [url? url get-space sqlite:// url][
make error! rejoin ["SQLite URL <" url "> is invalid."]
]
with port [
url: spec/uri
host: spec/domain
path: join spec/root any [spec/path ""]
target: spec/target
]
]
open: func [port /local flags][
with port [
flags: compose [
(get-port-flags port [read write new direct])
(any [state/custom []])
]
locals: make database! [
file: join path target
status: either get-flag flags 'new [
open/new file
][
open file
]
headers?: not get-flag flags 'raw
flat?: get-flag flags 'flat
]
state/flags: state/flags or port-flags
]
]
select: func [port statement /local out end][
out: copy []
statement: with port/locals [prepare statement]
statement/bind
statement/get-headers
while [end: tail out statement/step] either port/locals/flat? [
[append out statement/get-row new-line end true]
][
[append/only out statement/get-row new-line end true]
]
statement/finalize
out
]
insert: func [port statement][
statement: with port/locals [prepare statement]
statement/bind
statement/step
statement/finalize
]
close: func [port][
with port/locals [close]
port
]
remove: func [port][
with port/locals [purge]
port
]
]
]