REBOL [ Title: "TRETBASE" Author: "Paul Tretter" Email: ptretter@tretbase.com Date: 12-April-2008 Version: 1.0 Description: { TRETBASE is a Relational Database Management System. } License: { Copyright (c) 2008, Paul Tretter All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. Neither the name of Paul Tretter or TRETBASE nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. } Note: { TRETBASE assigns values to 'db 'i 'n 'master 'db-path and 'r globally, so programmers should avoid using those global variables. } Bugs: "Report bugs or suggestions to feedback@tretbase.com" ] {Master block is comprise such that it each section starts with database and followed by a block of info The info block will contain the following in index order: 1. String name of database (string!) 2. Database counter (this is the number of records before reconciliation) (integer!) 3. This is the ACTUAL number of records in the database. (integer!) 4. Database creation date (time!) 5. Database modification date. (time!) 6. Table field data in index order (block!) 7. Table's line termination (string!) } unless value? 'db-path [db-path: %./data/] unless exists? db-path [make-dir db-path] either exists? join db-path %master.db [ either (size? join db-path %master.db) > 0 [master: do load join db-path %master.db][master: to-list copy []] ][ write join db-path %master.db master: to-list copy [] ] db: context [ buffer-size: 1024 ; this is the buffer size used globally for file reads. default-term: "^/" ; default line termination for records. verify: func [[throw] 'dbase [word!]][ unless present? :dbase [return rejoin ["Fail - " :dbase " not found."]] ] modified?: func ['dbase [word!]][ verify :dbase fifth select master :dbase ] created?: func ['dbase [word!]][ verify :dbase fourth select master :dbase ] create: func ['dbase [word!] data [block!]][ forskip master 2 [if equal? :dbase first master [master: head master return rejoin [:dbase " database already exists"]]] if exists?/full :dbase [ return "Database cannot be created when existing files are found in data directory for this database name" ] forall data [data: skip data 1 poke data 1 attempt [to-datatype data/1]] unless parse data [some [[string! | word!] datatype!]][return "Syntax Error!"] append master :dbase append/only master reduce head insert copy [0 0 now/precise now/precise data default-term] to-string :dbase foreach item [".db" "-deletions.db" "-changes.db"][close open rejoin [db-path :dbase item]] master: head master commit rejoin ["OK - Database " :dbase " created."] ] release: func ['dbase [word!]][ verify :dbase forskip master 2 [ if equal? :dbase first master [ master: head remove/part master 2 commit return rejoin ["OK - Database " :dbase " deleted."] ] ] ] exists?: func ['dbase [word!] /full /local ret][ foreach item [".db" "-deletions.db" "-changes.db"][ ret: system/words/exists? rejoin [db-path :dbase item] unless full [break] unless ret [break] ] ret ] count?: does [return (length? master) / 2] list: has [dbx][ dbx: copy [] forskip master 2 [append dbx first master] unless empty? dbx [return dbx] none ] inflate: func ['dbase [word!] /local item][ poke item: select master :dbase 2 item/2 + 1 poke item 3 item/3 + 1 ] deflate: func ['dbase [word!] /local item][poke item: select master :dbase 3 item/3 - 1] modify: func ['dbase [word!]][poke select master :dbase 5 now/precise] records?: func ['dbase [word!]][verify :dbase third select master :dbase] present?: func ['dbase [word!]][if found? find list :dbase [return true] false] header?: func ['dbase [word!] /quiet][ unless quiet [verify :dbase] sixth select master :dbase ] commit: does [save join db-path %master.db master] eor: func ['dbase [word!] termination [string!]][ verify :dbase if (records? :dbase) > 0 [return "Cannot change end of record assignment while records exists"] poke select master :dbase 7 termination commit ] eor?: func ['dbase [word!] /quiet][ unless quiet [verify :dbase] seventh select master :dbase ] column: func ['dbase [word!] 'task [word!] 'field [block! string! word! integer!] /local port port2 term ops buffer][ unless any [:task = 'add :task = 'drop][return "Fail - Task argument must be either 'add or 'drop value."] verify :dbase unless exists?/full :dbase [return "Fail - Database files missing."] if any [ system/words/exists? rejoin [db-path :dbase ".db.clm"] system/words/exists? rejoin [db-path :dbase "-deletions.db.clm"] system/words/exists? rejoin [db-path :dbase "-changes.db.clm"] system/words/exists? rejoin [db-path :dbase ".hdr"] ][ return "Cannot drop columns from database while clm files exist." ] either :task = 'drop [ task: true ][ task: false unless all [ block? :field parse :field [[string! | word!] word!] datatype? attempt [to-datatype second :field] ][ return "Fail - Syntax Error - Must be [[String! | Word!] Datatype!]." ] ] if any [word? :field string? :field][ either all [task not find header?/quiet :dbase :field][ return "Fail - Column Field Name not found." ][ field: (index? find header?/quiet :dbase field) + 1 / 2 ] ] if all [task any [:field < 1 :field > ((length? header?/quiet :dbase) / 2)]][return "Fail - Index out of range!"] ops: copy [] bind operations 'dbase foreach item ["-deletions.db" "-changes.db" ".db"][ port2: open/seek rejoin [db-path :dbase item ".tmp"] term: eor?/quiet :dbase 7 port: open/lines/read/direct/with rejoin [db-path :dbase item] term switch item [ "-deletions.db" [ either task [ insert tail ops select operations "-deletions.db-5" ][ insert tail ops select operations "-deletions.db-6" ] ] "-changes.db" [ either task [ insert tail ops select operations "-changes.db-5" ][ insert tail ops select operations "-changes.db-6" ] ] ".db" [ either task [ insert tail ops select operations ".db-5" ][ insert tail ops select operations ".db-6" ] ] ] while [not none? buffer: copy/part port buffer-size][ foreach raw-record buffer [bind ops 'raw-record reduce ops] ] clear ops close port close port2 wait .1 rename rejoin [db-path :dbase item] rejoin [to-string :dbase item ".clm"] rename rejoin [db-path :dbase item ".tmp"] rejoin [to-string :dbase item] ] save rejoin [db-path :dbase ".hdr"] sixth select master :dbase either task [ remove/part at sixth select master :dbase (:field * 2 - 1) 2 ][ append sixth select master :dbase :field ] modify :dbase commit if task [return rejoin ["OK - Column dropped from " :dbase "."]] rejoin ["OK - Column added to " :dbase "."] ] reconcile: function ['dbase [word!]][ ;locals port port2 port3 term deletions change-count change-counter ops changes record-number sel change-recs buffer ][ verify :dbase unless exists?/full :dbase [return "Fail - Database files missing."] if any [ system/words/exists? rejoin [db-path :dbase ".db.bak"] system/words/exists? rejoin [db-path :dbase "-deletions.db.bak"] system/words/exists? rejoin [db-path :dbase "-changes.db.bak"] ][ return "Cannot reconcile this database while backup files exist." ] term: eor?/quiet :dbase deletions: copy [] changes: copy [] ops: copy [] bind operations 'dbase sel: func [s v /change p][forskip s 2 [if = v first s [either change [poke s 2 p][return first next s]]]] port2: open/lines/direct/with rejoin [db-path :dbase ".rcl"] term foreach item ["-deletions.db" "-changes.db" ".db"][ switch item [ "-deletions.db" [insert tail ops select operations "-deletions.db-7"] "-changes.db" [insert tail ops select operations "-changes.db-7"] ".db" [change-recs: extract changes 2 insert tail ops select operations ".db-7"] ] port: open/lines/direct/read/with rejoin [db-path :dbase item] term while [not none? buffer: copy/part port buffer-size][ foreach raw-record buffer [bind ops 'raw-record reduce ops] ] clear ops close port ] attempt [close port3] close port2 wait .1 foreach item ["-deletions.db" "-changes.db" ".db"][ rename rejoin [db-path :dbase item] rejoin [to-string :dbase item ".bak"] ] rename rejoin [db-path :dbase ".rcl"] rejoin [to-string :dbase ".db"] foreach item ["-deletions.db" "-changes.db"][close open rejoin [db-path :dbase item]] modify :dbase commit rejoin ["OK - " :dbase " is now reconciled."] ] flatten: func [ {Returns a new block with desired blocks flattened or removed} blk [block!] "block to flatten" /fine "Flattens blocks to finest representation" /semi "Flattens to support 'select operations" /full "Flatten fully - ignored with other refinements" /local blk2 fl ][ blk2: copy [] fl: func [b][ either parse b [block!][ b: first b fl b ][ either semi [ insert tail blk2 b ][ either full [ foreach val b [either block? val [fl val][insert tail blk2 val]] ][ insert/only tail blk2 b ] ] ] ] if fine [full: none while [parse blk [block!]][blk: first :blk]] foreach item :blk [ either block? item [fl item][insert tail blk2 item] ] blk2 ] index-check?: func [data arg /change newval /local sub-ic? iret][ sub-ic?: func [sd][ forall sd [ either equal? first sd :arg [ if change [poke sd 1 :newval] iret: true ][ if block? first sd [sub-ic? first sd] ] ] ] sub-ic? data if iret [return iret] false ] check-rec: func [rec rl][ unless equal? length? rec length? rl [return "Fail - Length? mismatch on record."] unless parse rec rl [return "Fail - Type? mismatch on record."] ] change: func ['db [word!] record-number [integer!] record [block!]][ add/change :db record record-number ] add: func ['dbase [word!] data [block! file!] /change record-num /local flag buffer port2 recs port crr rule header term][ verify :dbase unless exists?/full :dbase [return "Fail - Database files missing."] either file? :data [ unless system/words/exists? :data [return "Fail - Filename not valid or does not exist."] if error? try [data: load data][return "Fail - Error reading import file."] ][ unless parse data [some [block!]][data: append/only copy [] :data] ] if change [unless record-num <= second select master :dbase [return "Record number not found in database"]] header: header?/quiet :dbase term: eor?/quiet :dbase rule: copy [] foreach item header [if datatype? attempt [to-datatype item][insert/only tail rule compose copy ['none! | (item)]]] port: open/seek rejoin [db-path :dbase either change ["-changes.db"][".db"]] if any [find header image! find header 'image!][flag: true] foreach item data [ crr: check-rec item rule if flag [ while [not tail? item][ if image? first item [poke item 1 enbase compress mold/all first item] item: next item ] item: head item ] either none? crr [ either change [ port2: open/read/lines/direct/with rejoin [db-path :dbase "-deletions.db"] term while [not none? buffer: copy/part port2 buffer-size][ foreach item buffer [if equal? record-num first to-block item [close port return "record was deleted"]] ] insert tail port join mold/only to-block join record-num trim/lines mold first :data term close port2 ][ recs: to-integer second select master :dbase insert tail port join mold/only to-block rejoin [recs: recs + 1 trim/lines mold item] term inflate :dbase ] ][ close port return crr ] ] close port modify :dbase commit rejoin ["OK - " either change ["Record changed in "]["Records added to "] :dbase] ] operations: [ "-deletions.db-1" [ foreach raw-record buffer [ attempt [remove at fblk index? remove find head dbrecs first to-block raw-record] ] ] "-deletions.db-2" [ foreach raw-record buffer [ remove find head dbrecs first to-block raw-record ] ] "-deletions.db-3" [close port return "record deleted"] "-deletions.db-5" [insert tail port2 join raw-record term] "-deletions.db-6" [insert tail port2 join raw-record term] "-deletions.db-7" [insert deletions first to-block raw-record] "-changes.db-1" [ ; these operations are for iflag processing foreach raw-record buffer [ parse to-block raw-record [set n integer! set r block! any-type!] flag: false foreach index-data r [ i: index-data fnc-ret: reduce fnc if all [not unset? last fnc-ret equal? last fnc-ret true][ either not find head dbrecs n [ insert dbrecs n insert/only tail fblk reduce fnc-val flag: true break ][ remove at fblk index? remove find head dbrecs n insert dbrecs n insert/only tail fblk reduce fnc-val flag: true break ] ] ] unless flag [attempt [remove at fblk index? remove find head dbrecs n]] ] ] "-changes.db-4" [ ; these operations are for fnc processing foreach raw-record buffer [ parse to-block raw-record [set n integer! set r block! end!] flag: false fnc-ret: reduce fnc if all [not unset? last fnc-ret equal? last fnc-ret true][ either not find head dbrecs n [ insert dbrecs n insert/only tail fblk reduce fnc-val flag: true ][ remove at fblk index? remove find head dbrecs n insert dbrecs n insert/only tail fblk reduce fnc-val flag: true ] ] unless flag [attempt [remove at fblk index? remove find head dbrecs n]] ] ] "-changes.db-2" [ ; these operations are for standard processing foreach raw-record buffer [ parse to-block raw-record [set record-number integer! set record block! end!] flag: false while [not tail? record][ if all [findflex form first record (requestf) any [ equal? type? first record (trequest) equal? pick dtypes index? record 'any-type! equal? (request) 'none! ]][ unless find head dbrecs record-number [insert dbrecs record-number] flag: true break ] record: next record ] unless flag [remove find head dbrecs record-number] ] ] "-changes.db-3" [rch: copy second to-block raw-record] ".db-1" [ ; these operations are for iflag processing foreach raw-record buffer [ parse to-block raw-record [set n integer! set r block! any-type!] foreach index-data r [ i: index-data fnc-ret: reduce fnc if all [not unset? last fnc-ret equal? last fnc-ret true][ insert/only tail fblk reduce fnc-val insert dbrecs n break ] ] ] ] "-changes.db-5" [ head remove at second raw-record: to-block raw-record field insert tail port2 join mold/only raw-record term ] "-changes.db-6" [ raw-record: to-block raw-record insert tail second raw-record 'none! insert tail port2 join mold/only raw-record term ] "-changes.db-7" [ unless find deletions record-number: first to-block raw-record [ either not find changes record-number [ insert tail changes reduce [record-number 1] ][ sel/change changes record-number (sel changes record-number) + 1 ] ] ] ".db-4" [ ; these operations are for fnc processing foreach raw-record buffer [ parse to-block raw-record [set n integer! set r block! any-type!] fnc-ret: reduce fnc if all [not unset? last fnc-ret equal? last fnc-ret true][ insert/only tail fblk reduce fnc-val insert dbrecs n ] ] ] ".db-2" [ ; these operations are for standard processing if findflex form buffer (requestf) [ foreach raw-record buffer [ record: second to-block raw-record while [not tail? record][ if findflex form first record (requestf) [ if any [ equal? type? first record (trequest) equal? pick dtypes index? record 'any-type! equal? (request) 'none! ][ insert dbrecs first to-block raw-record break ] ] record: next record ] ] ] ] ".db-3" [ if all [value? 'rch not none? rch][ close port if flag [ manage-data rch ] return rch ] if flag [ record: second to-block raw-record manage-data record return record ] close port return second to-block raw-record ] ".db-5" [ head remove at second raw-record: to-block raw-record field insert tail port2 join mold/only raw-record term ] ".db-6" [ raw-record: to-block raw-record insert tail second raw-record 'none! insert tail port2 join mold/only raw-record term ] ".db-7" [ unless find deletions record-number: first to-block raw-record [ either not find change-recs record-number [ insert tail port2 raw-record ][ change-count: sel changes record-number change-counter: 1 port3: open/direct/lines/read/with rejoin [db-path :dbase "-changes.db"] term while [not none? buffer: copy/part port3 buffer-size][ foreach change-item buffer [ if (change-record-number: first to-block change-item) = record-number [ either change-counter = change-count [ insert tail port2 change-item ][ change-counter: change-counter + 1 ] ] ] ] ] ] ] ] retrieve: func ['dbase [word!] record-num [integer!] /local port flag rch buffer record ops term dtypes][ verify :dbase unless record-num <= second select master :dbase [return "Fail - Record not found."] term: eor?/quiet :dbase ops: copy [] bind operations 'dbase dtypes: extract/index sixth select master :dbase 2 2 if any [find dtypes image! find dtypes 'image!][flag: true] manage-data: func [rcd][ while [not tail? dtypes][ if any [equal? first dtypes 'image! equal? first dtypes image!][ poke rcd (index? dtypes) to-image first to-block decompress debase pick rcd (index? dtypes) ] dtypes: next dtypes ] dtype: head dtypes ] foreach item ["-deletions.db" "-changes.db" ".db"][ insert tail ops select operations join item "-3" port: open/lines/read/direct/with rejoin [db-path :dbase item] term while [not none? buffer: copy/part port buffer-size][ foreach raw-record buffer [ if equal? record-num first to-block raw-record [bind ops 'raw-record reduce ops] ] ] clear ops close port ] ] search: function ['dbase [word!] request /wild /match][ ;locals port record-number record buffer fnc-ret fnc fnc-val trequest dtypes rchoice iflag term flag ops findflex requestf dbrecs fblk ][ verify :dbase dbrecs: to-list copy [] dtypes: extract/index sixth select master :dbase 2 2 either block? request [ either parse request [block! block!][ fnc: first request fblk: copy [] fnc-val: second request fields: extract/index sixth select master :dbase 2 1 foreach item fields [if index-check? request item [index-check?/change request item to-path compose [r (index? find fields item)]]] iflag: index-check? request 'i ][ unless any [find dtypes type? request find dtypes type?/word request][return "Datatype not found in database"] requestf: form request trequest: type? request ] ][ unless any [find dtypes type? request find dtypes type?/word request][return "Datatype not found in database"] requestf: form request trequest: type? request ] rchoice: 0 if wild [rchoice: rchoice + 2] if match [rchoice: rchoice + 4] set 'findflex make function! [series value] select [0 [find series value] 2 [find/any series value] 4 [find/case series value] 6 [find/any/case series value]] rchoice ops: copy [] term: eor?/quiet :dbase foreach item [".db" "-changes.db" "-deletions.db"][ switch item [ ".db" [ case [ iflag [insert tail ops select operations ".db-1"] fnc [insert tail ops select operations ".db-4"] not fnc [insert tail ops select operations ".db-2"] ] ] "-changes.db" [ case [ iflag [insert tail ops select operations "-changes.db-1"] fnc [insert tail ops select operations "-changes.db-4"] not fnc [insert tail ops select operations "-changes.db-2"] ] ] "-deletions.db" [ either fnc [insert tail ops select operations "-deletions.db-1"][insert tail ops select operations "-deletions.db-2"] ] ] bind ops 'dbase port: open/lines/direct/read/with rejoin [db-path :dbase item] term while [not none? buffer: copy/part port buffer-size][ reduce compose/deep ops ] clear ops close port ] unset 'r unset 'n unset 'i either fnc [if empty? fblk [return none] return sort fblk][if empty? head dbrecs [return none] sort to-block head dbrecs] ] delete: func ['dbase [word!] record-num [integer! block!] /local recs port buffer term count][ verify :dbase unless exists?/full :dbase [return "Fail - Database files missing."] record-num: to-block record-num unless parse record-num [some [integer!]][return "Fail - Syntax Error!"] count: second select master :dbase remove-each item record-num [item > count] term: eor?/quiet :dbase port: open/read/lines/direct/with rejoin [db-path :dbase "-deletions.db"] term while [not none? buffer: copy/part port buffer-size][ while [not tail? buffer][ remove find record-num to-integer first buffer buffer: next buffer ] ] close port if empty? record-num [return "Fail - Records either already deleted or out of range."] port: open/seek rejoin [db-path :dbase "-deletions.db"] foreach item record-num [insert tail port join item term] close port poke item: select master :dbase 3 item/3 - (length? record-num) modify :dbase commit rejoin ["OK - Record# " :record-num " deleted from " :dbase "."] ] deleted?: func ['dbase [word!] record-num [integer!] /local port buffer term][ verify :dbase term: eor?/quiet :dbase port: open/read/lines/direct/with rejoin [db-path :dbase "-deletions.db"] term while [not none? buffer: copy/part port buffer-size][ while [not tail? buffer][if equal? record-num to-integer first buffer [close port return true] buffer: next buffer] ] close port false ] ]