RFC: addressbook.r

Hi Rebols, after much frustration with gnomecard, I decided to roll my own addressbook, that's what I've got so far. I'd like some comments on - the user interface (I like it this way) - the xml layout (no experience there) - information in the datafile that might be missing/superflouououos (that's just like bananana, you just can't stop, once you started writing it ;-) regards, Ingo -- Attached file included as plaintext by Listar -- REBOL [ Title: "Addressbook" author: "Ingo Hohmann" email: [ingo--2b1--de] date: 31-Oct-2000 file: %addressbook.r history: [ 0.0.6 [ 31-Oct-2000 "added note display" "iho" ] 0.0.5 [ 31-Oct-2000 "added help" "iho" ] 0.0.4 [ 31-Oct-2000 "added add / delete" "iho" ] 0.0.3 [ 30-Oct-2000 "except for persons add works" "iho" ] 0.0.2 [ 29-Oct-2000 "cleaned up" "iho" ] 0.0.1 [ 28-Oct-2000 "first preview" "iho" ] ] version: first history addy: "preview" comments: { This is a little address database system, with an NQA Interface (No Questions Asked) what you type in, will immediately be part of the database (once save is called on exit, BTW how can I catch the close event?). } known-bugs: [ {no testing if changed file-as already exists} {no testing if " is present in fields} ] todo: [ {a lot of cleanups} {update 'update} {sorting} ] ] yamm/import %xml-helper.r addressbook: make object! [ doc: {This object encapsulates the address database} xml-data-block: block! ; parse-xml created block of blocks addressdb-block: block! ; addressdb block in xml-data-block current-data-block: block! ; is set to the block containing the current data current-data-pos: 0 ; position of current-data in addressdb-block current-address-pos: 1 ; position in addressdb-block list current-comm-pos: 1 ; position in communication list current-sub-pos: 1 ; set to either current-comm-pos or current-address-pos current-view-name: string! ; the tag name of the currently shown data ["person" "address" "comm"] add-new-data?: false ; true, if a lists last position is shown (don't change data) current-view: none ; function to show current view current-layout: ; pointer to current layout block ; superflouos? (sp?) current-fields: ; fields shown in current view names: copy [] ; list of names for main list xml-data-file: %address.xml current-view: function! ; function to show the current view load-xml: func ["load xml data file and parse it"] [ xml-data-block: trim-xml parse-xml read xml-data-file addressdb-block: xml-data-block/3/1/3 ] save-xml: func ["save xml data"] [ write xml-data-file xdump xml-data-block ] ;layouts person-layout: [ across text bold "Personal" text "Address" #"^A" [leave show-address] text "Communication" #"^C" [leave show-comm] text "Notes" #"^N" [leave show-note] return tabs 110 text "Filed as" tab file-as: field update: text 200x20 return text "Name" tab first-name: field return text "Last" tab last-name: field return text "Nickname" tab nick-name: field return text "Middle" tab middle-name: field return text "Prefix" tab name-prefix: field return text "Suffix" tab name-suffix: field return text "Birthday" tab birthday: field return tab tab tab button "Delete" [delete-data] ] address-layout: [ across text "Personal" #"^P" [leave address-fields show-person] text bold "Address" text "Communication" #"^C" [leave address-fields show-comm] text "Notes" #"^N" [leave show-note] return tabs 110 text "extended" tab extended: field here: at return text "street" tab street: field return text "postal-code" tab postal-code: field return text "city" tab city: field return text "region" tab region: field return text "post-office" tab post-office: field return text "Country" tab country: field return text "Type" tab attr: field return at here address-list: text-list data addrs [ leave address-fields set 'current-address-pos index? find addrs value add-new-data?: either current-address-pos = length? addrs [true][false] show-address ] return tab tab tab button "Delete" [delete-data] ] comm-layout: [ across text "Personal" #"^P" [leave comm-fields show-person] text "Address" #"^A" [leave comm-fields show-address] text bold "Communication" text "Notes" #"^N" [leave show-note] return tabs 110 text "Value" tab value: field here: at return text "" return text "Type" tab type: field return text "Attributes" tab attr: field return at here comms-list: text-list data comms [ leave comm-fields current-comm-pos: index? find comms value add-new-data?: either current-comm-pos = length? comms [true][false] show-comm ] return tab tab tab button "Delete" [delete-data] ] note-layout: [ across text "Personal" #"^P" [leave comm-fields show-person] text "Address" #"^A" [leave show-address] text "Communication" #"^C" [leave show-comm] text bold "Notes" #"^N" return note: area 450x300 return tab tab tab button "Delete" [delete-data] ] note-fields: copy [ note ] help-layout: [ help-text: area 450x350 across button "View" [show-help/topic 'howto-view] button "Update" [show-help/topic 'howto-update] button "misc" [show-help/topic 'howto-misc] tab button "Close help" [current-view] ] ; lists of fields, to set/get them easily person-fields: copy [] forall person-layout [ if all [ set-word? person-layout/1 'field = person-layout/2 ] [ append person-fields to-word person-layout/1 ] ] person-layout: head person-layout person-fields: next person-fields ; assuming 'file-as is first field address-fields: copy [] forall address-layout [ if all [ set-word? address-layout/1 'field = address-layout/2 ] [ append address-fields to-word address-layout/1 ] ] address-layout: head address-layout comm-fields: copy [] forall comm-layout [ if all [ set-word? comm-layout/1 'field = comm-layout/2 ] [ append comm-fields to-word comm-layout/1 ] ] comm-layout: head comm-layout ; ; display functions ; show-person: func ["displays the name data"][ disp/pane: layout/offset person-layout 0x0 current-view: :show-person current-view-name: "person" current-fields: :person-fields foreach pos current-data-block/3 [ if pos/1 = "person" [ foreach [attr val] pos/2 [ attr: to-word attr x: to-set-path compose [(to-word attr) text] x val ] break ] ] file-as/text: second find current-data-block/2 "file-as" update/text: second find current-data-block/2 "update" show disp ] current-view: :show-person current-layout: person-layout ; needed? current-fields: person-fields show-address: func [ "displays address data" /local addr-pos ][ current-view: :show-address current-view-name: "address" current-fields: :address-fields addrs: copy [] foreach pos current-data-block/3 [ if all [pos/1 = "address" block? pos/2] [ append addrs rejoin [ select pos/2 "postal-code" "," select pos/2 "city" "," select pos/2 "street" ] ] ] append addrs "" disp/pane: layout/offset address-layout 0x0 addr-pos: 0 foreach pos current-data-block/3 [ if all [pos/1 = "address" block? pos/2] [ addr-pos: addr-pos + 1 if addr-pos = current-address-pos [ foreach [attr val] pos/2 [ attr: to-word attr x: to-set-path compose [(to-word attr) text] x val ] break ] ] ] show disp ] show-comm: func [ "displays communication data" /local comm-pos ][ current-view: :show-comm current-view-name: "comm" current-fields: :comm-fields comms: copy [] foreach pos current-data-block/3 [ if all [pos/1 = "comm" block? pos/2] [ append comms rejoin [ select pos/2 "value" either not none? select pos/2 "attr" [rejoin [", " select pos/2 "attr"]][""] ] ] ] append comms "" disp/pane: layout/offset comm-layout 0x0 comm-pos: 0 foreach pos current-data-block/3 [ if all [pos/1 = "comm" block? pos/2] [ comm-pos: comm-pos + 1 if comm-pos = current-comm-pos [ foreach [attr val] pos/2 [ attr: to-word attr x: to-set-path compose [(to-word attr) text] x val ] break ] ] ] show disp ] show-note: func [ "displays the note" /local found? ][ disp/pane: layout/offset note-layout 0x0 current-view: :show-note current-view-name: "note" current-fields: :note-fields found?: false foreach pos current-data-block/3 [ if pos/1 = "note" [ if none? pos/3 [ change at pos 3 [""] ] note/text: pos/3/1 found?: true break ] ] if not found? [ append/only current-data-block/3 copy/deep compose [(current-view-name) none [""]] pos: back tail current-data-block/3 note/text: pos/1/3/1 ] file-as/text: second find current-data-block/2 "file-as" update/text: second find current-data-block/2 "update" show disp ] show-help: func [ "displays the help screen" /topic "show specific help-text" show-this [word!] "the topic string" ][ disp/pane: layout/offset help-layout 0x0 help-text/text: trim/auto any [ if 'howto-view = show-this [ { HOWTO -- View Data: - Change between views Click on Person / Address / Communication, respectively - Show different Persons data: Use up / down cursor keys, or click with the mouse - Show different Address / Communication: Click in the list } ] if 'howto-update = show-this [ { HOWTO -- Update data: - Update data: just change data in the fields as you like - Delete data: hit the delete key, if you are on the "Person" screen, the complete person will be deleted, in other screens, the data shown at the moment. - Add new data: click the last (empty) position in any list, a new data-set will be added - Update data on disk: Currently data on disk will only be updated once you click the "Save & Exit" Button } ] if 'howto-misc = show-this [ { HOWTO -- Miscallenous: - Send feedback: Click on my email address } ] { Addressbook help ---------------- This addressbook has an NQA/WYSIWYG User Interface, NQA: No Questions Asked -> You'll never get asked if you _really_ want to do that WYSIWYG: Data you see on the screen is in the database (except for an update timelag) Now click on a button to get specific help } ] show disp ] h: 0 set-current-data: func [ "sets position in data block, etc" pos /local new-name ][ current-data-pos: pos: max 1 min length? names pos append clear name-l/picked pick names pos show name-l if current-data-pos = length? names [ new-name: copy "Unnamed" either not find names new-name [ append/only addressdb-block compose/deep ["data" ["file-as" (new-name) "update" (to-string now)] [["person" [] none]]] create-names show name-l focus file-as ][ request/ok {Please rename previously added data first} current-data-pos: current-data-pos - 1 ] ] current-data-block: pick addressdb-block (current-data-pos) current-address-pos: 1 current-comm-pos: 1 ] ; ; check changes ; leave: func [ { tests all fields and if one is dirty updates the database (iho) globals used: current-fields, current-view-name } /local dirty count-pos txt-path txt ] [ foreach fld current-fields [ dirty: to-path compose [(:fld) dirty?] if dirty [break] ] if dirty [ ; one of the fields is changed ... current-sub-pos: any [ all [current-view-name = "address" current-address-pos] all [current-view-name = "comm" current-comm-pos] 1 ] if add-new-data? [ append/only current-data-block/3 copy/deep compose [(current-view-name) [] none] ] count-pos: 0 foreach tag-block current-data-block/3 [ if all [tag-block/1 = current-view-name block? tag-block/2] [ count-pos: count-pos + 1 if count-pos = current-sub-pos [ foreach fld2 head current-fields [ txt-path: to-path compose [(:fld2) text] txt: txt-path fld2: to-string fld2 either pos2: find tag-block/2 fld2 [ change next pos2 txt ] [ append tag-block/2 compose [(fld2) (txt)] ] ] break ] ] ] if all ["person" = current-view-name file-as/dirty?] [ probe current-data-block create-names ] ] ] create-names: func [ {creates the name list} ][ clear names if block? addressdb-block [ foreach a addressdb-block [ ;; needs error handling ... append names select a/2 "file-as" ] if not "" = last names [ append names "" ] ] ] delete-data: func [ {delete a complete person, or address/comm data} /local current-sub-pos count-pos ][ either "person" = current-view-name [ remove at addressdb-block current-data-pos create-names set-current-data current-data-pos - 1 current-view ][ current-sub-pos: any [ all [current-view-name = "address" current-address-pos] all [current-view-name = "comm" current-comm-pos] 0 ; to trap errors, if new displays are added ] count-pos: 0 data-block: current-data-block/3 forall data-block [ if current-view-name = data-block/1/1 [ count-pos: count-pos + 1 if count-pos = current-sub-pos [ remove data-block current-view break ] ] ] ] ] ; ; start the gui now ; start: func [ "starts up the gui" /local adr first last ] [ create-names main: layout [ title center rejoin [ "Addressbook (Ver " system/script/header/version " " system/script/header/addy ")"] across name-l: text-list data names [ set-current-data index? find names value current-view ] 200x400 h: at disp: box 550x480 at h + 456x-24 across space 4 arrow left keycode [up] [leave set-current-data current-data-pos - 1 current-view] arrow right keycode [down] [leave set-current-data current-data-pos + 1 current-view] at 20x500 text "Ingo Hohmann" text "<[ingo--2b1--de]>" [send-text/to [ingo--2b1--de]] tab button "Help" [show-help] tab tab button "Save & Exit" [leave save-xml unview/all halt] ] set-current-data 1 current-view view main ] ] addressbook/load-xml addressbook/start -- Attached file included as plaintext by Listar -- <addressdb> <data file-as="Joe User" update="28-Oct-2000/18:42:55+2:00"> <person birthday="1970-01-01" name-suffix="md" name-prefix="dr. h.c." middle-name="X." first-name="Joe" last-name="User" nick-name="Joey" /> <comm type="url" attr="personal" value="http://www.web-page.de" /> <comm type="email" attr="Internet" value="[joe--user--com]" /> <comm type="tel" attr="PREF;WORK;HOME;VOICE;FAX;MSG;CELL;PAGER;BBS;MODEM;CAR;ISDN;VIDEO" value="0700/JOE-USER" /> <address country="User Land" postal-code="4711" region="All around here" city="Compcity" street="Pentium-Street" extended="at the seven dwarfs" post-office="just hand it to any passenger" /> <note> Here comes a note test </note> </data> <data file-as="Joe User jun." update="28-Oct-2000/18:42:55+2:00"> <person birthday="1970-01-01" name-suffix="jun." middle-name="X." first-name="Joe" last-name="User" nick-name="Joey" /> <comm type="url" attr="personal" value="http://www.web-page-jun.de" /> <comm type="email" attr="Internet" value="[joe-jun--user--com]" /> <comm type="tel" attr="PREF;WORK;HOME;VOICE;FAX;MSG;CELL;PAGER;BBS;MODEM;CAR;ISDN;VIDEO" value="0700/JOE-USER" /> <address country="User Land" postal-

Sorry, my previous post missed a helper script, that's needed to make it work ... Here it is. P.S.: you can change yamm/import %xml-helper.r to do %xml-helper.r without any bad side-effects. regards, Ingo -- Attached file included as plaintext by Listar -- [REBOL [ Title: "XML helpers" Author: [jn "Joel Neely" iho "Ingo Hohmann"] email: [iho [ingo--2b1--de]] ] trim-xml: func [ {trim whitespace from parse-xml created blocks (jn)} b [block!] /local content item ][ content: third b if found? content [ while [not tail? content] [ item: first content either block? item [ trim-xml item content: next content ][ either 0 = length? trim item [ remove content ][ content: next content ] ] ] if 0 = length? head content [ b/3: none ] ] b ] _xdump: func [ {xdump internal helper (jn)(iho)} b [block!] {xml structure} indent [string!] /start "starting the recursion" /local tag next-indent was-string out prin print ][ prin: func [s][append out s] print: func [s][append out join s newline] out: "" if start [clear out] tag: trim to-string first b prin join copy indent [join copy "<" tag] if block? second b [ foreach [n v] second b [ prin join copy " " [either string? n [trim n][n] {="} form v {"}] ] ] either not block? third b [ print " />" ][ print ">" next-indent: join copy indent " " was-string: false foreach x third b [ was-string: not any-block? x either was-string [ if 0 < length? trim x [ print join copy next-indent x ] ][ _xdump x next-indent ] ] print join copy indent [copy "</" trim tag ">"] ] if start [out] ] xdump: func [ {pretty print a block created from parse-xml (jn)(iho)} b [block!] {the xml structure from parse-xml} /complete {doesn't omit the outer blocks (normally document none [])} ][ either complete [ _xdump/start b copy "" ][ _xdump/start first third b copy "" ] ] build-xml-tag: func [ "Generates a tag from a composed block. (iho)" blk [block!] "Block of parens to evaluate and other data" /stand-alone "creates a stand-alone (self-closing) tag" /local out in ][ append out: copy # either 0 < length? blk: compose blk [ in: first head blk: next blk either not any-string? in [mold in] [in] ] [#] foreach [att val] blk [ append out rejoin [" " att {="} val {"}] ] ?? out if stand-alone [append out " /"] to-tag trim out ] ] xml-structure: ['document none! xml-element-contents] xml-element-node: [into [xml-element-name xml-element-attributes xml-element-contents]] xml-element-name: [set elt-name string! (print elt-name)] xml-element-attributes: [none! | block!] xml-element-contents: [none! | into [some [xml-element-node | string! ]]] xml-target: http://p.moreover.com/cgi-local/page?index_devoper+xml parse parse-xml read xml-target xml-structure