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
        ]
    ]
]