[REBOL] Object Database
From: jregent:centrum:cz at: 16-Apr-2001 21:12
Hi Carl, Luis, Dr. Turk &comp
I play with Carl's Object Database functions and View too.
Carl's code is now modified in fly by actual field list of current file.
Layout, context, data manipulation function etc. are generated before
doing.
This db-edit we will to use for administration of small files and learning.
I offer cooperation with share, testing, debuging and finishing this code.
Some coment's and idas are welcome.
Field-list can be stored in db-file..
If field is named "web" as (example 5 ), data of this field are not saved.
I thing name "web" is in conflict with internal word?
If are used keys Up/Down many times Rebol crasch (GPF)
Rebol is best :-)
Many thanks for your work and inspiration.
By
Jan Regent
----------------------------------------------------------------------------
------
rebol
Title: "db-edit"
author: "Jan Regent"
need: "view 1.0"
]
;---------------------------------------------------------------------------
--
; db-lib
;---------------------------------------------------------------------------
--
find-data: func [key] [select database key]
remove-data: func [key] [ remove/part find database key 2]
;===========================================================================
======= db actions
save-data: has [data] [
data: copy []
foreach [key obj] database [
append/only data third obj
]
save db-file data
]
save-data-formated: has [data][
save-data
file: read db-file
formated-db-file: to-file join db-file "-temp.dat"
if exists? formated-db-file [delete formated-db-file]
;--------------------------------------------------------------- record
parsing
file: replace file "[[" "[" ;! I don't undestand why save-data saved
record with "[["
file: replace file "]]" "]" ;! debuging needed
while [true] [
parse file [thru "[" copy qrecord to "]" ]
file: remove/part file length? qrecord
if not found? find qrecord field-list/1
delete db-file
qnew-file: split-path db-file
rename formated-db-file qnew-file/2
return
]
write/append/lines formated-db-file "["
;------------------------------------------------------- field parsing
for i 1 ((length? field-list) - 1) 1 [
i1: i + 1
field-label: field-list/:i
field-label2: field-list/:i1
parse qrecord [thru field-label copy qfield to field-label2 ]
write/append/lines formated-db-file join " " [field-label " " qfield]
]
qfield: remove/part qrecord ((index? find qrecord field-label2) + length?
field-label2)
write/append/lines formated-db-file join " " [ field-label2 " " qfield]
write/append/lines formated-db-file "]"
]
]
load-data-template: {has [data] [
data: load/all db-file
clear database
foreach item data [
item: make record item
repend database [item/x-x-key-x-x item]
]
]
}
load-data-gen: has [][
qitem: copy field-list/1
qitem: replace qitem ":" ""
load-data-template: replace load-data-template "x-x-key-x-x" qitem
load-data: do load-data-template
]
db-create: func [ fields [string!]]
[
qfile: split-path db-file
if not exists? qfile/1 [ make-dir/deep qfile/1]
ddf-file: to-file join db-file ".ddf"
write/lines ddf-file "<field-list>"
write/lines/append ddf-file join " " fields
write/lines/append ddf-file "</field-list>"
cmd: join "field-list: [" [ fields "]" ]
debug-log cmd
do cmd
db-context-create
insert-data-gen
insert-data-new
save-data-formated
rec-count: 1
rec-count-save
]
rec-count-save: has []
[
rec-count-file: to-file join db-file ".reccount"
write/lines rec-count-file join "<rec-count> " [rec-count "
</rec-count>" ]
]
rec-count-read: has []
[
rec-count-file: to-file join db-file ".reccount"
parse read rec-count-file [thru "<rec-count>" copy qrec-count to
</rec-count>
]
qrec-count: trim qrec-count
rec-count: to-integer qrec-count
]
db-open: has [][
ddf-file: to-file join db-file ".ddf"
parse read ddf-file [thru "<field-list>" copy fields to "</field-list>" ]
cmd: join "field-list: [" [ fields "]" ]
debug-log cmd
do cmd
db-context-create
insert-data-gen
rec-count-read
]
db-context-create: has []
[
cmd: "context ["
foreach item field-list [cmd: join cmd [item " "]]
cmd: join cmd " none ]"
debug-log cmd
record: do cmd
]
;===========================================================================
==== record actions
save-record: has [][
foreach item field-list [
qitem: replace to-string item ":" ""
cmd: join "rec/" [item " to-string " qitem "/text"]
debug-log cmd
do cmd
]
record-no: (2 * this-record) - 1
do join "database/" [record-no ": rec"]
]
find-record-no: has [][
record-no: (2 * this-record) - 1
rec: find-data database/:record-no
if not none? rec [
unview
focus name
view layout current-layout
]
]
insert-data-gen: has [] [
qfunc: {insert-data: func [}
foreach item field-list [
qitem: copy item
qitem: replace qitem ":" "'"
qfunc: join qfunc [qitem " "]
]
append qfunc "]"
append qfunc newline
;append qfunc { "Insert record into db-file, generated function, key is
x-x-x"}
;qfunc: replace qfunc "x-x-x" field-list/1
append qfunc newline
qfunc: join qfunc [ {[
repend database [
} replace copy field-list/1 ":" "'" {
make record [
}
]
foreach item field-list [
qitem: copy item
qitem: replace qitem ":" "'"
qfunc: join qfunc [" " item " " qitem newline]
]
qfunc: join qfunc {
]
]
]
}
debug qfunc
do qfunc
]
insert-data-new: has []
[
cmd: "insert-data "
foreach item field-list [ cmd: join cmd [{ "" }]]
debug-log cmd
do cmd
]
;========================================================================
view layouts/ actions
gen-form: has []
[
simple-layout: copy []
append simple-layout join {[ h3 } [main-title ]
append simple-layout {
across
;----------------------------------------------------------------------- fields section
}
foreach item field-list [
qline: join " label " [{"} item {" 100x24 right } item { }]
append simple-layout qline
qitem: join "rec/" item
qitem: replace qitem ":" ""
curr-value: to-string do qitem
qline: join {field 362 } [ qitem " return" ]
append simple-layout qline
append simple-layout newline
]
append simple-layout {
;----------------------------------------------------------------------- control section
arrow left keycode [up ] [ show-page "prev-record" ]
arrow right keycode [down ] [ show-page "next-record" ]
label "find: " 42x24 right web: field 362 " " return
guide 125x100
button 100 "New" #"^n" [ show-page "new-record" ]
button "Del" #"^d" [ ] ;show-page "del-record"
button "Close" #"^q" [
save-record
save-data-formated
unview
]
return
]
}
if exists? %db-edit.frm [ delete %db-edit.frm]
write %db-edit.frm simple-layout
]
show-page: func [arrow-key][
save-record
if "prev-record" = arrow-key [
if this-record > 1 [
this-record: this-record - 1
find-record-no
]
]
if "next-record" = arrow-key [
if this-record < rec-count [
this-record: this-record + 1
find-record-no
]
]
if "new-record" = arrow-key [
insert-data-new
rec-count: rec-count + 1
rec-count-save
this-record: rec-count
find-record-no
]
if "del-record" = arrow-key [
remove-data to-word replace field-list/1 ":" ""
rec-count: rec-count - 1
if rec-count = 0 [
rec-count: 1
insert-data-new
]
rec-count-save
if this-record > rec-count [this-record: rec-count]
find-record-no
]
;print [arrow-key this-record ]
]
;===============================================================================================
; main
;=======================================================================
========================
db-edit: func [db-name [file!] fields [string!] ]
[
db-file: copy db-name
if not exists? db-file [db-create fields ]
db-open
load-data-gen
load-data
rec: find-data database/1
main-title: join {"Data: } [ db-name {"} ]
gen-form
current-layout: load %db-edit.frm
;debug-log current-layout
view layout current-layout
]
debug-log: func [text
][
if debug [
write/append/lines %debug.txt ""
write/append/lines %debug.txt ""
write/append/lines %debug.txt ""
write/append/lines %debug.txt to-string text
]
]
;----------------------------------------------------------- <global words>
debug: true
if debug [if exists? %debug.txt [delete %debug.txt]]
record: context []
field-list: []
db-file: %contact-db.dat
main-title: join {"} [ db-file {"} ]
database: []
this-record: 1
rec-count: 0
rec: ""
;---------------------------------------------------------- </global words>
; examples - only one line can be unremarked
;1
db-edit %db\aa.dat {"email:" "name:" "phone:" "web1:" "web3:" }
;2
;db-edit %db\cars.dat {"number:" "color:" "type:" "technical-checking:"
year:
}
;3
;db-edit %db\users.dat {"email:" "name:" "phone:" "id:" "mobile:" }
;4
;db-edit %db\main.cfg {"work-dir:" "backup-dir:" "created:" "rights:" }
;5
;db-edit %db\web.cfg {"name:" "web:" "page:" "rights:" }
-- Attached file included as plaintext by Listar --
-- File: db-edit.r
rebol [
Title: "db-edit"
author: "Jan Regent"
need: "view 1.0"
]
;-----------------------------------------------------------------------------
; db-lib
;-----------------------------------------------------------------------------
find-data: func [key] [select database key]
remove-data: func [key] [ remove/part find database key 2]
;================================================================================== db
actions
save-data: has [data] [
data: copy []
foreach [key obj] database [
append/only data third obj
]
save db-file data
]
save-data-formated: has [data][
save-data
file: read db-file
formated-db-file: to-file join db-file "-temp.dat"
if exists? formated-db-file [delete formated-db-file]
;--------------------------------------------------------------- record parsing
file: replace file "[[" "[" ;! I don't undestand why save-data saved record with "[["
file: replace file "]]" "]" ;! debuging needed
while [true] [
parse file [thru "[" copy qrecord to "]" ]
file: remove/part file length? qrecord
if not found? find qrecord field-list/1 [
delete db-file
qnew-file: split-path db-file
rename formated-db-file qnew-file/2
return
]
write/append/lines formated-db-file "["
;------------------------------------------------------- field parsing
for i 1 ((length? field-list) - 1) 1 [
i1: i + 1
field-label: field-list/:i
field-label2: field-list/:i1
parse qrecord [thru field-label copy qfield to field-label2 ]
write/append/lines formated-db-file join " " [field-label " " qfield]
]
qfield: remove/part qrecord ((index? find qrecord field-label2) + length? field-label2)
write/append/lines formated-db-file join " " [ field-label2 " " qfield]
write/append/lines formated-db-file "]"
]
]
load-data-template: {has [data] [
data: load/all db-file
clear database
foreach item data [
item: make record item
repend database [item/x-x-key-x-x item]
]
]
}
load-data-gen: has [][
qitem: copy field-list/1
qitem: replace qitem ":" ""
load-data-template: replace load-data-template "x-x-key-x-x" qitem
load-data: do load-data-template
]
db-create: func [ fields [string!]]
[
qfile: split-path db-file
if not exists? qfile/1 [ make-dir/deep qfile/1]
ddf-file: to-file join db-file ".ddf"
write/lines ddf-file "<field-list>"
write/lines/append ddf-file join " " fields
write/lines/append ddf-file "</field-list>"
cmd: join "field-list: [" [ fields "]" ]
debug-log cmd
do cmd
db-context-create
insert-data-gen
insert-data-new
save-data-formated
rec-count: 1
rec-count-save
]
rec-count-save: has []
[
rec-count-file: to-file join db-file ".reccount"
write/lines rec-count-file join "<rec-count> " [rec-count " </rec-count>" ]
]
rec-count-read: has []
[
rec-count-file: to-file join db-file ".reccount"
parse read rec-count-file [thru "<rec-count>" copy qrec-count to "</rec-count>" ]
qrec-count: trim qrec-count
rec-count: to-integer qrec-count
]
db-open: has [][
ddf-file: to-file join db-file ".ddf"
parse read ddf-file [thru "<field-list>" copy fields to "</field-list>" ]
cmd: join "field-list: [" [ fields "]" ]
debug-log cmd
do cmd
db-context-create
insert-data-gen
rec-count-read
]
db-context-create: has []
[
cmd: "context ["
foreach item field-list [cmd: join cmd [item " "]]
cmd: join cmd " none ]"
debug-log cmd
record: do cmd
]
;=============================================================================== record
actions
save-record: has [][
foreach item field-list [
qitem: replace to-string item ":" ""
cmd: join "rec/" [item " to-string " qitem "/text"]
debug-log cmd
do cmd
]
record-no: (2 * this-record) - 1
do join "database/" [record-no ": rec"]
]
find-record-no: has [][
record-no: (2 * this-record) - 1
rec: find-data database/:record-no
if not none? rec [
unview
focus name
view layout current-layout
]
]
insert-data-gen: has [] [
qfunc: {insert-data: func [}
foreach item field-list [
qitem: copy item
qitem: replace qitem ":" "'"
qfunc: join qfunc [qitem " "]
]
append qfunc "]"
append qfunc newline
;append qfunc { "Insert record into db-file, generated function, key is x-x-x"}
;qfunc: replace qfunc "x-x-x" field-list/1
append qfunc newline
qfunc: join qfunc [ {[
repend database [
} replace copy field-list/1 ":" "'" {
make record [
}
]
foreach item field-list [
qitem: copy item
qitem: replace qitem ":" "'"
qfunc: join qfunc [" " item " " qitem newline]
]
qfunc: join qfunc {
]
]
]
}
debug qfunc
do qfunc
]
insert-data-new: has []
[
cmd: "insert-data "
foreach item field-list [ cmd: join cmd [{ "" }]]
debug-log cmd
do cmd
]
;======================================================================== view layouts/
actions
gen-form: has []
[
simple-layout: copy []
append simple-layout join {[ h3 } [main-title ]
append simple-layout {
across
;----------------------------------------------------------------------- fields section
}
foreach item field-list [
qline: join " label " [{"} item {" 100x24 right } item { }]
append simple-layout qline
qitem: join "rec/" item
qitem: replace qitem ":" ""
curr-value: to-string do qitem
qline: join {field 362 } [ qitem " return" ]
append simple-layout qline
append simple-layout newline
]
append simple-layout {
;----------------------------------------------------------------------- control section
arrow left keycode [up ] [ show-page "prev-record" ]
arrow right keycode [down ] [ show-page "next-record" ]
label "find: " 42x24 right web: field 362 " " return
guide 125x100
button 100 "New" #"^n" [ show-page "new-record" ]
button "Del" #"^d" [ ] ;show-page "del-record"
button "Close" #"^q" [
save-record
save-data-formated
unview
]
return
]
}
if exists? %db-edit.frm [ delete %db-edit.frm]
write %db-edit.frm simple-layout
]
show-page: func [arrow-key][
save-record
if "prev-record" = arrow-key [
if this-record > 1 [
this-record: this-record - 1
find-record-no
]
]
if "next-record" = arrow-key [
if this-record < rec-count [
this-record: this-record + 1
find-record-no
]
]
if "new-record" = arrow-key [
insert-data-new
rec-count: rec-count + 1
rec-count-save
this-record: rec-count
find-record-no
]
if "del-record" = arrow-key [
remove-data to-word replace field-list/1 ":" ""
rec-count: rec-count - 1
if rec-count = 0 [
rec-count: 1
insert-data-new
]
rec-count-save
if this-record > rec-count [this-record: rec-count]
find-record-no
]
;print [arrow-key this-record ]
]
;===============================================================================================
; main
;===================================================
